151 lines
3.9 KiB
Haskell
151 lines
3.9 KiB
Haskell
{-# 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
|