{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell,TypeSynonymInstances #-} {-| This module provides the GTA framework on binary (and leaf-valued) trees, such as definitions of the data structures and their algebras, generators, aggregators, etc. -} 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, LVTreeSemiring, BinTreeSemiring) where import GTA.Core import GTA.Util.GenericSemiringStructureTemplate import Data.List -- leaf-valued binary tree data LVTree a = NodeLV (LVTree a) (LVTree a) | LeafLV a deriving (Eq, Ord, Read) -- The following definitions can be generated automatically by @genAllDecl ''LVTree@ -- They are written by hand here for writing comments. -- algebra of LVTree data LVTreeAlgebra b a = LVTreeAlgebra { nodeLV :: a -> a -> a, leafLV :: b -> a } -- a set of functions for 'map' data LVTreeMapFs b b' = LVTreeMapFs { leafLVF :: b -> b' } -- type parameters are algebra, free algebra, and functions for 'map' instance GenericSemiringStructure (LVTreeAlgebra b) (LVTree b) (LVTreeMapFs b) where freeAlgebra = LVTreeAlgebra {..} where nodeLV = NodeLV leafLV = LeafLV pairAlgebra lvta1 lvta2 = LVTreeAlgebra {..} where nodeLV (l1, l2) (r1, r2) = (nodeLV1 l1 r1, nodeLV2 l2 r2) leafLV a = (leafLV1 a, leafLV2 a) (nodeLV1, leafLV1) = let LVTreeAlgebra {..} = lvta1 in (nodeLV, leafLV) (nodeLV2, leafLV2) = let LVTreeAlgebra {..} = lvta2 in (nodeLV, leafLV) makeAlgebra (CommutativeMonoid {..}) lvta frec fsingle = LVTreeAlgebra {..} where nodeLV l r = foldr oplus identity [fsingle (nodeLV' l' r') | l' <- frec l, r' <- frec r] leafLV a = fsingle (leafLV' a) (nodeLV', leafLV') = let LVTreeAlgebra {..} = lvta in (nodeLV, leafLV) foldingAlgebra op iop (LVTreeMapFs {..}) = LVTreeAlgebra {..} where nodeLV l r = l `op` r leafLV a = leafLVF a hom (LVTreeAlgebra {..}) = h where h (NodeLV l r) = nodeLV (h l) (h r) h (LeafLV a) = leafLV a -- renaming type LVTreeSemiring a s = GenericSemiring (LVTreeAlgebra a) s {- -- generalized version of the matrix chain DP algorithm O(n^3) generates a bag of trees from a list. The left-to-right traversal of each tree is equivalent to the input list. -} 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..(n-1)] -- binary tree with different types for nodes and leaves data BinTree n l = BinNode n (BinTree n l) (BinTree n l) | BinLeaf l deriving (Eq, Ord, Read) -- The following definitions can be generated automatically by @genAllDecl ''BinTree@ -- They are written by hand here for writing comments. -- algebra of BinTree data BinTreeAlgebra n l a = BinTreeAlgebra { binNode :: n -> a -> a -> a, binLeaf :: l -> a } -- a set of functions for 'map' data BinTreeMapFs n l b' = BinTreeMapFs { binNodeF :: n -> b', binLeafF :: l -> b' } -- type parameters are algebra, free algebra, and functions for 'map' instance GenericSemiringStructure (BinTreeAlgebra n l) (BinTree n l) (BinTreeMapFs n l) where freeAlgebra = BinTreeAlgebra {..} where binNode = BinNode binLeaf = BinLeaf pairAlgebra lvta1 lvta2 = BinTreeAlgebra {..} where binNode a (l1, l2) (r1, r2) = (binNode1 a l1 r1, binNode2 a l2 r2) binLeaf a = (binLeaf1 a, binLeaf2 a) (binNode1, binLeaf1) = let BinTreeAlgebra {..} = lvta1 in (binNode, binLeaf) (binNode2, binLeaf2) = let BinTreeAlgebra {..} = lvta2 in (binNode, binLeaf) makeAlgebra (CommutativeMonoid {..}) lvta frec fsingle = BinTreeAlgebra {..} where binNode a l r = foldr oplus identity [fsingle (binNode' a l' r') | l' <- frec l, r' <- frec r] binLeaf a = fsingle (binLeaf' a) (binNode', binLeaf') = let BinTreeAlgebra {..} = lvta in (binNode, binLeaf) foldingAlgebra op iop (BinTreeMapFs {..}) = BinTreeAlgebra {..} where binNode a l r = binNodeF a `op` l `op` r binLeaf a = binLeafF a hom (BinTreeAlgebra {..}) = h where h (BinNode a l r) = binNode a (h l) (h r) h (BinLeaf a) = binLeaf a -- renaming type BinTreeSemiring n l a = GenericSemiring (BinTreeAlgebra n l) a -- BinTree-semiring for counting count :: Num a => BinTreeSemiring n l a count = sumproductBy (BinTreeMapFs {binLeafF = const 1, binNodeF = const 1}) -- shotcuts to maxsum of marked trees 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 -- predicate for rooted suBinTrees (i.e., those including the original root) 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 -- predicate for all suBinTrees data StClass = RtdST -- suBinTree including the root | IsoST -- isolated suBinTree | Empty -- empty | Other -- other NGs 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 {- This is BinTreeSemiring-polymorphic LVTreeSemiring. We can use this kind of A-semirnig-polymorphic B-semiring to change the intermediate data structure from B to A -} 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 {- generating a bag of trees from a list. The left-to-right traversal of each tree is equivalent to the input list, ignoring the assigned marks. -} assignTrees :: [b] -> [c] -> [a] -> BinTreeSemiring c (b, a) s -> s assignTrees msl msn x = lvtrees x >=< assignTrans msl msn -- polymorphic generator for all selections 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