diff --git a/src/Graph.hs b/src/Graph.hs index b9460b1..88f9a67 100644 --- a/src/Graph.hs +++ b/src/Graph.hs @@ -1,35 +1,52 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveFunctor #-} module Graph ( - Graph(..) + Graph(..) + , editLabel + , open + , rewind + , singleton + , weave ) where import Data.Map (Map, (!?)) -import qualified Data.Map as Map (delete, empty, insert) +import qualified Data.Map as Map (delete, empty, insert, toList) +import Tree (Tree(..), Structure(..)) -data Vertex label edge = Vertex { +data Vertex edge label = Vertex { label :: label - , edges :: Map edge (Vertex label edge) - } deriving Show + , edges :: Map edge (Vertex edge label) + } deriving (Functor, Show) -singleton :: label -> Vertex label edge +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 label edge = Top | Zipper { - origin :: Zipper label edge +data Zipper edge label = Top | Zipper { + origin :: Zipper edge label , from :: label , by :: edge - , siblingEdges :: Map edge (Vertex label edge) - } deriving Show + , siblingEdges :: Map edge (Vertex edge label) + } deriving (Functor, Show) -data Graph label edge = Graph { - focus :: Vertex label edge - , context :: Zipper label edge - } deriving Show +data Graph edge label = Graph { + focus :: Vertex edge label + , context :: Zipper edge label + } deriving (Functor, Show) -open :: Vertex label edge -> Graph label edge +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 label edge -> Vertex label edge +zipUp :: Ord edge => Graph edge label -> Vertex edge label zipUp graph = case context graph of Top -> focus graph @@ -41,10 +58,10 @@ zipUp graph = } } -rewind :: Ord edge => Graph label edge -> Graph label edge +rewind :: Ord edge => Graph edge label -> Graph edge label rewind = open . zipUp -follow :: Ord edge => Graph label edge -> edge -> Maybe (Graph label edge) +follow :: Ord edge => Graph edge label -> edge -> Maybe (Graph edge label) follow (Graph {focus, context}) edge = edges focus !? edge >>= \vertex -> Just $ Graph { focus = vertex @@ -56,7 +73,7 @@ follow (Graph {focus, context}) edge = } } -weave :: (Monoid label, Ord edge) => Graph label edge -> [edge] -> Graph label edge +weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label weave = foldl $ \graph edge -> case graph `follow` edge of Nothing -> Graph { @@ -70,5 +87,6 @@ weave = foldl $ \graph edge -> } Just newGraph -> newGraph -setLabel :: Graph label edge -> label -> Graph label edge -setLabel graph newLabel = graph {focus = (focus graph) {label = newLabel}} +editLabel :: Graph edge label -> (label -> label) -> Graph edge label +editLabel graph@(Graph {focus}) labelEditor = + graph {focus = focus {label = labelEditor $ label focus}}