{-# LANGUAGE LambdaCase #-}
--{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

module Dodge.Data.DoubleTree where

import Control.Lens

data DoubleTreeNodeType
    = DTRootNode
    | DTTopNode
    | DTMidAboveNode
    | DTMidBelowNode
    | DTBottomNode

data DTree a = DT {_dtValue :: a, _dtLeft :: [DTree a], _dtRight :: [DTree a]}
    deriving (Eq, Ord, Show, Read)

instance Functor DTree where
    fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r)

instance Foldable DTree where
    foldMap f (DT x l r) = foldMap (foldMap f) l <> f x <> foldMap (foldMap f) r

data ContextDT a
    = TopDT
    | LeftwardDT
        { _cdtUp :: ContextDT a
        , _cdtCloseLeft :: [DTree a]
        , _cdtParent :: a
        , _cdtCloseRight :: [DTree a]
        , _cdtFarRight :: [DTree a]
        }
    | RightwardDT
        { _cdtUp :: ContextDT a
        , _cdtFarLeft :: [ DTree a]
        , _cdtCloseLeft :: [DTree a]
        , _cdtParent :: a
        , _cdtCloseRight :: [DTree a]
        }

data LocationDT a = LocDT
    { _locDtContext :: ContextDT a
    , _locDT :: DTree a
    }

makeLenses ''DTree
makeLenses ''LocationDT
makeLenses ''ContextDT

instance Functor LocationDT where
    fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t)

instance Functor ContextDT where
    fmap f = \case
        TopDT -> TopDT
        LeftwardDT u cl p cr fr -> LeftwardDT 
            (fmap f u)
            (fmap (fmap f) cl)
            (f p)
            (fmap (fmap f) cr)
            (fmap (fmap f) fr)
        RightwardDT u fl cl p cr -> RightwardDT (fmap f u)
            (fmap (fmap f) fl)
            (fmap (fmap f) cl)
            (f p)
            (fmap (fmap f) cr)

--deriveJSON defaultOptions ''DoubleTree
--deriveJSON defaultOptions ''LabelDoubleTree