SHARE
TWEET

multicolor

edv Nov 15th, 2011 92 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. module Main where
  2.  
  3. import GXL
  4. import System ( getArgs )
  5. import Data.List
  6. import Data.Array
  7. import Text.XML.HaXml.XmlContent
  8. import Text.XML.HaXml.OneOfN
  9.  
  10. type Edges = [Int]
  11. type Station = (Int, Edges, Int)
  12.  
  13. convGxl :: Gxl -> [Station]
  14. convGxl (Gxl _ graphs) = parseG' $ head graphs
  15.   where
  16.     parseG' (Graph _ _ _ ne) = transform' $ parseG'' ne ([], [])
  17.     parseG'' []     n = n
  18.     parseG'' (x:xs) n = case x of
  19.         OneOf3 node -> parseG'' xs (takeNode' node : fst n, snd n)
  20.         TwoOf3 edge -> parseG'' xs (fst n, takeEdge' edge : snd n)
  21.         _           -> parseG'' xs n
  22.     takeNode' (Node attr _ _ _) = (read $ nodeId attr)::Int
  23.     takeEdge' (Edge attr _ _ _) = ((read $ edgeFrom attr)::Int, (read $ edgeTo attr)::Int)
  24.     transform' (n, e) = foldl' (\a node -> (node, findEdges' node e, 0) : a) [] n
  25.     findEdges' n e = foldl' (\a edge ->
  26.         if n == (fst edge)  then (snd edge) : a
  27.             else
  28.                 if n == (snd edge)
  29.                     then (fst edge) : a
  30.                     else a
  31.         ) [] e
  32.  
  33. slf :: [Station] -> ([[Int]], Int)
  34. slf s = slf' sorted (listArray (0,len-1) $ replicate len []) 0
  35.   where
  36.     sorted = sortBy (\e1 e2 ->
  37.         if degree e1 > degree e2
  38.             then LT
  39.             else
  40.                 if degree e1 == degree e2
  41.                     then EQ
  42.                     else GT) s
  43.     len = (length s)
  44.    
  45. slf' :: [Station] -> Array Int [Int] -> Int -> ([[Int]], Int)
  46. slf' [] colors mc = (elems colors, mc)
  47. slf' sts@(s:ss) colors mc =  slf' (delete st sts) (colorize n colorslist) maxcolor
  48.   where
  49.     (st@(n, edg, z),_) = maxSaturation (s, (degree s, saturation s colors)) ss
  50.     maxSaturation w [] = w
  51.     maxSaturation w@(e, (dege, sate)) (x:xs) =
  52.         let satx = saturation x colors
  53.             degx = degree x
  54.         in if degx < dege
  55.             then w
  56.             else if sate < satx
  57.                 then maxSaturation (x, (degx, satx)) xs
  58.                 else maxSaturation w xs
  59.     (colorslist, maxcolor) = let clr = color edg
  60.                              in (clr, max (last clr) mc)
  61.     color :: [Int] -> [Int]
  62.     color edges = take z $ [0..] \\ (nub $ concat
  63.         $ foldr (\node acc -> colors!node : acc) [] edges)
  64.     colorize :: Int -> [Int] -> Array Int [Int]
  65.     colorize node cl = colors // [(node, cl)]
  66.  
  67. degree :: Station -> Int
  68. degree (_,edges,_) = length edges
  69.  
  70. saturation :: Station -> Array Int [Int] -> Int
  71. saturation (_,edges,_) colors = foldr (\node acc ->
  72.     if null (colors!node)
  73.         then acc
  74.         else acc+1) 0 edges
  75.  
  76. main = do
  77.     args <- getArgs
  78.     graph <- fReadXml $ head args
  79.     stations <- readZ $ convGxl (graph::Gxl)
  80.     let (g, n) = slf stations
  81.     putStrLn $ show g
  82.     putStrLn $ show (n+1)
  83.   where
  84.     readZ :: [Station] -> IO [Station]
  85.     readZ st = foldr (\(n,e,_) a -> do
  86.             putStrLn $ "Podaj zapotrzebowanie stacji " ++ show n ++ ": "
  87.             z <- getLine
  88.             aa <- a
  89.             return $ (n,e,(read z)::Int) : aa
  90.         ) (return []) st
  91.  
  92.  
RAW Paste Data
Top