module GTA.Data.BinTree (LVTree (NodeLV, LeafLV), LVTreeAlgebra(LVTreeAlgebra), nodeLV, leafLV, LVTreeMapFs (LVTreeMapFs), leafLVF, BinTree(BinNode,BinLeaf), BinTreeAlgebra(BinTreeAlgebra),binNode,binLeaf, BinTreeMapFs (BinTreeMapFs), binLeafF, binNodeF, lvtrees, subtreeSelectsWithRoot, subtreeSelects, selects, assignTrans, assignTrees, count, maxsum, maxsumsolution) where
import GTA.Core
import GTA.Util.GenericSemiringStructureTemplate
import Data.List
data LVTree a = NodeLV (LVTree a) (LVTree a)
| LeafLV a
deriving (Eq, Ord, Read)
genAllDecl ''LVTree
type LVTreeSemiring a s = GenericSemiring (LVTreeAlgebra a) s
lvtrees :: [a] -> LVTreeSemiring a s -> s
lvtrees x bts = head (head (lvtrees' x bts))
lvtrees' :: [a] -> LVTreeSemiring a s -> [[s]]
lvtrees' x (GenericSemiring{..}) =
let CommutativeMonoid {..} = monoid
LVTreeAlgebra {..} = algebra
ls = map f x
bigOplus = foldr oplus identity
f a = leafLV a
f' l r = [nodeLV l r]
n = length x
merge ts k =
let vs = transpose (map (\(i, y) -> drop i y) (zip [1..k] ts))
hs = map reverse (transpose ts)
ns = zipWith mrg hs vs
in ns:ts
mrg h v = bigOplus (concat (zipWith f' h v))
in foldl merge [ls] [1..(n1)]
data BinTree n l = BinNode n (BinTree n l) (BinTree n l)
| BinLeaf l
deriving (Eq, Ord, Read)
genAllDecl ''BinTree
type BinTreeSemiring n l a = GenericSemiring (BinTreeAlgebra n l) a
count :: Num a => BinTreeSemiring n l a
count = sumproductBy (BinTreeMapFs {binLeafF = const 1, binNodeF = const 1})
markedT :: forall a. Num a =>
BinTreeMapFs (Bool, a) (Bool, a) (AddIdentity a)
markedT = BinTreeMapFs {binNodeF=f, binLeafF=f}
where f (m,a) = AddIdentity (if m then a else 0)
maxsum :: (Num a, Ord a) => BinTreeSemiring (Bool, a) (Bool, a) (AddIdentity a)
maxsum = maxsumBy markedT
maxsumsolution :: (Num a, Ord a) => BinTreeSemiring (Bool, a) (Bool, a) (AddIdentity a, Bag (BinTree (Bool, a) (Bool, a)))
maxsumsolution = maxsumsolutionBy markedT
data RtStClass = Rtd | Emp | NG deriving (Show, Eq, Ord, Read)
rtst :: forall t t1. BinTreeAlgebra (Bool, t1) (Bool, t) RtStClass
rtst = BinTreeAlgebra {..}
where
binNode (True, _) l r = case (l, r) of
(Rtd, Rtd) -> Rtd
(Rtd, Emp) -> Rtd
(Rtd, NG) -> NG
(Emp, Rtd) -> Rtd
(Emp, Emp) -> Rtd
(Emp, NG) -> NG
(NG , Rtd) -> NG
(NG , Emp) -> NG
(NG , NG) -> NG
binNode (False, _) l r = case (l, r) of
(Rtd, Rtd) -> NG
(Rtd, Emp) -> NG
(Rtd, NG) -> NG
(Emp, Rtd) -> NG
(Emp, Emp) -> Emp
(Emp, NG) -> NG
(NG , Rtd) -> NG
(NG , Emp) -> NG
(NG , NG) -> NG
binLeaf (m, _) = if m then Rtd else Emp
data StClass = RtdST
| IsoST
| Empty
| Other
deriving (Show, Eq, Ord, Read)
st :: forall t t1. BinTreeAlgebra (Bool, t1) (Bool, t) StClass
st = BinTreeAlgebra {..} where
binNode (True, _) l r = case (l, r) of
(RtdST, RtdST) -> RtdST
(RtdST, IsoST) -> Other
(RtdST, Empty) -> RtdST
(RtdST, Other) -> Other
(IsoST, RtdST) -> Other
(IsoST, IsoST) -> Other
(IsoST, Empty) -> Other
(IsoST, Other) -> Other
(Empty, RtdST) -> RtdST
(Empty, IsoST) -> Other
(Empty, Empty) -> RtdST
(Empty, Other) -> Other
(Other, RtdST) -> Other
(Other, IsoST) -> Other
(Other, Empty) -> Other
(Other, Other) -> Other
binNode (False, _) l r = case (l, r) of
(RtdST, RtdST) -> Other
(RtdST, IsoST) -> Other
(RtdST, Empty) -> IsoST
(RtdST, Other) -> Other
(IsoST, RtdST) -> Other
(IsoST, IsoST) -> Other
(IsoST, Empty) -> Other
(IsoST, Other) -> Other
(Empty, RtdST) -> IsoST
(Empty, IsoST) -> IsoST
(Empty, Empty) -> Empty
(Empty, Other) -> Other
(Other, RtdST) -> Other
(Other, IsoST) -> Other
(Other, Empty) -> Other
(Other, Other) -> Other
binLeaf (m, _) = if m then RtdST else Empty
assignTrans :: [b] -> [c] -> BinTreeSemiring c (b, a) s -> LVTreeSemiring a s
assignTrans msl msn bts = GenericSemiring {monoid=monoid'',algebra=algebra''}
where
(monoid'', algebra') = let GenericSemiring {..} = bts
in (monoid, algebra)
BinTreeAlgebra {..} = algebra'
CommutativeMonoid {..} = monoid''
bigOplus = foldr oplus identity
algebra'' = LVTreeAlgebra {..} where
nodeLV l r = bigOplus [binNode m l r | m <- msn]
leafLV a = bigOplus [binLeaf (m, a) | m <- msl]
---generators
assignTrees :: [b] -> [c] -> [a] -> BinTreeSemiring c (b, a) s -> s
assignTrees msl msn x = lvtrees x >=< assignTrans msl msn
selects :: BinTree n l -> BinTreeSemiring (Bool,n) (Bool,l) a -> a
selects t bts = selects' t
where
BinTreeAlgebra {..} = algebra bts
CommutativeMonoid {..} = monoid bts
selects' (BinNode a l r) =
let l' = selects' l; r' = selects' r
in binNode (True, a) l' r' `oplus` binNode (False, a) l' r'
selects' (BinLeaf a) = (binLeaf (True, a)) `oplus` (binLeaf (False, a))
subtreeSelectsWithRoot :: BinTree n l -> BinTreeSemiring (Bool,n) (Bool,l) a -> a
subtreeSelectsWithRoot t = selects t >== (/=NG)<.>rtst
subtreeSelects :: BinTree n l -> BinTreeSemiring (Bool,n) (Bool,l) a -> a
subtreeSelects t = selects t >== (/=Other)<.>st