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

module Dodge.Data.DoubleTree where

import Control.Lens
--import Data.Aeson
--import Data.Aeson.TH
import Data.Bifunctor

--import qualified Data.Map.Strict as M

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

-- for each child, records the link type to the father node
data LabelDoubleTreeNodeType a
    = LDTRootNode
    | LDTTopNode a
    | LDTMidAboveNode a
    | LDTMidBelowNode a
    | LDTBottomNode a

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

data LDTree b a = LDT -- LabelDoubleTree
    { _ldtValue :: a
    , _ldtLeft :: [(b, LDTree b a)]
    , _ldtRight :: [(b, LDTree b a)]
    }
    deriving (Eq, Ord, Show, Read)

-- I am not sure about the double use of records here
data ContextLDT b a
    = TopLDT
    | LeftwardLDT
        { _cldtUp :: ContextLDT b a
        , _cldtCloseLeft :: [(b, LDTree b a)]
        , _cldtParent :: a
        , _cldtLink :: b
        , _cldtCloseRight :: [(b, LDTree b a)]
        , _cldtFarRight :: [(b, LDTree b a)]
        }
    | RightwardLDT
        { _cldtUp :: ContextLDT b a
        , _cldtFarLeft :: [(b, LDTree b a)]
        , _cldtCloseLeft :: [(b, LDTree b a)]
        , _cldtParent :: a
        , _cldtLink :: b
        , _cldtCloseRight :: [(b, LDTree b a)]
        }

data LocationLDT b a = LocLDT
    { _locLdtContext :: ContextLDT b a
    , _locLDT :: LDTree b a
    }

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

instance Functor (LDTree b) where
    fmap f (LDT x l r) = LDT (f x) (fmap (second $ fmap f) l) (fmap (second $ fmap f) r)

instance Bifunctor LDTree where
    second = fmap
    first f (LDT x l r) =
        LDT
            x
            (map (bimap f (first f)) l)
            (map (bimap f (first 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 ''LDTree
makeLenses ''LocationLDT
makeLenses ''ContextLDT
makeLenses ''LocationDT
makeLenses ''ContextDT

instance Functor (LocationLDT b) where
    fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t)

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

instance Functor (ContextLDT b) where
    fmap f = \case
        TopLDT -> TopLDT
        LeftwardLDT u cl p l cr fr -> LeftwardLDT 
            (fmap f u)
            (fmap (fmap (fmap f)) cl)
            (f p)
            l
            (fmap (fmap (fmap f)) cr)
            (fmap (fmap (fmap f)) fr)
        RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u)
            (fmap (fmap (fmap f)) fl)
            (fmap (fmap (fmap f)) cl)
            (f p)
            l
            (fmap (fmap (fmap f)) cr)

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