96 lines
2.7 KiB
Haskell
96 lines
2.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
module Graph (
|
|
Graph(..)
|
|
, Vertex(..)
|
|
, Zipper(..)
|
|
, editLabel
|
|
, follow
|
|
, open
|
|
, rewind
|
|
, singleton
|
|
, weave
|
|
) where
|
|
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map (delete, empty, insert, lookup, toList)
|
|
import Tree (Tree(..), Structure(..))
|
|
|
|
data Vertex edge label = Vertex {
|
|
label :: label
|
|
, edges :: Map edge (Vertex edge label)
|
|
} deriving (Functor, Show)
|
|
|
|
instance Show edge => Tree (Vertex edge) where
|
|
getStructure (Vertex {label, edges}) = Node [
|
|
("(" ++ label ++ ")", Node $ recurseOnEdge <$> Map.toList edges)
|
|
]
|
|
where
|
|
recurseOnEdge (edge, vertex) = (show edge, getStructure vertex)
|
|
|
|
singleton :: label -> Vertex edge label
|
|
singleton label = Vertex {label, edges = Map.empty}
|
|
|
|
data Zipper edge label = Top | Zipper {
|
|
origin :: Zipper edge label
|
|
, from :: label
|
|
, by :: edge
|
|
, siblingEdges :: Map edge (Vertex edge label)
|
|
} deriving (Functor, Show)
|
|
|
|
data Graph edge label = Graph {
|
|
focus :: Vertex edge label
|
|
, context :: Zipper edge label
|
|
} deriving (Functor, Show)
|
|
|
|
instance (Ord edge, Show edge) => Tree (Graph edge) where
|
|
getStructure = getStructure . zipUp
|
|
|
|
open :: Vertex edge label -> Graph edge label
|
|
open focus = Graph {focus, context = Top}
|
|
|
|
zipUp :: Ord edge => Graph edge label -> Vertex edge label
|
|
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 edge label -> Graph edge label
|
|
rewind = open . zipUp
|
|
|
|
follow :: Ord edge => Graph edge label -> edge -> Maybe (Graph edge label)
|
|
follow (Graph {focus, context}) edge =
|
|
Map.lookup edge (edges focus) >>= \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 edge label -> [edge] -> Graph edge label
|
|
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
|
|
|
|
editLabel :: Graph edge label -> (label -> label) -> Graph edge label
|
|
editLabel graph@(Graph {focus}) labelEditor =
|
|
graph {focus = focus {label = labelEditor $ label focus}}
|