75 lines
2.1 KiB
Haskell
75 lines
2.1 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Graph (
|
|
Graph(..)
|
|
) where
|
|
|
|
import Data.Map (Map, (!?))
|
|
import qualified Data.Map as Map (delete, empty, insert)
|
|
|
|
data Vertex label edge = Vertex {
|
|
label :: label
|
|
, edges :: Map edge (Vertex label edge)
|
|
} deriving Show
|
|
|
|
singleton :: label -> Vertex label edge
|
|
singleton label = Vertex {label, edges = Map.empty}
|
|
|
|
data Zipper label edge = Top | Zipper {
|
|
origin :: Zipper label edge
|
|
, from :: label
|
|
, by :: edge
|
|
, siblingEdges :: Map edge (Vertex label edge)
|
|
} deriving Show
|
|
|
|
data Graph label edge = Graph {
|
|
focus :: Vertex label edge
|
|
, context :: Zipper label edge
|
|
} deriving Show
|
|
|
|
open :: Vertex label edge -> Graph label edge
|
|
open focus = Graph {focus, context = Top}
|
|
|
|
zipUp :: Ord edge => Graph label edge -> Vertex label edge
|
|
zipUp graph =
|
|
case context graph of
|
|
Top -> focus graph
|
|
Zipper {origin, from, by, siblingEdges} -> zipUp $ Graph {
|
|
context = origin
|
|
, focus = Vertex {
|
|
label = from
|
|
, edges = Map.insert by (focus graph) siblingEdges
|
|
}
|
|
}
|
|
|
|
rewind :: Ord edge => Graph label edge -> Graph label edge
|
|
rewind = open . zipUp
|
|
|
|
follow :: Ord edge => Graph label edge -> edge -> Maybe (Graph label edge)
|
|
follow (Graph {focus, context}) edge =
|
|
edges focus !? edge >>= \vertex -> Just $ Graph {
|
|
focus = vertex
|
|
, context = Zipper {
|
|
origin = context
|
|
, from = label $ focus
|
|
, by = edge
|
|
, siblingEdges = Map.delete edge $ edges focus
|
|
}
|
|
}
|
|
|
|
weave :: (Monoid label, Ord edge) => Graph label edge -> [edge] -> Graph label edge
|
|
weave = foldl $ \graph edge ->
|
|
case graph `follow` edge of
|
|
Nothing -> Graph {
|
|
focus = singleton mempty
|
|
, context = Zipper {
|
|
origin = context graph
|
|
, from = label $ focus graph
|
|
, by = edge
|
|
, siblingEdges = edges $ focus graph
|
|
}
|
|
}
|
|
Just newGraph -> newGraph
|
|
|
|
setLabel :: Graph label edge -> label -> Graph label edge
|
|
setLabel graph newLabel = graph {focus = (focus graph) {label = newLabel}}
|