{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}

module RedBlack where

import Control.Monad.State

data Color = Red | Black deriving (Show, Eq)
data Child = L | R deriving (Show, Eq)
data Visit k v = Visit (Color, k, Maybe v) deriving (Show, Eq)

class RedBlackMonad k v m where
  visit :: m (Visit k v)
  update :: Maybe (Visit k v) -> m ()
  empty :: m Bool
  down :: Child -> m ()
  up :: m ()
  -- push :: m ()
  -- pop :: m ()
  -- swap :: m ()

-- 1. RedBlackMonad instance using a Zipper and a Tree

data Tree a = Leaf | Branch (Tree a) a (Tree a) deriving Show
data RedBlackZipper a = Root (Tree a) | Hole (RedBlackZipper a) Child (Tree a) deriving Show

focus :: RedBlackZipper a -> Tree a
focus (Root t) = t
focus (Hole _ _ t) = t

setFocus :: RedBlackZipper a -> Tree a -> RedBlackZipper a
setFocus (Root _) t = (Root t)
setFocus (Hole c d _) t = (Hole c d t)
  
instance (Ord k) => RedBlackMonad k v (State (RedBlackZipper (Visit k v))) where
  visit = get >>= return . f . focus
    where
      f (Branch _ v _) = v
      
  update mv = get >>= \x -> put $ setFocus x $ f mv $ focus x
    where
      f Nothing _ = Leaf
      f (Just v) (Branch l _ r) = (Branch l v r)
      f (Just v) Leaf = (Branch Leaf v Leaf)

  empty = get >>= return . f . focus
    where
      f Leaf = True
      f _ = False
      
  down c = get >>= \x -> put $ f c x $ focus x
    where
      f :: Child -> RedBlackZipper (Visit k v) -> Tree (Visit k v) -> RedBlackZipper (Visit k v)
      f L z (Branch l _ _) = (Hole z L l)
      f R z (Branch _ _ r) = (Hole z R r)
      
  up = return ()
      
--  up = get >>= 

-- instance (Monad) HashGraphMonad domain range m where

-- data Cxt a = Top | Left (Cxt a) (RB k d) | Right (Tree k d) (Cxt a)
      
--  Main.modify Nothing


