{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
--{-# 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 DoubleTree a = DT {_dtValue :: a, _dtLeft :: [DoubleTree a], _dtRight :: [DoubleTree a]}
    deriving (Eq, Ord, Show, Read)

--data FLatLabelDoubleTreeNode b a = FLDT
--    {_fldtValue :: a
--    ,_fldtType ::
--    ,_fldtIndentation :: Int
--    ,_fldtID :: Int
--    ,_fldtChildren =

data LabelDoubleTree b a = LDT
    { _ldtValue :: a
    , _ldtLeft :: [(b, LabelDoubleTree b a)]
    , _ldtRight :: [(b, LabelDoubleTree 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, LabelDoubleTree b a)]
        , _cldtParent :: a
        , _cldtLink :: b
        , _cldtCloseRight :: [(b, LabelDoubleTree b a)]
        , _cldtFarRight :: [(b, LabelDoubleTree b a)]
        }
    | RightwardLDT
        { _cldtUp :: ContextLDT b a
        , _cldtFarLeft :: [(b, LabelDoubleTree b a)]
        , _cldtCloseLeft :: [(b, LabelDoubleTree b a)]
        , _cldtParent :: a
        , _cldtLink :: b
        , _cldtCloseRight :: [(b, LabelDoubleTree b a)]
        }

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

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

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

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

instance Bifunctor LabelDoubleTree where
    second = fmap
    first f (LDT x l r) =
        LDT
            x
            (map (bimap f (first f)) l)
            (map (bimap f (first f)) r)

makeLenses ''DoubleTree
makeLenses ''LabelDoubleTree
makeLenses ''LocationLDT
makeLenses ''ContextLDT
--deriveJSON defaultOptions ''DoubleTree
--deriveJSON defaultOptions ''LabelDoubleTree