{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# 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 
        { _cldtValue :: a}
    | LeftwardLDT
        { _cldtUp :: ContextLDT b a  
        , _cldtCloseLeft :: [LabelDoubleTree b a] 
        , _cldtLink :: b
        , _cldtValue :: a
        , _cldtCloseRight :: [LabelDoubleTree b a]
        , _cldtFarRight :: [LabelDoubleTree b a]
        }
    | RightwardLDT 
        { _cldtUp :: ContextLDT b a  
        , _cldtFarLeft :: [LabelDoubleTree b a]
        , _cldtCloseLeft :: [LabelDoubleTree b a] 
        , _cldtLink :: b
        , _cldtValue :: a
        , _cldtCloseRight :: [LabelDoubleTree b a]
        }

-- this is not quite right, it duplicates the value when the context is at the
-- top
data LocationLDT b a = LocLDT
    { _locLdtContext :: ContextLDT b a
    , _locLdtLeft :: [LabelDoubleTree b a]
    , _locLdtRight :: [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
deriveJSON defaultOptions ''DoubleTree
deriveJSON defaultOptions ''LabelDoubleTree