Задача коммивояжёра

import Data.List
import qualified Data.List.Key as K
 
dist :: (Int, Int) -> (Int, Int) -> Float
dist (x1, y1) (x2, y2) = sqrt (f (x1 - x2) ** 2 + f (y1 - y2) ** 2)
    where f = fromIntegral
 
cost :: [(Int, Int)] -> Float
cost xs = sum $ zipWith dist xs (tail xs ++ xs)
 
nearTour :: [(Int, Int)] -> [(Integer, (Int, Int))]
nearTour = f . zip [0..] where
    f [] = []
    f [x] = [x]
    f ((i,p):ps) = (i,p) : f (nxt : delete nxt ps) where
        nxt = K.minimum (dist p . snd) ps
 
main :: IO ()
main = do let praxisTour = nearTour
                [(139, 31),( 41,126),(108, 49),(112,193),(179,188),
                 (212, 24),(245, 50),(167,187),(159,236),(185, 78),
                 ( 27, 63),(101,188),(195,167),( 30, 10),(238,110),
                 (221, 60),( 27,231),(146, 67),(249,172),( 36, 71),
                 ( 37,203),(118, 38),(241,226),(197, 29),(220,186)]
          print (cost $ map snd praxisTour, praxisTour)

          print (cost (map snd praxisTour) + dist (snd $ last praxisTour) (snd $ head praxisTour),
                praxisTour++[head praxisTour])

type Set = Int
 
emptySet :: Set
emptySet = 0
 
setEmpty n = n==0
 
fullSet :: Int -> Int
fullSet n | (n >= 0) && (n <= maxSet) = 2^(n+1)-2 -- element 0 is not there...
          | otherwise = error ("Fullset : illegal set = " ++ show n)
 
addSet i s = d'*e+m
    where (d,m) = divMod s e
          e  = 2^i
          d' = if odd d then d else d+1
 
delSet i s = d'*e+m
    where (d,m) = divMod s e
          e = 2^i
          d' = if odd d then d-1 else d
 
set2List s = s2l s 0
    where s2l 0 _             = []
          s2l n i | odd n     = i : s2l (n `div` 2) (i+1)
                  | otherwise = s2l (n `div` 2) (i+1)
 
maxSet :: Int
--maxSet = truncate (logBase 2 2147483647.0) - 1
maxSet = truncate (logBase 2 (fromInteger (maxBound::Int))) - 1
 
-- start of TSP
 
type TspCoord = (Int,Set)
type TspEntry = (Int,[Int])
 
compTsp :: Graph Int Int -> Int -> Table TspEntry TspCoord 
                         -> TspCoord -> TspEntry 
compTsp g n a (i,k) 
    | setEmpty k = (weight i n g,[i,n])
    | otherwise = minimum [ addFst (findTable a (j, delSet j k))
                                   (weight i j g)
                            | j <- set2List k]
    where addFst (c,p) w = (w+c,i:p)
 
bndsTsp :: Int -> ((Int,Set),(Int,Set))
bndsTsp n =  ((1,emptySet),(n,fullSet n))
 
tsp :: Graph Int Int -> (Int,[Int])
tsp g = findTable t (n,fullSet (n-1))
    where n = length (nodes g)
          t = dynamic (compTsp g n) (bndsTsp n)
 
-- examples of graphs 
 
dm :: Graph Int Int
dm = mkGraph True (1,6) [(i,j,(v1!!(i-1))!!(j-1)) |i<-[1..6],j<-[1..6]]
v1 :: [[Int]]
v1 = [[  0,  4,  1,  6,100,100],
      [  4,  0,  1,100,  5,100],
      [  1,  1,  0,100,  8,  2],
      [  6,100,100,  0,100,  2],
      [100,  5,  8,100,  0,  5],
      [100,100,  2,  2,  5,  0]]
 
-- "Computer Algorithms" by Sara Baase and Allen Van Gelder, Fig. 13.15
bvg :: Graph Int Int
bvg = mkGraph True (1,4) [(i,j,(w!!(i-1))!!(j-1)) |i<-[1..4],j<-[1..4]]
 
w :: [[Int]]
w = [[ 0,  20, 15, 35],
     [ 20,  0, 10, 25],
     [ 15,  10, 0, 12],
     [ 35,  25, 12, 0]]
 
{-
Examples of evaluations and results 
 
tsp dm
(20, [6, 4, 1, 3, 2, 5, 6])
 
tsp bvg
(72,[4,2,1,3,4])
-}