[99p]Graph(Complete w/o #85)

import Data.List
import Data.Function

-- predefine types
type Arcgraph a = [(a,a)]
type Wgraph a b = [((a,a),b)]
agraph0 = [(1,2),(2,3)]
agraph1 = [(1,2),(2,3),(1,3),(3,4),(4,2),(5,6)]
agraph2 = [(1,2),(1,3),(1,4),(2,3),(2,4),(3,4)]
agraph21 = [(1,2),(1,3),(1,4),(2,1),(2,3),(2,4),(3,1),(3,2),(3,4),(4,1),(4,2),(4,3)]
agraph3 = [('a','b'),('a','d'),('b','c'),('b','e'),('c','e'),('d','e'),('d','f'),('d','g'),('e','h'),('f','g'),('g','h')]
agraph4 = [(1,2),(1,3),(1,4),(1,5),(2,3),(2,4),(2,5),(3,4),(3,5),(4,5)]
agraph5 = [('a','c'),('a','d'),('a','e'),('a','f'),('a','k'),('b','c'),('c','d'),('c','g'),('d','e'),('d','h'),('e','i'),
           ('f','j'),('g','h'),('g','l'),('h','i'),('i','j'),('l','k')]
agraph6 = [(1,2),(2,3),(3,4),(4,1)]
agraph7 = [(1,2),(2,3),(1,4),(3,4),(5,2),(5,4)]
wgraph3 = [(('a','b'),5),(('a','d'),3),(('b','c'),2),(('b','e'),4),(('c','e'),6),
           (('d','e'),7),(('d','f'),4),(('d','g'),3),(('e','h'),5),(('f','g'),4),(('g','h'),1)]
wgraph = [((1,2),12),((1,3),34),((1,5),78),((2,4),55),((2,5),32),((3,4),61),((3,5),44),((4,5),93)]

-- problem 81
eles [] = []
eles (g:gs) = nub ([fst g, snd g] ++ eles gs)
paths :: Eq a => a -> a -> Arcgraph a -> [[a]]
paths a b g
        | a==b   =[[a]]
        | a/=b   =(if (a,b) `elem` g then [[a,b]] else []) ++
                   nub ([ (init ax)++xb |
                          x <- (delete a (delete b (eles g))), ax <- paths a x ag, xb <- paths x b bg, ax /= [] , xb /= [],
                          (init ax) `intersect` xb == [] ])
                                      where ag = [ga | ga <- g, fst ga /= b, snd ga /= b]
                                            bg = [gb | gb <- g, fst gb /= a, snd gb /= a]

-- problem 82
cycles :: Eq a => a -> Arcgraph a -> [[a]]
cycles a g = concat [map (++[a]) (paths a x g) | x <- eles g, (x,a) `elem`g]

-- problem 83 (solution for non-Arc graphs)
biArc :: Eq a => Arcgraph a -> Arcgraph a
biArc [] = []
biArc (g:gs) = nub ([g] ++ [(snd g, fst g)] ++ biArc gs)
rid :: Eq a => Arcgraph a -> a -> Arcgraph a
rid [] a = []
rid g a = [x | x <- g, fst x /= a , snd x /= a]
spantree' :: Eq a => Arcgraph a -> [[(a,a)]]
spantree' [(a,b)] = [[(a,b)]]
spantree' g = filter (\x -> length x == length (eles g) -1)
              $ concat [map ([realedge (a,i)]++) (spantree' (rid g a)) | (a,i) <- biArc g]
                        where realedge (a,i) = if (a,i) `elem` g then (a,i) else (i,a)
spantree :: Ord a => Arcgraph a -> [[(a,a)]]
spantree g = nub $ map sort (spantree' g)
istree :: Ord a => Arcgraph a -> Bool
istree g = length (spantree g) == 1
isconnected :: Ord a => Arcgraph a -> Bool
isconnected g = length (spantree g) /= 0

-- problem 84
adjWedge' :: (Eq a, Eq b) => [a] -> Wgraph a b -> Wgraph a b
adjWedge' [] g = []
adjWedge' (x:xs) g = nub ([e |e <- g, (fst (fst e) == x)||(snd (fst e) == x)] ++ (adjWedge' xs g))
adjWedge :: (Eq a, Ord b) => [a] -> Wgraph a b -> ((a,a),b)
adjWedge xs g = head $sortBy (compare `on` snd)
                (filter (\e -> (fst (fst e) `notElem` xs) || (snd (fst e) `notElem` xs) == True ) (adjWedge' xs g))

elesW :: Eq a => Wgraph a Integer -> [a]
elesW [] = []
elesW (e:gs) = nub ([fst (fst e), snd (fst e)] ++ elesW gs)
mstPrim' :: Ord a => [a] -> Wgraph a Integer -> Wgraph a Integer -> Wgraph a Integer
mstPrim' xs es g
        | sort xs == sort (elesW g)  = es
        | sort xs /= sort (elesW g)  = (mstPrim' (nub(xs ++ [fst (fst enew)] ++ [snd (fst enew)])) (es++[enew]) g)
                                        where enew = adjWedge xs g
mstPrim :: Ord a => Wgraph a Integer -> Wgraph a Integer
mstPrim [] = []
mstPrim g = mstPrim' [head (sort (elesW g))] [] g
mstPrimV :: Ord a => Wgraph a Integer -> Integer
mstPrimV [] = 0
mstPrimV g = foldr (+) 0 $ map (\e -> snd e) (mstPrim g)

-- problem 85

-- problem 86 (solution for non-Arc graphs)
dgrcount :: Eq a => Arcgraph a -> a -> Int
dgrcount [] _ = 0
dgrcount (g:gs) x = (if (x == fst g) || (x == snd g) then 1 else 0) + dgrcount gs x
dgrsort :: Eq a => Arcgraph a -> [a]
dgrsort [] = []
dgrsort g = reverse $ sortBy (compare `on` (dgrcount g)) (eles g)
connectTo :: Eq a => a -> Arcgraph a -> [a]
connectTo a [] = [a]
connectTo a (g:gs)
            |  fst g == a   = [snd g] ++ connectTo a gs
            |  snd g == a   = [fst g] ++ connectTo a gs
            |  otherwise    = connectTo a gs
colorone :: Ord a => b -> Arcgraph a -> [a] -> [(a,b)]
colorone _ [] _ = []
colorone c g s
         |  sort s == sort(eles g)  = []
         |  otherwise               = [(m, c)] ++ colorone c g (nub (s ++ (connectTo m g)))
                                          where m = head (filter (`notElem` s) (dgrsort g))
gcolorWP' :: (Ord a, Num b) => b -> Arcgraph a -> [a] -> [(a,b)]
gcolorWP' _ [] _ = []
gcolorWP' c g cs
          |  sort cs == sort(eles g)  = []
          |  otherwise                = clist ++ gcolorWP' (c+1) g (cs++ (map fst clist))
                                          where clist = colorone c g cs
gcolorWP :: (Ord a, Num b) => Arcgraph a -> [(a,b)]
gcolorWP g = gcolorWP' 0 g []

-- problem 87
------ very slow solution
dfsGraph' :: Ord a => Arcgraph a -> [a] -> a -> [a]
dfsGraph' [] _ v = [v]
dfsGraph' g s v
          |  sort s == sort(eles g) = []
          |  otherwise              = nub([v] ++ concatMap (\x -> dfsGraph' (rid g v) (nub(s++[v])) x) (filter (`notElem` s) (connectTo v g)))
dfsGraph :: Ord a => Arcgraph a -> a -> [a]
dfsGraph g v = dfsGraph' g [] v

-- problem 88
ridlist :: Eq a => Arcgraph a -> [a] -> Arcgraph a
ridlist [] _ = []
ridlist g as = [x | x <- g, (fst x) `notElem` as , (snd x) `notElem` as]
splitGraph :: Ord a => Arcgraph a -> [[a]]
splitGraph [] = []
splitGraph g = [clist] ++ splitGraph (ridlist g clist)
               where clist = dfsGraph g (head $dgrsort g)

-- problem 89 (bi-Arc)
evencycle :: Eq a => a -> Arcgraph a -> Bool
evencycle v [] = True
evencycle v g = foldr (&&) True (map (odd. length) (cycles v g))
bipartite :: Eq a => Arcgraph a -> Bool
bipartite [] = True
bipartite g = foldr (&&) True [evencycle v g | v <- eles g]