diff --git a/Data/Forest/Static.hs b/Data/Forest/Static.hs --- a/Data/Forest/Static.hs +++ b/Data/Forest/Static.hs @@ -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)) +-- diff --git a/Data/Forest/StructuredPaired.hs b/Data/Forest/StructuredPaired.hs new file mode 100644 --- /dev/null +++ b/Data/Forest/StructuredPaired.hs @@ -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 + diff --git a/ForestStructures.cabal b/ForestStructures.cabal --- a/ForestStructures.cabal +++ b/ForestStructures.cabal @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![Build Status](https://travis-ci.org/choener/ForestStructures.svg?branch=master)](https://travis-ci.org/choener/ForestStructures) +![github action: master](https://github.com/choener/ForestStructures/actions/workflows/action.yml/badge.svg) # ForestStructures: Dynamic and static tree and forest structures diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +0.0.1.0 +------- + +- structured forests, mostly for secondary structures of RNA + 0.0.0.2 -------