ForestStructures 0.0.0.2 → 0.0.1.1
raw patch · 5 files changed
Files
- Data/Forest/Static.hs +66/−58
- Data/Forest/StructuredPaired.hs +94/−0
- ForestStructures.cabal +15/−6
- README.md +1/−1
- changelog.md +5/−0
Data/Forest/Static.hs view
@@ -3,6 +3,7 @@ module Data.Forest.Static where +import Control.DeepSeq (NFData(..)) import Control.Applicative ((<$>),(<*>)) import Control.Monad (replicateM) import Data.Foldable (toList)@@ -19,6 +20,8 @@ import qualified Data.Vector.Generic as VG import qualified Data.Vector.Unboxed as VU import Test.QuickCheck+import GHC.Generics(Generic)+import Data.Aeson (ToJSON(..),FromJSON(..)) @@ -39,37 +42,42 @@ -- construction with helper functions. The labels of type @a@ (in @label@) -- require a vector structure @v@ for @O(1)@ access. -data Forest (p :: TreeOrder) v a where- Forest :: (VG.Vector v a) =>- { label :: v a- -- ^ Each node @k@ in @[0..n-1]@ has a label at @label ! k@.- , parent :: VU.Vector Int- -- ^ Each node @k@ has a parent node, or @-1@ if there is no such- -- parent.- , children :: V.Vector (VU.Vector Int)- -- ^ Each node @k@ has a vector of indices for its children. For leaf- -- nodes, the vector is empty.- , lsib :: VU.Vector Int- -- ^ The left sibling for a node @k@. Will *not* cross subtrees. I.e.- -- if @k@ is @lsib@ of @l@, then @k@ and @l@ have the same parent.- , rsib :: VU.Vector Int- -- ^ The right sibling for a node @k@.- , roots :: VU.Vector Int- -- ^ The roots of the individual trees, the forest was constructed- -- from.- } -> Forest p v a+data Forest (p ∷ TreeOrder) v a = Forest+ { label ∷ !(v a)+ -- ^ Each node @k@ in @[0..n-1]@ has a label at @label ! k@.+ , parent ∷ !(VU.Vector Int)+ -- ^ Each node @k@ has a parent node, or @-1@ if there is no such+ -- parent.+ , children ∷ !(V.Vector (VU.Vector Int))+ -- ^ Each node @k@ has a vector of indices for its children. For leaf+ -- nodes, the vector is empty.+ , lsib ∷ !(VU.Vector Int)+ -- ^ The left sibling for a node @k@. Will *not* cross subtrees. I.e.+ -- if @k@ is @lsib@ of @l@, then @k@ and @l@ have the same parent.+ , rsib ∷ !(VU.Vector Int)+ -- ^ The right sibling for a node @k@.+ , roots ∷ !(VU.Vector Int)+ -- ^ The roots of the individual trees, the forest was constructed+ -- from.+ }+ deriving (Eq,Ord,Read,Show,Generic) -deriving instance (Show a, Show (v a)) => Show (Forest p v a)+instance (NFData (v a)) ⇒ NFData (Forest p v a) +instance ToJSON (v a) ⇒ ToJSON (Forest p v a) +instance FromJSON (v a) ⇒ FromJSON (Forest p v a) +++ -- | Construct a static 'Forest' with a tree traversal function. I.e. -- @forestWith preorderF trees@ will construct a pre-order forest from the -- list of @trees@. -- -- Siblings span trees in the forest! -forestWith :: (VG.Vector v a) => (forall a . [T.Tree a] -> [a]) -> [T.Tree a] -> Forest (p::TreeOrder) v a+forestWith ∷ (VG.Vector v a) ⇒ (forall a . [T.Tree a] → [a]) → [T.Tree a] → Forest (p∷TreeOrder) v a forestWith f ts = Forest { label = VG.fromList $ f ts , parent = VU.fromList $ map (\(_,k,_ ,_) -> k ) $ f pcs@@ -98,47 +106,47 @@ -- | Construct a pre-ordered forest. -forestPre :: (VG.Vector v a) => [T.Tree a] -> Forest Pre v a+forestPre ∷ (VG.Vector v a) ⇒ [T.Tree a] → Forest Pre v a forestPre = forestWith preorderF -- | Construct a post-ordered forest. -forestPost :: (VG.Vector v a) => [T.Tree a] -> Forest Post v a+forestPost ∷ (VG.Vector v a) ⇒ [T.Tree a] → Forest Post v a forestPost = forestWith postorderF -- | Add @pre-ordered@ @(!)@ indices. First argument is the starting index. -addIndices :: Int -> T.Tree a -> T.Tree (Int,a)+addIndices ∷ Int → T.Tree a → T.Tree (Int,a) addIndices k = snd . mapAccumL (\i e -> (i+1, (i,e))) k -- | Add @pre-ordered@ @(!)@ indices, but to a forest. -addIndicesF :: Int -> [T.Tree a] -> [T.Tree (Int,a)]+addIndicesF ∷ Int → [T.Tree a] → [T.Tree (Int,a)] addIndicesF k = snd . mapAccumL go k where go = mapAccumL (\i e -> (i+1, (i,e))) -- | Add @pre-ordered@ @(!)@ indices to a forest, but throw the label away as -- well. -addIndicesF' :: Int -> [T.Tree a] -> [T.Tree Int]+addIndicesF' ∷ Int → [T.Tree a] → [T.Tree Int] addIndicesF' k = snd . mapAccumL go k where go = mapAccumL (\i e -> (i+1, i)) -- | Add parent + children information. Yields -- @(Index,Parent,[Child],Label)@. Parent is @-1@ if root node. -parentChildrenF :: Int -> [T.Tree (Int,a)] -> [T.Tree (Int,Int,[Int],a)]+parentChildrenF ∷ Int → [T.Tree (Int,a)] → [T.Tree (Int,Int,[Int],a)] parentChildrenF k ts = [ T.Node (i,k,children sf,l) (parentChildrenF i sf) | T.Node (i,l) sf <- ts ] where children sf = map (fst . T.rootLabel) sf -- | Return a map with all the nearest siblings for each node, for a forest. -lrSiblingF :: [T.Tree (Int,a)] -> S.Map Int (Int,Int)+lrSiblingF ∷ [T.Tree (Int,a)] → S.Map Int (Int,Int) lrSiblingF = S.delete (-1) . lrSibling . T.Node (-1,error "laziness in lrSiblingF broken") -- | Return a map with all the nearest siblings for each node, for a tree. -lrSibling :: T.Tree (Int,a) -> S.Map Int (Int,Int)+lrSibling ∷ T.Tree (Int,a) → S.Map Int (Int,Int) lrSibling = S.fromList . map splt . T.flatten . go ([]::[Int]) where go sib (T.Node (k,lbl) frst) = let cs = [l | T.Node (l,_) _ <- frst] in T.Node (k,lbl,sib) [ go cs t | t <- frst] splt (k,_,[]) = (k,(-1,-1))@@ -146,25 +154,25 @@ -- | Return the left-most leaf for each node. -leftMostLeaves :: Forest p v a -> VU.Vector Int+leftMostLeaves ∷ Forest p v a → VU.Vector Int leftMostLeaves f = VG.map (leftMostLeaf f) $ VG.enumFromN 0 $ VG.length $ parent f -- | Just the leaf-most leaf for a certain node. -leftMostLeaf :: Forest p v a -> Int -> Int+leftMostLeaf ∷ Forest p v a → Int → Int leftMostLeaf f = go where go k = let cs = children f VG.! k in if VG.null cs then k else go (VG.head cs) -- | Return the right-most leaf for each node. -rightMostLeaves :: Forest p v a -> VU.Vector Int+rightMostLeaves ∷ Forest p v a → VU.Vector Int rightMostLeaves f = VG.map (rightMostLeaf f) $ VG.enumFromN 0 $ VG.length $ parent f -- | Given a tree, and a node index, return the right-most leaf for the -- node. -rightMostLeaf :: Forest p v a -> Int -> Int+rightMostLeaf ∷ Forest p v a → Int → Int rightMostLeaf f = go where go k = let cs = children f VG.! k in if VG.null cs then k else go (VG.last cs)@@ -176,7 +184,7 @@ -- -- TODO group by -leftKeyRoots :: Forest Post v a -> VU.Vector Int+leftKeyRoots ∷ Forest Post v a → VU.Vector Int leftKeyRoots f = VU.fromList . sort . S.elems $ VU.foldl' go S.empty (VU.enumFromN (0::Int) $ VG.length $ parent f) -- Build a map from left-most leaf to most root-near node. where go s k = S.insertWith max (lml VU.! k) k s@@ -188,7 +196,7 @@ -- -- TODO turn this into @newtype vectors@ that enforce @size >= 1@. -sortedSubForests :: Forest p v a -> [VU.Vector Int]+sortedSubForests ∷ Forest p v a → [VU.Vector Int] sortedSubForests f = -- cleanup map VU.fromList@@ -207,7 +215,7 @@ -- make sure that the roots are there, but come last $ VG.snoc (VG.reverse (children f)) (roots f) -newtype Srt = Srt { unSrt :: [Int] }+newtype Srt = Srt { unSrt ∷ [Int] } deriving (Eq,Show) instance Ord Srt where@@ -215,7 +223,7 @@ -- | Given a forest, return the list of trees that constitue the forest. -forestToTrees :: Forest p v a -> T.Forest a+forestToTrees ∷ (VG.Vector v a) ⇒ Forest p v a → T.Forest a forestToTrees Forest{..} = map getTree . VG.toList $ roots where getTree k = T.Node (label VG.! k) (map getTree . VG.toList $ children VG.! k) @@ -225,16 +233,16 @@ -- | Wrapped quickcheck instance for 'T.Tree'. -newtype QCTree a = QCTree { getTree :: T.Tree a }+newtype QCTree a = QCTree { getTree ∷ T.Tree a } deriving (Show) -instance (Arbitrary a) => Arbitrary (QCTree a) where+instance (Arbitrary a) ⇒ Arbitrary (QCTree a) where arbitrary =- let go = sized $ \n ->- do val <- arbitrary+ let go = sized $ \n →+ do val ← arbitrary let n' = n `div` 2- nodes <- if n' > 0- then do k <- choose (0,n')+ nodes ← if n' > 0+ then do k ← choose (0,n') resize n' $ replicateM k (getTree <$> arbitrary) else return [] return $ T.Node val nodes@@ -242,18 +250,18 @@ shrink (QCTree (T.Node val forest)) = [] -- [ QCTree $ T.Node v f | v <- shrink val, f <- map (map getTree) $ shrink $ map QCTree forest ] --- * Test functions--test1 :: [T.Tree Char]-test1 = [T.Node 'R' [T.Node 'a' [], T.Node 'b' []], T.Node 'S' [T.Node 'x' [], T.Node 'y' []]]--test2 :: [T.Tree Char]-test2 = [T.Node 'R' [T.Node 'a' [], T.Node 'b' [], T.Node 'c' []]]--runtest t = do- print (forestPre t :: Forest Pre V.Vector Char)- print (forestPost t :: Forest Post V.Vector Char)- print (forestPost [T.Node 'R' [T.Node 'a' []]] :: Forest Post V.Vector Char)- print (forestPost [T.Node 'R' [T.Node 'a' [], T.Node 'b' []]] :: Forest Post V.Vector Char)- print (sortedSubForests (forestPre t :: Forest Pre V.Vector Char))-+-- -- * Test functions+-- +-- test1 :: [T.Tree Char]+-- test1 = [T.Node 'R' [T.Node 'a' [], T.Node 'b' []], T.Node 'S' [T.Node 'x' [], T.Node 'y' []]]+-- +-- test2 :: [T.Tree Char]+-- test2 = [T.Node 'R' [T.Node 'a' [], T.Node 'b' [], T.Node 'c' []]]+-- +-- runtest t = do+-- print (forestPre t :: Forest Pre V.Vector Char)+-- print (forestPost t :: Forest Post V.Vector Char)+-- print (forestPost [T.Node 'R' [T.Node 'a' []]] :: Forest Post V.Vector Char)+-- print (forestPost [T.Node 'R' [T.Node 'a' [], T.Node 'b' []]] :: Forest Post V.Vector Char)+-- print (sortedSubForests (forestPre t :: Forest Pre V.Vector Char))+--
+ Data/Forest/StructuredPaired.hs view
@@ -0,0 +1,94 @@++-- | A semi-specialized forest structure with the following atomic elements:+-- (i) unstructured regions of type @a@, (ii) binary paired regions of type+-- @(b,b)@ with a recursing tree (or insertion between the two @b@'s), (iii)+-- juxtaposition of two elements, and (iv) an empty structure.++module Data.Forest.StructuredPaired where++import Control.Lens+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Monoid+import GHC.Generics (Generic)++import Data.Forest.Static++++-- | A structured forest.++data SPForest r t+ -- | An (unstructured) region with the structured forest. In case @r@ forms a+ -- monoid @SPJ (SPR a) (SPR b) `equiv` SPR (a<>b)@ should hold.+ = SPR r+ -- | A tree within the forest brackets the forest on the left and right side+ -- with elements of type @t@.+ | SPT t (SPForest r t) t+ -- | Juxtaposition of two forests. This allows for simple concatenation of+ -- forests. In particular, there is no particular position, while lists+ -- prefer @x:xs@ vs @xs++[x]@.+ | SPJ [SPForest r t]+ -- | An empty forest. @SPJ SPE SPE `equiv` SPE@ should hold.+ | SPE+ deriving (Read,Show,Eq,Ord,Generic)+makePrisms ''SPForest++instance Functor (SPForest r) where+ fmap f = \case+ SPR r → SPR r+ SPT l t r → SPT (f l) (fmap f t) (f r)+ SPJ xs → SPJ (map (fmap f) xs)+ SPE → SPE+ {-# Inlinable fmap #-}++instance Foldable (SPForest r) where+ foldMap = bifoldMap (const mempty)+ {-# Inlinable foldMap #-}++instance Traversable (SPForest r) where+ traverse = bitraverse pure+ {-# Inlinable traverse #-}++instance Bifunctor SPForest where+ first f = \case+ SPR r → SPR (f r)+ SPT l t r → SPT l (first f t) r+ SPJ xs → SPJ (map (first f) xs)+ SPE → SPE+ {-# Inlinable first #-}+ second = fmap+ {-# Inlinable second #-}+ bimap f g = \case+ SPR r → SPR (f r)+ SPT l t r → SPT (g l) (bimap f g t) (g r)+ SPJ xs → SPJ (map (bimap f g) xs)+ SPE → SPE+ {-# Inlinable bimap #-}++instance Bifoldable SPForest where+ bifoldMap f g = \case+ SPR r → f r+ SPT l t r → g l <> bifoldMap f g t <> g r+ SPJ xs → error "Bifoldable" -- mconcatMap (bifoldMap f g) xs+ SPE → mempty+ {-# Inlinable bifoldMap #-}++instance Bitraversable SPForest where+ bitraverse f g = \case+ SPR r → SPR <$> f r+ SPT l t r → SPT <$> g l <*> bitraverse f g t <*> g r+ SPJ xs → error "Bitraversable" -- SPJ <$> bitraverse f g l <*> bitraverse f g r+ SPE → pure SPE+ {-# Inlinable bitraverse #-}++++-- | Structured Forests can be transformed into static forests.+--+-- TODO types involved!++toStaticForest ∷ SPForest r t → Forest p v a+toStaticForest = undefined+
ForestStructures.cabal view
@@ -1,17 +1,17 @@+cabal-version: 2.2 name: ForestStructures-version: 0.0.0.2-author: Christian Hoener zu Siederdissen, Sarah Berkemer, 2015-2017-copyright: Christian Hoener zu Siederdissen, 2015-2017+version: 0.0.1.1+author: Christian Hoener zu Siederdissen 2015-2023, Sarah Berkemer, 2015-2017+copyright: Christian Hoener zu Siederdissen, 2015-2023 homepage: https://github.com/choener/ForestStructures bug-reports: https://github.com/choener/ForestStructures/issues maintainer: choener@bioinf.uni-leipzig.de category: Formal Languages, Bioinformatics-license: BSD3+license: BSD-3-Clause license-file: LICENSE build-type: Simple stability: experimental-cabal-version: >= 1.10.0-tested-with: GHC == 7.10.3, GHC == 8.0.2+tested-with: GHC == 8.8 synopsis: Tree- and forest structures description: This library provides both static and dynamic tree and forest@@ -31,27 +31,36 @@ library build-depends: base >= 4.7 && < 5.0+ , aeson >= 1.0+ , bifunctors >= 5.0 , containers >= 0.5+ , deepseq >= 1.0 , fgl >= 5.5+ , lens >= 4.0 , QuickCheck >= 2.0 , unordered-containers >= 0.2 , vector >= 0.10 , vector-th-unbox >= 0.2 exposed-modules: Data.Forest.Static+ Data.Forest.StructuredPaired default-language: Haskell2010 default-extensions: BangPatterns , AllowAmbiguousTypes , DataKinds+ , DeriveGeneric , FlexibleContexts , GADTs , KindSignatures+ , LambdaCase , OverloadedStrings , RankNTypes , RecordWildCards , StandaloneDeriving+ , TemplateHaskell , UndecidableInstances+ , UnicodeSyntax ghc-options: -O2
README.md view
@@ -1,4 +1,4 @@-[](https://travis-ci.org/choener/ForestStructures)+ # ForestStructures: Dynamic and static tree and forest structures
changelog.md view
@@ -1,3 +1,8 @@+0.0.1.0+-------++- structured forests, mostly for secondary structures of RNA+ 0.0.0.2 -------