87 lines
2.5 KiB
Haskell
87 lines
2.5 KiB
Haskell
{-# 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
|
|
| 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
|