graph.hs

--
--                         Homework #2 - Graph
--                         ===================
-- 
--               Info: http://vyuka.haskell.cz/graph/
--             Author: Tomáš Pažourek
--

import Data.Function (on)
import qualified Data.Set as Set
import Data.Set (Set, fromList, toList, insert, member, delete, size, fold)
import Data.List (sort, find)

newtype Vertex = Vertex Int deriving (Show, Read, Eq, Ord)

data Link = Link { edge :: (Vertex, Vertex)
                 , weight :: Double
                 } deriving (Show, Read)

instance Eq Link where
    (==) = (==) `on` edge

instance Ord Link where
    compare = compare `on` edge

type Graph = (Set Vertex, Set Link)

graph :: Graph
graph = (fromList [], fromList [])

addVertex :: Vertex -> Graph -> Graph
addVertex v (vs, ls) = (insert v vs, ls)

addLink :: (Vertex, Vertex) -> Double -> Graph -> Graph
addLink e@(v1, v2) w (vs, ls) = addVertex v1 $ addVertex v2 $ (vs, insert (Link e w) ls)

deleteVertex :: Vertex -> Graph -> Graph
deleteVertex v (vs, ls)
 | v `member` vs = (delete v vs, Set.filter (\l -> fst (edge l) /= v && snd (edge l) /= v) ls)
 | otherwise     = error "There is no such vertex in the graph."

deleteLink :: (Vertex, Vertex) -> Graph -> Graph
deleteLink e (vs, ls)
 | e `member` (Set.map edge ls) = (vs, Set.filter ((e /=).edge) ls)
 | otherwise                    = error "There is no such edge in the graph."

findVertex :: Vertex -> Graph -> Set Link
findVertex v (_, ls) = Set.filter (\l -> fst (edge l) == v || snd (edge l) == v) ls

linkCount :: Graph -> Int
linkCount (_, ls) = size ls

totalWeight :: Graph -> Double
totalWeight (_, ls) = fold (+) 0 (Set.map weight ls)

averageWeight :: Graph -> Double
averageWeight g@(_, ls)
 | Set.null ls = error "The graph doesn't contain any edges."
 | otherwise   = totalWeight(g) / fromIntegral(linkCount(g))

medianWeight :: Graph -> Double
medianWeight (_, ls)
 | Set.null ls = error "The graph doesn't contain any edges."
 | even (length ws) = (/2) $ ws !! (mid ws - 1) + ws !! (mid ws + 1)
 | odd (length ws)  = ws !! (mid ws)
 where ws = sort $ map weight $ toList ls
       mid s = length s `div` 2

-- Vertex with a distance from sth.
data Vertex' = Vertex' { vertex :: Vertex
                       , distance :: Double
                       } deriving (Show, Read, Ord, Eq)

type DistanceGraph = (Set Vertex', Set Link)

-- Bellman-Ford algorithm
shortestPath :: Vertex -> Vertex -> Graph -> Double
shortestPath a b g@(vs, _) = distance
                           $ findVertex' b
                           $ (\dgs -> if dgs !! (size vs) /= dgs !! (size vs - 1)
                                      then error "The graph contains negative cycle."
                                      else dgs !! (size vs - 1))
                           $ iterate relaxAllEdges
                           $ toDistanceGraph g
 where
  toDistanceGraph :: Graph -> DistanceGraph
  toDistanceGraph g = (Set.map ( \v -> Vertex'{ vertex = v
                                              , distance = if v == a then 0 else 1/0
                                              } ) (fst g), snd g)

  -- finds Vertex' matching to Vertex in DistanceGraph
  findVertex' :: Vertex -> DistanceGraph -> Vertex'
  findVertex' v (vs', _) = case find (\v' -> v == vertex v') . toList $ vs' of
                           Just v' -> v'
                           Nothing -> error "The graph doesn't contain the vertex."

  relaxEdge :: Link -> DistanceGraph -> DistanceGraph
  relaxEdge l dg@(vs', ls)
   | l `member` ls = (Set.map (\v' -> if v' == y && (distance y > distance x + weight l)
	                                  then Vertex' { vertex = vertex v'
	                                               , distance = distance x + weight l }
	                                  else v') vs', ls)
   | otherwise     = error "The graph doesn't contain the relaxed edge."
   where { x = findVertex' (fst.edge $ l) dg; y = findVertex' (snd.edge $ l) dg }

  relaxAllEdges :: DistanceGraph -> DistanceGraph
  relaxAllEdges dg@(_, ls) = foldr relaxEdge dg $ toList ls