GTALibでTSP

TSP.hs

{-# LANGUAGE RecordWildCards, TupleSections #-}
module Main where

import Data.List(partition)
import GTA.Data.JoinList(Semiring, JoinList, JoinListAlgebra(..),
                         joinize, dejoinize, maxsumsolutionWith)
import GTA.Core(GenericSemiring(..), CommutativeMonoid(..), Bag(..),
                hom, oplus, identity, (<.>), filterBy, aggregateBy)
import Data.Vector.Bit(packInteger, pad)
import Data.Bits(bit, (.|.), (.&.))

problem :: [(Double, Double)]
problem = [ (6734, 1453),
            (2233, 10),
            (5530, 1424),
            (401, 841),
            (3082, 1644),
            (7608, 4458),
            (7573, 3716),
            (7265, 1268),
            (6898, 1885),
            (1112, 2049) ]

main :: IO ()
main = print $ tsp [ [ to `distance` from | to <- problem ] | from <- problem ]
    where len = length problem
          distance (a,b) (c,d) = sqrt $ (a-c)^2 + (b-d)^2

edges :: Int -> Semiring (Int,Int) s -> s
edges n = edgesJ n $ joinize [0..n-1]

edgesJ :: Int -> JoinList Int -> Semiring (Int, Int) s -> s
edgesJ n xs (GenericSemiring {..}) = permute' xs
    where permute' = hom (JoinListAlgebra { times = times,
                                            single = single',
                                            nil = nil })
          single' s = foldr (oplus . single . (s,)) identity $
                      filter (s /=) [0..n-1]
          JoinListAlgebra {..} = algebra
          CommutativeMonoid {..} = monoid

-- 閉路Tester(閉路しかないかを判定する 複数あるかもしれない)
circuits n = (Nothing /=) <.> circuits'
    where circuits' = JoinListAlgebra{..}
          Nothing `times` ys = Nothing
          xs `times` Nothing = Nothing
          Just Nothing `times` ys = ys
          xs `times` Just Nothing = xs
          Just (Just (s, e)) `times` Just (Just (s', e')) =
              if 0 == packInteger ((s .&. s') .|. (e .&. e'))
                 then Just (Just (s .|. s', e .|. e'))
                 else Nothing
          single (s, e) = Just $ Just (pad n (bit s), pad n (bit e))
          nil = Just Nothing

-- 連結Tester(選択したエッジが繋ってるかを判定する)
connected n = ((1 ==) . length) <.> connected'
    where connected' = JoinListAlgebra{..}
          xs `times` ys = foldr (#) [] (xs ++ ys)
          a # xs = foldr (.|.) a ss : ts
              where (ss, ts) = partition ((0 /=) . packInteger . (a .&.)) xs
          single (a,b) = [pad n (bit a) .|. pad n (bit b)]
          nil = []

-- 通行禁止のエッジを指定するTester
forbid edge = id <.> fobidden'
    where fobidden' = JoinListAlgebra{..}
          times = (&&)
          single (a,b) = edge /= (a,b) && edge /= (b,a)
          nil = True

-- TSPを解く
tsp problem = map snd . dejoinize . head $ ans
    where
      (c, Bag ans) = edges size
                     `filterBy` circuits size
                     `filterBy` connected size
--                     `filterBy` forbid (0,2)
                     `aggregateBy` maxsumsolutionWith cost
      size = length problem
      cost (a, b) = - problem !! a !! b