{-# 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}}