ForestStructures 0.0.0.1 → 0.0.0.2
raw patch · 4 files changed
+168/−29 lines, 4 filesdep +tastydep +tasty-quickcheckdep +tasty-thdep −test-frameworkdep −test-framework-quickcheck2dep −test-framework-thdep ~QuickCheckdep ~basedep ~containers
Dependencies added: tasty, tasty-quickcheck, tasty-th
Dependencies removed: test-framework, test-framework-quickcheck2, test-framework-th
Dependency ranges changed: QuickCheck, base, containers, criterion, fgl, unordered-containers, vector, vector-th-unbox
Files
- Data/Forest/Static.hs +114/−13
- ForestStructures.cabal +23/−15
- changelog.md +5/−0
- tests/properties.hs +26/−1
Data/Forest/Static.hs view
@@ -3,16 +3,22 @@ module Data.Forest.Static where +import Control.Applicative ((<$>),(<*>))+import Control.Monad (replicateM) import Data.Foldable (toList) import Data.Graph.Inductive.Basic import Data.List (span,uncons,sort) import Data.Traversable (mapAccumL)+import Data.Tree (Tree) import Debug.Trace+import qualified Data.List as L import qualified Data.Map.Strict as S+import qualified Data.Set as Set import qualified Data.Tree as T import qualified Data.Vector as V import qualified Data.Vector.Generic as VG import qualified Data.Vector.Unboxed as VU+import Test.QuickCheck @@ -22,7 +28,7 @@ -- -- TODO @Unordered@ for trees that have no sorted order? -data TreeOrder = Pre | Post+data TreeOrder = Pre | Post | Unordered @@ -30,16 +36,27 @@ -- possible by following the indices, the nodes themselves shall always be -- ordered by the type @p :: TreeOrder@. This is not completely enforced, -- given that @Forest@ is exporting the constructor, but encouraged via--- construction with helper functions.+-- 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 deriving instance (Show a, Show (v a)) => Show (Forest p v a)@@ -49,6 +66,8 @@ -- | 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 f ts@@ -87,18 +106,18 @@ 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.+-- | Add @pre-ordered@ @(!)@ indices. First argument is the starting index. 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.+-- | Add @pre-ordered@ @(!)@ indices, but to a forest. 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+-- | Add @pre-ordered@ @(!)@ indices to a forest, but throw the label away as -- well. addIndicesF' :: Int -> [T.Tree a] -> [T.Tree Int]@@ -128,10 +147,28 @@ -- | Return the left-most leaf for each node. leftMostLeaves :: Forest p v a -> VU.Vector Int-leftMostLeaves f = VG.map go $ VG.enumFromN 0 $ VG.length $ parent f+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 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 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 f = go+ where go k = let cs = children f VG.! k+ in if VG.null cs then k else go (VG.last cs)+ -- | Return all left key roots. These are the nodes that have no (super-) -- parent with the same left-most leaf. --@@ -145,14 +182,78 @@ where go s k = S.insertWith max (lml VU.! k) k s lml = leftMostLeaves f -{--test :: [T.Tree Char]-test = [T.Node 'R' [T.Node 'a' [], T.Node 'b' []], T.Node 'S' [T.Node 'x' [], T.Node 'y' []]]+-- | Returns the list of all sorted subsets of subforests in the forest.+-- If the forest is given in pre-order, then The subsets are returned in+-- reversed pre-order.+--+-- TODO turn this into @newtype vectors@ that enforce @size >= 1@. -runtest = do- print (forestPre test :: Forest Pre V.Vector Char)- print (forestPost test :: Forest Post V.Vector Char)+sortedSubForests :: Forest p v a -> [VU.Vector Int]+sortedSubForests f =+ -- cleanup+ map VU.fromList+ . L.nub -- TODO revise later, is in @O(n^2)@+ . concat+ -- make sure that in our partial order we have smaller forests come+ -- first.+ . map (map unSrt . Set.toList . Set.fromList . map Srt)+ -- get all nonempty ordered subforests+ . map (concatMap (L.tail . L.subsequences))+ . map (L.permutations)+ . map VG.toList . VG.toList+ -- only nodes with children+ . VG.filter (not . VG.null)+ -- every node that has children in reverse order+ -- make sure that the roots are there, but come last+ $ VG.snoc (VG.reverse (children f)) (roots f)++newtype Srt = Srt { unSrt :: [Int] }+ deriving (Eq,Show)++instance Ord Srt where+ Srt xs <= Srt ys = length xs <= length ys++-- | Given a forest, return the list of trees that constitue the forest.++forestToTrees :: 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)++++-- * QuickCheck++-- | Wrapped quickcheck instance for 'T.Tree'.++newtype QCTree a = QCTree { getTree :: T.Tree a }+ deriving (Show)++instance (Arbitrary a) => Arbitrary (QCTree a) where+ arbitrary =+ let go = sized $ \n ->+ do val <- arbitrary+ let n' = n `div` 2+ nodes <- if n' > 0+ then do k <- choose (0,n')+ resize n' $ replicateM k (getTree <$> arbitrary)+ else return []+ return $ T.Node val nodes+ in QCTree <$> go+ 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))
ForestStructures.cabal view
@@ -1,7 +1,7 @@ name: ForestStructures-version: 0.0.0.1-author: Christian Hoener zu Siederdissen, Sarah Berkemer, 2015-2016-copyright: Christian Hoener zu Siederdissen, 2015-2016+version: 0.0.0.2+author: Christian Hoener zu Siederdissen, Sarah Berkemer, 2015-2017+copyright: Christian Hoener zu Siederdissen, 2015-2017 homepage: https://github.com/choener/ForestStructures bug-reports: https://github.com/choener/ForestStructures/issues maintainer: choener@bioinf.uni-leipzig.de@@ -11,7 +11,7 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0-tested-with: GHC == 7.8.4, GHC == 7.10.3+tested-with: GHC == 7.10.3, GHC == 8.0.2 synopsis: Tree- and forest structures description: This library provides both static and dynamic tree and forest@@ -30,12 +30,13 @@ library- build-depends: base >= 4.7 && < 4.9- , containers >= 0.5 && < 0.6- , fgl >= 5.5 && < 5.6- , unordered-containers >= 0.2 && < 0.3- , vector >= 0.10 && < 0.12- , vector-th-unbox >= 0.2 && < 0.3+ build-depends: base >= 4.7 && < 5.0+ , containers >= 0.5+ , fgl >= 5.5+ , QuickCheck >= 2.0+ , unordered-containers >= 0.2+ , vector >= 0.10+ , vector-th-unbox >= 0.2 exposed-modules: Data.Forest.Static default-language:@@ -48,6 +49,7 @@ , KindSignatures , OverloadedStrings , RankNTypes+ , RecordWildCards , StandaloneDeriving , UndecidableInstances ghc-options:@@ -67,18 +69,24 @@ default-language: Haskell2010 default-extensions: BangPatterns+ , DataKinds+ , TemplateHaskell build-depends: base- , ForestStructures+ , containers , QuickCheck- , test-framework >= 0.8 && < 0.9- , test-framework-quickcheck2 >= 0.3 && < 0.4- , test-framework-th >= 0.2 && < 0.3+ , tasty >= 0.11+ , tasty-quickcheck >= 0.8+ , tasty-th >= 0.1+ , vector+ --+ , ForestStructures benchmark benchmark build-depends: base- , criterion >= 1.0.2 && < 1.1.1+ , criterion >= 1.0.2+ -- , ForestStructures default-language: Haskell2010
changelog.md view
@@ -1,3 +1,8 @@+0.0.0.2+-------++- removed upper bounds+ 0.0.0.1 -------
tests/properties.hs view
@@ -1,7 +1,32 @@+ module Main where +import Debug.Trace+import qualified Data.Tree as T+import qualified Data.Vector.Unboxed as VU+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.TH +import Data.Forest.Static +-- Finite tree ?++--prop_finite :: [QCTree ()] -> Bool+--prop_finite qs = True -- traceShow qs True++---- Given trees, create a pre-order forest and then generate the trees from+---- the pre-order forest again.+--+--prop_bla :: [QCTree ()] -> Bool+--prop_bla qs = ts == xs+-- where xs = forestToTrees f+-- ts = map getTree qs+-- f = forestPre ts :: Forest Pre VU.Vector ()++-- Same, but with post-order.+ main :: IO ()-main = return ()+main = $(defaultMainGenerator)