ticketgobble

answer.lhs

62 Afghanistan Antarctica Barbados Botswana Canada Chad China Denmark Ethiopia Guam Guatemala Guernsey Kiribati Latvia Libya Liechtenstein Macao Malawi Martinique Mauritania Mauritius Montenegro Mozambique Namibia Narnia Nauru Netherlands Niger Niue Oman Palau Panama Paraguay Peru Poland Portugal Romania Rwanda Samoa Senegal Serbia Singapore Slovakia Slovenia Somalia Sudan Sweden Switzerland Tajikistan Thailand Togo Tokelau Tonga Turkey Turkmenistan Tuvalu Uganda Ukraine Uzbekistan Vanuatu Zambia Zimbabwe
ENV: haskell
POINT: 可視化

期間が被るノード同士にエッジを引いた無向グラフにおいての最大独立集合問題として
解きました。

このノード数だと相当頑張らないと(頑張っても？)解が得られないと考え、取り敢えず
可視化してみたところ、各独立頂点集合はたかだか18ノードからなる事がわかったため、
各独立頂点集合に対してDFSを行い、解を導きました。

ぱっと見ではノード数の多さにげんなりしましたが、可視化することで行けそうと感じ
たため、可視化の重要性を感じました。

以下に使用したコードを掲載させていただきます。

> {-# LANGUAGE TupleSections #-}
> import Data.Time.Calendar
> import Control.Applicative
> import Control.Monad
> 
> import qualified Data.IntSet   as S
> import qualified Data.Graph as G
> import qualified Data.Tree  as T
> import qualified Data.Array as A
> import Data.Function
> import Data.List
> import System.IO
> 
> toDay :: String -> Day
> toDay s = let (m, _:d) = break (== '/') s
>           in fromGregorian 2000 (read m) (read d)
> 
> readData :: String -> [(String, Range Day)]
> readData s = map go $ lines s
>   where
>     go s' =
>         let (city, _:r) = break (== ' ') s'
>             (st,  _:ed) = break (== '-') r
>         in (city, range (toDay st) (toDay ed))
> 
> data Range a = Range { start :: a, end :: a } deriving (Show, Eq)
> 
> range :: Ord a => a -> a -> Range a
> range a b | a <= b    = Range a b
>           | otherwise = error "Range: a > b"
> 
> overwrap :: Ord a => Range a -> Range a -> Bool
> overwrap (Range as ae) (Range bs be)
>     | ae < bs   = False
>     | be < as   = False
>     | otherwise = True
> 
> main :: IO ()
> main = do
>     d  <- readData <$> readFile "tickets.txt"
>     es <- withFile "graph.dot" WriteMode $ \file -> do
>         hPutStrLn file "graph ticketgobble {"
>         es <- forM d $ \a -> do
>             hPutStrLn file $ (fst a) ++ ";"
>             let con = [ b | b <- dropWhile (/= a) d, overwrap (snd a) (snd b)]
>             mapM_ (\b -> hPutStrLn file $ "  " ++ fst a ++ " -- " ++ fst b ++ ";") (filter (\b -> a /= b) con)
>             return . (fst a, fst a,) . map (\b -> fst b) $ filter (overwrap (snd a) . snd) d
>         hPutStrLn file "}"
>         return es
> 
>     let (g, ef) = G.graphFromEdges' es
>     let cs = map (G.graphFromEdges . map ef . T.flatten) $ G.components g
>     let r = sort . flip concatMap cs $ \(gr,vf,_) ->
>             map ((\(n,_,_) -> n) . vf) $ S.toList $ maximumBy (compare `on` S.size) $ (maximumIndependentSet gr :: [S.IntSet])
>     putStr (show $ length r)
>     mapM_ (\a -> putChar ' ' >> putStr a) r
>     putChar '\n'
> 
> maximumIndependentSet :: MonadPlus m => G.Graph -> m S.IntSet
> maximumIndependentSet g = go S.empty (uncurry enumFromTo $ A.bounds g)
>   where
>     go vs [] = return vs
>     go vs is = msum $ flip map is $ \i ->
>         if S.null $ S.intersection (S.fromList $ g A.! i) vs
>         then go (S.insert i vs) $ filter (/= i) is
>         else return vs