Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# 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
Add Comment
Please, Sign In to add comment