module Graphene.Algorithms (
kruskal,
dfs,
bfs,
dijkstra,
DijkstraState,
underlyingGraph,
distancePairings,
prevs,
unvisited,
visited,
from
) where
import Data.List
import qualified Data.Map as M
import Graphene.Graph
import Lens.Family2
import Lens.Family2.State
import Control.Monad.Writer
import Control.Monad.Trans.State
import Data.Ord
import Data.Bifunctor
import Data.Maybe
_3 :: Lens' (a, b, c) c
_3 k (a, b, c) = fmap (\c' -> (a, b, c')) (k c)
_2 :: Lens' (a, b, c) b
_2 k (a, b, c) = fmap (\b' -> (a, b', c)) (k b)
_1 :: Lens' (a, b, c) a
_1 k (a, b, c) = fmap (\a' -> (a', b, c)) (k a)
kruskal :: (Ord v, Ord e) => Graph v e -> Graph v e
kruskal g = view _3 $ execState go (vertexSets, sortedEdges, emptyGraph)
where vertexSets = map (:[]) $ g^.vertices
sortedEdges = sortBy (comparing fst) $ g^.edges
go :: (Eq v, Ord v, Ord e) => State ([[v]], [(e, (v, v))], Graph e v) ()
go = do
(vs, es, _) <- get
unless (null es) $ do
let e@(w, (v1, v2)) = head es
ss = filter (\s -> any (`elem` s) [v1, v2]) vs
case ss of
[s1, s2] -> do
_3.vertices %= union ([v1, v2])
_3.edges %= insert e
_1 %= delete s1 . delete s2 . insert (s1 `union` s2)
_ -> return ()
_2 %= tail
go
dfs :: Eq v => v -> Graph e v -> [v]
dfs v g = case ns of
[] -> [v]
_ -> v : concatMap (\w -> dfs w (g' w)) ns
where ns = neighbors v g
g' w = removeVertices (v : delete w ns) g
bfs :: Eq v => v -> Graph e v -> [v]
bfs v g = go [v] g
where go [] _ = []
go (x:xs) g = x : go (xs ++ ns) (removeVertex x g)
where ns = neighbors x g
sg :: Graph Int Char
sg = fromLists ['a'..'e'] (zip3 [1..5] ['a'..'d'] ['b'..'e'])
infinity :: Int
infinity = maxBound
data DijkstraState e v = DijkstraState{
_underlyingGraph :: Graph e v
, _distancePairings :: M.Map v Int
, _prevs :: M.Map v (Maybe v)
, _unvisited :: [v]
, _visited :: [v]
, _from :: v
} deriving (Show, Eq)
underlyingGraph :: Lens' (DijkstraState e v) (Graph e v)
underlyingGraph k (DijkstraState u d p un v f) = fmap (\u' -> DijkstraState u' d p un v f) (k u)
distancePairings :: Lens' (DijkstraState e v) (M.Map v Int)
distancePairings k (DijkstraState u d p un v f) = fmap (\d' -> DijkstraState u d' p un v f) (k d)
prevs :: Lens' (DijkstraState e v) (M.Map v (Maybe v))
prevs k (DijkstraState u d p un v f) = fmap (\p' -> DijkstraState u d p' un v f) (k p)
unvisited :: Lens' (DijkstraState e v) [v]
unvisited k (DijkstraState u d p un v f) = fmap (\un' -> DijkstraState u d p un' v f) (k un)
visited :: Lens' (DijkstraState e v) [v]
visited k (DijkstraState u d p un v f) = fmap (\v' -> DijkstraState u d p un v' f) (k v)
from :: Lens' (DijkstraState e v) v
from k (DijkstraState u d p un v f) = fmap (\f' -> DijkstraState u d p un v f') (k f)
mkDijkstra :: (Eq v, Ord v) => Graph e v -> v -> DijkstraState e v
mkDijkstra g@(Graph vs es) v = DijkstraState g dists prevs vs [] v
where dists = M.fromList ( (v, 0) : (map (, infinity) $ delete v vs) )
prevs = M.fromList $ zip vs (repeat Nothing)
dijkstra :: (Eq v, Ord v) => Graph Int v -> v -> DijkstraState Int v
dijkstra g = execState go . mkDijkstra g
where go :: (Eq v, Ord v) => State (DijkstraState Int v) ()
go = do
q <- use unvisited
unless (null q) $ do
dists <- use distancePairings
g <- use underlyingGraph
let u = minimumBy (comparing (flip M.lookup dists)) q
(Just uWeight) = M.lookup u dists
conns = connections u g
unvisited %= (delete u)
unless ( uWeight == infinity ) $ do
forM_ conns $ \(eWeight, v) -> do
let (Just vWeight) = M.lookup v dists
newWeight = eWeight + uWeight
unless (newWeight > vWeight) $ do
distancePairings %= (M.insert v newWeight)
prevs %= (M.insert v (Just u) )
visited %= (u:)
go