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