PathTree (empty) → 0.1.0.0

raw patch · 6 files changed

+506/−0 lines, 6 filesdep +PathTreedep +QuickCheckdep +basesetup-changed

Dependencies added: PathTree, QuickCheck, base, containers, test-framework, test-framework-quickcheck2

Files

LICENSE +30/−0
PathTree.cabal +49/−0
Setup.hs +2/−0
src/Data/LCRSTree.hs +72/−0
src/Data/PathTree.hs +123/−0
test/Spec.hs +230/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Pedro Rodriguez Tavarez (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Pedro Rodriguez Tavarez nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ PathTree.cabal view

@@ -0,0 +1,49 @@+name: PathTree+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2016 Pedro Rodriguez Tavarez+maintainer: pedro@pjrt.co+homepage: https://github.com/pjrt/PathTree#readme+synopsis: A tree used to merge and maintain paths+description:+    This package contains two modules: "Data.LCRSTree" and "Data.PathTree".+    A 'PathTree' is a tree used to build unified paths from some node. This+    means being able to merge multiple paths, that may overlap at the root, in+    a sensible way. The module comes with a set of functions to add paths.+    A Left-Children-Right-Siblings tree ('LCRSTree') is a tree that represents+    a multi-way tree (aka, a Rose Tree) in a binary-tree format. It is the+    underlying implementation of 'PathTree'.+    <https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree>+category: Data+author: Pedro Rodriguez Tavarez++source-repository head+    type: git+    location: https://github.com/pjrt/PathTree++library+    exposed-modules:+        Data.LCRSTree+        Data.PathTree+    build-depends:+        base >=4.7 && <5,+        containers >=0.5.6.2 && <0.6+    default-language: Haskell2010+    hs-source-dirs: src+    ghc-options: -Wall++test-suite PathTree-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    build-depends:+        base >=4.8.2.0 && <4.9,+        PathTree >=0.1.0.0 && <0.2,+        QuickCheck >=2.8.2 && <2.9,+        test-framework >=0.8.1.1 && <0.9,+        test-framework-quickcheck2 >=0.3.0.3 && <0.4+    default-language: Haskell2010+    hs-source-dirs: test+    ghc-options: -threaded -rtsopts -with-rtsopts=-N

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Data/LCRSTree.hs view

@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.LCRSTree+-- Copyright   :  (c) Pedro Rodriguez Tavarez <pedro@pjrt.co>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Pedro Rodriguez Tavarez <pedro@pjrt.co>+-- Stability   :  unstable+-- Portability :  unportable+--+-------------------------------------------------------------------------------+module Data.LCRSTree where++import Data.Tree (Tree)+import qualified Data.Tree as T++-- | A Left-child-right-sibling tree. <https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree>+data LCRSTree n = Empty+    | Leaf n (LCRSTree n)+    | Node n (LCRSTree n) (LCRSTree n)+  deriving (Show, Eq)++-- | Functor instance+instance Functor LCRSTree where+  fmap _ Empty = Empty+  fmap f (Leaf a s) = Leaf (f a) (fmap f s)+  fmap f (Node n c s) = Node (f n) (fmap f c) (fmap f s)++instance Foldable LCRSTree where+  foldr _ z Empty = z+  foldr f z (Leaf n s) = foldr f (f n z) s+  foldr f z (Node n c s) =+    let v = foldr f (f n z) c+    in foldr f v s++-- | Return the depth of the tree. This means the depth of the longest+-- branch+lcrsDepth :: Integral i => LCRSTree n -> i+lcrsDepth = depth 0+  where+    depth i Empty = i+    depth i (Leaf _ s) = depth i s+    depth i (Node _ c s) =+      let lDepth = depth (i + 1) c+          rDepth = depth i s+      in max lDepth rDepth++-- | Convert a 'Tree' into a 'LCRSTree'+fromRoseTree :: Tree n -> LCRSTree n+fromRoseTree t = mkWithS t []+  where+    mkWithS (T.Node n []) ss = Leaf n $ siblings ss+    mkWithS (T.Node n ch) ss =+      let mkN = case ch of+                 [] -> Leaf n+                 (c:cs) -> Node n (mkWithS c cs)+      in  mkN $ siblings ss++    siblings [] = Empty+    siblings (c:cs) = mkWithS c cs++-- | Convert a 'LCRSTree' into a 'Tree'+--+-- This function fails if a non-top 'Node' is passed. A non-top node is a node+-- @Node n c s@ where @s /= Empty@.+toRoseTree :: LCRSTree n -> Tree n+toRoseTree (Node topN topC Empty) = T.Node topN (collectS topC)+  where+    collectS  Empty   = []+    collectS (Leaf a s) = T.Node a [] : collectS s+    collectS (Node n c s) = T.Node n (collectS c) : collectS s+toRoseTree _ = error "fromLCRSTree: non-top node passed"

+ src/Data/PathTree.hs view

@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.PathTree+-- Copyright   :  (c) Pedro Rodriguez Tavarez <pedro@pjrt.co>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Pedro Rodriguez Tavarez <pedro@pjrt.co>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module implements multiple functions using a 'LCRSTree' to create a+-- tree where the mode of insertion are paths.+-------------------------------------------------------------------------------+module Data.PathTree+( PathTree+, LCRSTree(..)+, insert+, insertWith+, insertReplace+, fromPath+, fromPaths+, fromPathsWith+, fromPathsReplace+, toPaths+, pathExists+) where++import Data.List (foldl')+import Data.LCRSTree++-- | A path tree is simply a 'LCRSTree'+type PathTree n = LCRSTree n++-- | Insert a value /a/ into the path /[n]/ into a tree.+insert :: (Eq n) => [n] -> PathTree n -> PathTree n+insert t Empty = fromPath t+insert [] t  = t+insert [a] t =+  case t of+    Empty -> Leaf a Empty+    Leaf a' s -> Leaf a (Leaf a' s)+    Node n c s -> Node n c (insert [a] s)+insert (h:t) l@(Leaf _ _) = Node h (insert t Empty) l+insert (h:t) (Node n c s)+  | h == n = Node n (insert t c) s+  | otherwise = Node n c (insert (h:t) s)++-- | Like 'insert', but will use /f/ to decide what to do if an existing+-- value already exists at the path.+insertWith :: (Eq n) => (n -> n -> n) -> [n] -> PathTree n -> PathTree n+insertWith _ t Empty = fromPath t+insertWith _ [] t = t+insertWith f [a] t =+  case t of+    Empty -> Leaf a Empty+    Leaf a' s -> if a == a'+                 then Leaf (f a' a) s+                 else Leaf a (insertWith f [a] s)+    Node n c s -> if n == a+                  then Node (f n a) c s+                  else Node n c (insertWith f [a] s)+insertWith f (h:t) l@(Leaf _ _) = Node h (insertWith f t Empty) l+insertWith f (h:t) (Node n c s)+  | h == n = Node n (insertWith f t c) s+  | otherwise = Node n c (insertWith f (h:t) s)++-- | Like 'insert', but replaces the value at the path. May seem odd to+-- replace a value that is equal to itself, but this can be used with+-- partially-equal types for some flexibility.+insertReplace :: (Eq n) => [n] -> PathTree n -> PathTree n+insertReplace = insertWith const+++-- | Given a single path, create a tree from it.+fromPath :: [n] -> PathTree n+fromPath [] = Empty+fromPath [a] = Leaf a Empty+fromPath (h:t) = Node h (fromPath t) Empty++-- | Like 'fromPath', but for multiple paths.+fromPaths :: Eq n => [[n]] -> PathTree n+fromPaths [] = Empty+fromPaths (h:t) = foldl' (flip insert) (fromPath h) t++-- | Like 'fromPaths' but applies /f/ if a give path already exists.+fromPathsWith :: Eq n => (n -> n -> n) -> [[n]] -> PathTree n+fromPathsWith _ [] = Empty+fromPathsWith f (h:t) = foldl' (flip (insertWith f)) (fromPath h) t++-- | Like 'fromPaths' but if two equal paths are passed, the former one+-- will be replaced.+fromPathsReplace :: Eq n => [[n]] -> PathTree n+fromPathsReplace = fromPathsWith const++-- | Returns all paths from the root node(s).+-- Note that @toPaths . fromPaths@ may NOT return the same tree back due to+-- some reordering of siblings.+toPaths :: PathTree n -> [[n]]+toPaths = trackPath []+  where+    trackPath _ Empty = []+    trackPath ns (Leaf a sib) = (ns ++ [a]) : trackPath ns sib+    trackPath ns (Node n' c' s') =+      let newPath = ns ++ [n']+      in  trackPath newPath c' ++ trackPath ns s'++-- | Given a path, determine if it exists fully. For a path to "exists fully"+-- means that it ends on a level that contains a leaf.+pathExists :: Eq n => [n] -> LCRSTree n -> Bool+pathExists _ Empty = False+pathExists paths (Leaf n s) =+  case paths of+    [] -> False+    [p] -> if n == p then True+                     else pathExists [p] s+    (p:ps) -> if p == n then pathExists ps s+                        else pathExists (p:ps) s+pathExists paths (Node n c s) =+  case paths of+    [] -> False+    [p] -> pathExists [p] s+    (p:ps) -> if p == n then pathExists ps c+                        else pathExists (p:ps) s

+ test/Spec.hs view

@@ -0,0 +1,230 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Test.QuickCheck+import Data.List (foldl')+import Control.Arrow (first)+import Control.Monad (liftM2, liftM3)+import Data.LCRSTree+import Data.PathTree++import Test.Framework+import Test.Framework.Providers.QuickCheck2+++main :: IO ()+main = defaultMain runTests++runTests :: [Test]+runTests =+  [ prop_fromPath+  , prop_insert+  , prop_pathExistance+  , prop_roseIdentity+  -- , testProperty "Tree Identity" $ noShrinking prop_identity+  ]++prop_fromPath :: Test+prop_fromPath =+    testGroup "fromPath"+      [ testProperty "identity" idendity_test+      , testProperty "depth" depth_test+      ]+  where+    idendity_test :: Property+    idendity_test =+      forAll pathOf2OrMore $ \path ->+        (head . toPaths . fromPath) path === path+    depth_test =+      forAll pathOf2OrMore $ \path ->+        let depth = length path - 1+        in lcrsDepth (fromPath path) === depth++    pathOf2OrMore = nonEmptyPath `suchThat` ((2 <) . length)++prop_insert :: Test+prop_insert =+  testGroup "Insert"+    [ testProperty "all values inserted should exist in the tree" insertExists+    , testProperty "inserting multiple paths with the same head should return a top node" topNodeInsert+    , testProperty "two paths inserted in any order should both exist" insertOrderExist+    , testProperty "inserting two path that diverge on a node should create a tree with one node diverging" insertDiverge+    ]+  where+    insertExists =+      forAll nonEmptyPathAndTree $ \(path, tree) ->+        let newT = insert path tree+        in  pathExistsE path newT+      where+        nonEmptyPathAndTree = liftM2 (,) nonEmptyPath arbitrary++    insertOrderExist =+      forAll twoNonEmptyPathsAndTree $ \(p1, p2, tree) ->+        let newTree1 = insert p1 $ insert p2 tree+            newTree2 = insert p2 $ insert p1 tree+        in conjoin [ pathExistsE p1 newTree1, pathExistsE p2 newTree1+                   , pathExistsE p1 newTree2, pathExistsE p2 newTree2 ]+        where+          twoNonEmptyPathsAndTree :: Gen ([AlphaChar], [AlphaChar], LCRSTree AlphaChar)+          twoNonEmptyPathsAndTree =+            liftM3 (,,) (listOf1 arbitrary) (listOf1 arbitrary) arbitrary++    topNodeInsert =+      forAll nonEmptyPathAndArb $ \(paths, top) ->+        let newPaths = map (top:) paths+            tree =  foldl' (flip insert) Empty newPaths+        in siblings tree == Empty+        where+          siblings (Node _ _ s) = s+          siblings (Leaf _ s) = s+          sibling Empty = error "No siblings for Empty"+          nonEmptyPathAndArb = liftM2 (,) (listOf1 nonEmptyPath) arbitrary++    insertDiverge =+      forAll (zipM3 nonEmptyPath nonEmptyPath nonEmptyPath) $ \(root, p1, p2) ->+        let paths = [root ++ p1, root ++ p2]+            lenOfInter = lenMin p1 p2+            tree = foldl' (flip insert) Empty paths+            actual = nodeCount tree+            expectedNumOfLeaf = 2+            expectedNumOfNode = lenOfInter - expectedNumOfLeaf + length root+        in counterexample+            (show tree ++ " contains " ++ show actual ++ " node-leaf count but expected "+                       ++ show (expectedNumOfNode, expectedNumOfLeaf))+            (actual == (expectedNumOfNode, expectedNumOfLeaf))+        where+          lenMin [l] a = 1 + length a+          lenMin a [l] = 1 + length a+          lenMin l1@(h1:t1) l2@(h2:t2)+            | h1 == h2 = 1 + lenMin t1 t2+            | otherwise = length $ l1 ++ l2+          intersectFromStart a [] = a+          intersectFromStart [] a = a+          intersectFromStart l1@(h1:t1) l2@(h2:t2)+            | h1 == h2 = h1 : intersectFromStart t1 t2+            | otherwise = l1 ++ l2+++prop_pathExistance :: Test+prop_pathExistance =+  testGroup "Path integrity"+    [ testProperty "paths should exist in a tree they make" prop_existance+    , testProperty "countPathExistances should return n for n non-uniquily inserted paths" prop_cpeNonUnique+    , testProperty "countPathExistances should return 1 for n uniquily inserted paths" prop_cpeUnique+    ]++  where+    nonZero :: Gen Int+    nonZero = arbitrary `suchThat` (>0)++    prop_existance =+      forAll (listOf1 nonEmptyPath) $ \paths ->+        let tr = fromPaths paths+        in conjoin $ map (`pathExistsE` tr) paths++    prop_cpeNonUnique =+      forAll (zipM nonEmptyPath nonZero) $ \(path, n) ->+        let tr = foldl' (flip insert) Empty $ map (const path) [1..n]+        in  countPathExistances path tr === n++    prop_cpeUnique =+      forAll (zipM nonEmptyPath nonZero) $ \(path, n) ->+        let tr = foldl' (flip insertReplace) Empty $ map (const path) [1..n]+        in  countPathExistances path tr === 1+++prop_roseIdentity :: Test+prop_roseIdentity =+    testProperty "fromRoseTree . toRoseTree should be identity" roseIdent+  where+    roseIdent :: LCRSTree AlphaChar -> Property+    roseIdent tree = (fromRoseTree . toRoseTree) tree === tree+++-- I would like to test this, but at the moment, I can't guarantee the+-- order in which the tree is built from the path will be the same+-- other the tree had before. Semantically speaking, however, the tree+-- doesn't change.+--+-- I could make the equality if the tree be order independent on+-- sibling nodes, but that sounds like work :\+-- We could use the path as the "identity" of a tree (a tree is indentified+-- by its paths). This makes sense, I think.+prop_identity :: LCRSTree AlphaChar -> Property+prop_identity tree = (fromPaths . toPaths) tree === tree++instance (Eq n, Arbitrary n) => Arbitrary (LCRSTree n) where+  shrink Empty = []+  shrink (Leaf a s) =+    [Empty] ++ [s] ++ [Leaf a' s' | (a', s') <- shrink (a, s)]+  shrink (Node n c s) =+    [Empty] ++ [c, s] ++ [Node n' c' s' | (n', c', s') <- shrink (n, c, s)]++  arbitrary = do+      let empty = return Empty+          leaf = do n <- arbitrary+                    s <- freq [empty, node, leaf]+                    return $ Leaf n s+          node = do n <- arbitrary+                    c <- freq [leaf, node]+                    s <- freq [empty, leaf, node]+                    return $ Node n c s+      n <- arbitrary+      c <- node+      return $ Node n c Empty+    where+      freq = frequency . freq' 60+        where+          freq' _ [] = []+          freq' n (h:t)+            | n <= 1 = (1, h) : freq' 1 t+            | otherwise = (n, h) : freq' (div n 2) t+++-- | A smaller set of characters (a-zA-Z)+newtype AlphaChar = AlphaChar Char+  deriving (Eq, Ord)++instance Show AlphaChar where+  show (AlphaChar c) = "'" ++ [c] ++ "'"+++instance Arbitrary AlphaChar where+  arbitrary =+    let es = elements $ ['A'..'Z'] ++ ['a'..'z']+    in AlphaChar <$> es+++zipM = liftM2 (,)+zipM3 = liftM3 (,,)++pathExistsE x y =+  counterexample (show x ++ " does not exist in " ++ show y) (pathExists x y)++nonEmptyPath :: Gen [AlphaChar]+nonEmptyPath = arbitrary `suchThat` (not . null)++countPathExistances :: (Integral i, Eq n) => [n] -> PathTree n -> i+countPathExistances [] _ = 1 -- The empty path exists once, in any tree+countPathExistances _ Empty = 0+countPathExistances [h] (Leaf n s)+  | h == n = 1 + countPathExistances [h] s+  | otherwise = countPathExistances [h] s+countPathExistances (h:t) tree =+  case tree of+    Empty -> 0+    Leaf _ s -> countPathExistances (h:t) s+    Node n c s -> if n == h+                  then countPathExistances t c+                  else countPathExistances (h:t) s++nodeCount :: Integral i => PathTree n -> (i, i)+nodeCount = nodeC (0,0)+  where+    nodeC :: Integral i => (i, i) -> PathTree n -> (i, i)+    nodeC t Empty = t+    nodeC (cn, cl) (Leaf _ s) = nodeC (cn, cl + 1) s+    nodeC (cn, cl) (Node _ c s) =+      let (cnc, clc) = nodeC (cn + 1, cl) c+          (snc, slc) = nodeC (0, 0) s+      in (cnc + snc, clc + slc)