Tissevert/Mainate
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Use new Tree module to print graphs (doesn't handle loops yet), switch type arguments and generalize the label setter into a label editor that takes a function

Browse source
This commit is contained in:
Tissevert 2019-05-06 08:21:04 +02:00
parent 5d1907094d
commit a8f87be2c1
1 changed files with 39 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
src/Graph.hs
View file

@ -1,35 +1,52 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveFunctor #-}
module Graph ( module Graph (
Graph(..) Graph(..)
, editLabel
, open
, rewind
, singleton
, weave
) where ) where
import Data.Map (Map, (!?)) 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 label :: label
, edges :: Map edge (Vertex label edge) , edges :: Map edge (Vertex edge label)
} deriving Show } 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} singleton label = Vertex {label, edges = Map.empty}
data Zipper label edge = Top | Zipper { data Zipper edge label = Top | Zipper {
origin :: Zipper label edge origin :: Zipper edge label
, from :: label , from :: label
, by :: edge , by :: edge
, siblingEdges :: Map edge (Vertex label edge) , siblingEdges :: Map edge (Vertex edge label)
} deriving Show } deriving (Functor, Show)
data Graph label edge = Graph { data Graph edge label = Graph {
focus :: Vertex label edge focus :: Vertex edge label
, context :: Zipper label edge , context :: Zipper edge label
} deriving Show } 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} 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 = zipUp graph =
case context graph of case context graph of
Top -> focus graph 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 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 = follow (Graph {focus, context}) edge =
edges focus !? edge >>= \vertex -> Just $ Graph { edges focus !? edge >>= \vertex -> Just $ Graph {
focus = vertex 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 -> weave = foldl $ \graph edge ->
case graph `follow` edge of case graph `follow` edge of
Nothing -> Graph { Nothing -> Graph {
@ -70,5 +87,6 @@ weave = foldl $ \graph edge ->
} }
Just newGraph -> newGraph Just newGraph -> newGraph
setLabel :: Graph label edge -> label -> Graph label edge editLabel :: Graph edge label -> (label -> label) -> Graph edge label
setLabel graph newLabel = graph {focus = (focus graph) {label = newLabel}} editLabel graph@(Graph {focus}) labelEditor =
graph {focus = focus {label = labelEditor $ label focus}}