multicolor

module Main where

import GXL
import System ( getArgs )
import Data.List
import Data.Array
import Text.XML.HaXml.XmlContent
import Text.XML.HaXml.OneOfN

type Edges = [Int]
type Station = (Int, Edges, Int)

convGxl :: Gxl -> [Station]
convGxl (Gxl _ graphs) = parseG' $ head graphs
  where
    parseG' (Graph _ _ _ ne) = transform' $ parseG'' ne ([], [])
    parseG'' []     n = n
    parseG'' (x:xs) n = case x of
        OneOf3 node -> parseG'' xs (takeNode' node : fst n, snd n)
        TwoOf3 edge -> parseG'' xs (fst n, takeEdge' edge : snd n)
        _           -> parseG'' xs n
    takeNode' (Node attr _ _ _) = (read $ nodeId attr)::Int
    takeEdge' (Edge attr _ _ _) = ((read $ edgeFrom attr)::Int, (read $ edgeTo attr)::Int)
    transform' (n, e) = foldl' (\a node -> (node, findEdges' node e, 0) : a) [] n
    findEdges' n e = foldl' (\a edge ->
        if n == (fst edge)  then (snd edge) : a
            else
                if n == (snd edge)
                    then (fst edge) : a
                    else a
        ) [] e

slf :: [Station] -> ([[Int]], Int)
slf s = slf' sorted (listArray (0,len-1) $ replicate len []) 0
  where
    sorted = sortBy (\e1 e2 ->
        if degree e1 > degree e2
            then LT
            else
                if degree e1 == degree e2
                    then EQ
                    else GT) s
    len = (length s)

slf' :: [Station] -> Array Int [Int] -> Int -> ([[Int]], Int)
slf' [] colors mc = (elems colors, mc)
slf' sts@(s:ss) colors mc =  slf' (delete st sts) (colorize n colorslist) maxcolor
  where
    (st@(n, edg, z),_) = maxSaturation (s, (degree s, saturation s colors)) ss
    maxSaturation w [] = w
    maxSaturation w@(e, (dege, sate)) (x:xs) =
        let satx = saturation x colors
            degx = degree x
        in if degx < dege
            then w
            else if sate < satx
                then maxSaturation (x, (degx, satx)) xs
                else maxSaturation w xs
    (colorslist, maxcolor) = let clr = color edg
                             in (clr, max (last clr) mc)
    color :: [Int] -> [Int]
    color edges = take z $ [0..] \\ (nub $ concat
        $ foldr (\node acc -> colors!node : acc) [] edges)
    colorize :: Int -> [Int] -> Array Int [Int]
    colorize node cl = colors // [(node, cl)]

degree :: Station -> Int
degree (_,edges,_) = length edges

saturation :: Station -> Array Int [Int] -> Int
saturation (_,edges,_) colors = foldr (\node acc ->
    if null (colors!node)
        then acc
        else acc+1) 0 edges

main = do
    args <- getArgs
    graph <- fReadXml $ head args
    stations <- readZ $ convGxl (graph::Gxl)
    let (g, n) = slf stations
    putStrLn $ show g
    putStrLn $ show (n+1)
  where
    readZ :: [Station] -> IO [Station]
    readZ st = foldr (\(n,e,_) a -> do
            putStrLn $ "Podaj zapotrzebowanie stacji " ++ show n ++ ": "
            z <- getLine
            aa <- a
            return $ (n,e,(read z)::Int) : aa
        ) (return []) st