diff --git a/Data/Forest/Static.hs b/Data/Forest/Static.hs --- a/Data/Forest/Static.hs +++ b/Data/Forest/Static.hs @@ -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)) diff --git a/ForestStructures.cabal b/ForestStructures.cabal --- a/ForestStructures.cabal +++ b/ForestStructures.cabal @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +0.0.0.2 +------- + +- removed upper bounds + 0.0.0.1 ------- diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -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)