diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,18 @@ +module Main where + +import qualified Data.Tree +import Data.TreeBench +import Data.Tree.SetBench +import Data.Tree.KnuthBench +import Criterion.Main + + + + +main = defaultMain + [ bgroup "Trees" + [ data_tree_bench + , data_settree_bench + , data_knuthtree_bench + ] + ] diff --git a/bench/Data/Tree/KnuthBench.hs b/bench/Data/Tree/KnuthBench.hs new file mode 100644 --- /dev/null +++ b/bench/Data/Tree/KnuthBench.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE + FlexibleContexts + #-} + +module Data.Tree.KnuthBench (data_knuthtree_bench) where + +import Prelude hiding (elem) +import Data.Monoid +import Data.Tree.Knuth +import qualified Data.Tree.Knuth.Forest as F +import Control.Monad.State +import Criterion + + +newNode :: MonadState Int m => F.KnuthForest Int -> m (KnuthTree Int) +newNode xs = do x <- get + modify (+1) + return $ KnuthTree (x, xs) + +-- makeWith :: Int -> Int -> Int -> State Int (Tree Int) +makeWith d w r | d <= 1 || w <= 1 = return F.Nil + | otherwise = do ws <- makeWith d (w-1) r + xs <- makeWith (d-1) (floor $ fromIntegral w / r) r + x <- get + modify (+1) + return $ F.Fork x xs ws + +tree1 = evalState (makeWith 1 1 2 >>= newNode) 1 +tree2 = evalState (makeWith 2 2 2 >>= newNode) 1 +tree3 = evalState (makeWith 3 3 2 >>= newNode) 1 +tree4 = evalState (makeWith 4 4 2 >>= newNode) 1 +tree5 = evalState (makeWith 5 5 2 >>= newNode) 1 + + +data_knuthtree_bench = bgroup "Data.Tree.Knuth" + [ bgroup "depth" + [ bench "1" $ whnf (elem 1) tree1 + , bench "2" $ whnf (elem 2) tree2 + , bench "3" $ whnf (elem 5) tree3 + , bench "4" $ whnf (elem 18) tree4 + , bench "5" $ whnf (elem 23) tree5 + ] + , bgroup "width" + [ bench "1" $ whnf (elem 1) tree1 + , bench "2" $ whnf (elem 2) tree2 + , bench "3" $ whnf (elem 6) tree3 + , bench "4" $ whnf (elem 20) tree4 + , bench "5" $ whnf (elem 25) tree5 + ] + ] diff --git a/bench/Data/Tree/SetBench.hs b/bench/Data/Tree/SetBench.hs new file mode 100644 --- /dev/null +++ b/bench/Data/Tree/SetBench.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE + FlexibleContexts + #-} + +module Data.Tree.SetBench (data_settree_bench) where + +import Prelude hiding (elem) +import Data.Monoid +import qualified Data.Set as Set +import Data.Tree.Set +import Control.Monad.State +import Criterion + + +newNode :: MonadState Int m => Set.Set (SetTree Int) -> m (SetTree Int) +newNode xs = do x <- get + modify (+1) + return $ SetTree x xs + +-- makeWith :: Int -> Int -> Int -> State Int (Tree Int) +makeWith d w r | d <= 1 = newNode Set.empty + | otherwise = do xs <- replicateM w $ makeWith (d-1) (floor $ fromIntegral w / r) r + newNode $ Set.fromList xs + +tree1 = evalState (makeWith 1 1 2) 1 +tree2 = evalState (makeWith 2 2 2) 1 +tree3 = evalState (makeWith 3 3 2) 1 +tree4 = evalState (makeWith 4 4 2) 1 +tree5 = evalState (makeWith 5 5 2) 1 + + +data_settree_bench = bgroup "Data.Tree.Set" + [ bgroup "depth" + [ bench "1" $ whnf (elem 1) tree1 + , bench "2" $ whnf (elem 2) tree2 + , bench "3" $ whnf (elem 5) tree3 + , bench "4" $ whnf (elem 18) tree4 + , bench "5" $ whnf (elem 23) tree5 + ] + , bgroup "width" + [ bench "1" $ whnf (elem 1) tree1 + , bench "2" $ whnf (elem 2) tree2 + , bench "3" $ whnf (elem 6) tree3 + , bench "4" $ whnf (elem 20) tree4 + , bench "5" $ whnf (elem 25) tree5 + ] + ] diff --git a/bench/Data/TreeBench.hs b/bench/Data/TreeBench.hs new file mode 100644 --- /dev/null +++ b/bench/Data/TreeBench.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE + FlexibleContexts + #-} + +module Data.TreeBench (data_tree_bench) where + +import Data.Monoid +import Data.Tree +import Data.Tree.Rose +import Control.Monad.State +import Criterion + + +newNode :: MonadState Int m => [Tree Int] -> m (Tree Int) +newNode xs = do x <- get + modify (+1) + return $ Node x xs + +-- makeWith :: Int -> Int -> Int -> State Int (Tree Int) +makeWith d w r | d <= 1 = newNode [] + | otherwise = do xs <- replicateM w $ makeWith (d-1) (floor $ (fromIntegral w) / r) r + newNode xs + +tree1 = evalState (makeWith 1 1 2) 1 +tree2 = evalState (makeWith 2 2 2) 1 +tree3 = evalState (makeWith 3 3 2) 1 +tree4 = evalState (makeWith 4 4 2) 1 +tree5 = evalState (makeWith 5 5 2) 1 + + +data_tree_bench = bgroup "Data.Tree" + [ bgroup "depth" + [ bench "1" $ whnf (elemT 1) tree1 + , bench "2" $ whnf (elemT 2) tree2 + , bench "3" $ whnf (elemT 5) tree3 + , bench "4" $ whnf (elemT 18) tree4 + , bench "5" $ whnf (elemT 23) tree5 + ] + , bgroup "width" + [ bench "1" $ whnf (elemT 1) tree1 + , bench "2" $ whnf (elemT 2) tree2 + , bench "3" $ whnf (elemT 6) tree3 + , bench "4" $ whnf (elemT 20) tree4 + , bench "5" $ whnf (elemT 25) tree5 + ] + ] + +elemT :: Eq a => a -> Tree a -> Bool +elemT x (Node y ys) = x == y || getAny (foldMap (Any . elemT x) ys) diff --git a/rose-trees.cabal b/rose-trees.cabal --- a/rose-trees.cabal +++ b/rose-trees.cabal @@ -1,5 +1,5 @@ Name: rose-trees -Version: 0.0.1.1 +Version: 0.0.2 Author: Athan Clark Maintainer: Athan Clark License: BSD3 @@ -8,6 +8,7 @@ -- Description: Cabal-Version: >= 1.10 Build-Type: Simple +Category: Data, Tree Library Default-Language: Haskell2010 @@ -15,13 +16,18 @@ GHC-Options: -Wall Exposed-Modules: Data.Tree.Rose Data.Tree.Knuth - Other-Modules: Data.Tree.Rose.Internal - Build-Depends: base >= 4 && < 5 + Data.Tree.Knuth.Forest + Data.Tree.Set + Build-Depends: base >= 4.6 && < 5 , containers , semigroups - , data-default - , pseudo-trie - , transformers + , semigroupoids + , witherable + , sets + , QuickCheck + , quickcheck-instances + , mtl + , criterion Test-Suite spec Type: exitcode-stdio-1.0 @@ -30,10 +36,48 @@ , test Ghc-Options: -Wall Main-Is: Spec.hs + Other-Modules: Data.Tree.Knuth + Data.Tree.Knuth.Forest + Data.Tree.Rose + Data.Tree.Set + Data.Tree.RoseSpec Build-Depends: base - , hspec + , rose-trees + , witherable + , containers + , semigroups + , semigroupoids + , sets + , tasty + , tasty-quickcheck , QuickCheck , quickcheck-instances + +Benchmark bench + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: src + , bench + Ghc-Options: -Wall + Main-Is: Bench.hs + Other-Modules: Data.Tree.Knuth + Data.Tree.Knuth.Forest + Data.Tree.Rose + Data.Tree.Set + Data.TreeBench + Data.Tree.SetBench + Data.Tree.KnuthBench + Build-Depends: base + , rose-trees + , witherable + , containers + , semigroups + , semigroupoids + , sets + , QuickCheck + , quickcheck-instances + , mtl + , criterion Source-Repository head Type: git diff --git a/src/Data/Tree/Knuth.hs b/src/Data/Tree/Knuth.hs --- a/src/Data/Tree/Knuth.hs +++ b/src/Data/Tree/Knuth.hs @@ -1,36 +1,140 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE + DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , FlexibleInstances + #-} +-- | +-- Module : Data.Tree.Knuth +-- Copyright : (c) 2014, 2015 Athan Clark +-- +-- License : BSD-style +-- Maintainer : athan.clark@gmail.com +-- Stability : experimental +-- Portability : GHC +-- +-- An implementation of +-- . + module Data.Tree.Knuth where -import Prelude hiding (foldr) -import Data.Monoid -import Data.Foldable +import qualified Data.Tree.Knuth.Forest as KF -data KnuthForest a = Fork { node :: a - , children :: (KnuthForest a) - , siblings :: (KnuthForest a) } - | Nil - deriving (Show, Eq, Functor) +import Data.Semigroup +import Data.Foldable as F +import Data.Maybe +import qualified Data.Set.Class as Sets +import Control.Applicative +import Control.Monad -appendSibling :: KnuthForest a -> KnuthForest a -> KnuthForest a -appendSibling Nil _ = Nil -appendSibling (Fork x xc Nil) y = Fork x xc y -appendSibling (Fork x xc xs) y = Fork x xc $ appendSibling xs y +import Test.QuickCheck -instance Monoid (KnuthForest a) where - mempty = Nil - mappend = appendSibling -instance Foldable KnuthForest where - foldr f acc Nil = acc - foldr f acc (Fork x xc xs) = - foldr f (foldr f (f x acc) xs) xc +newtype KnuthTree a = KnuthTree { unKnuthTree :: (a, KF.KnuthForest a) } + deriving (Show, Eq, Functor, Foldable, Traversable) -newtype KnuthTree a = KnuthTree { unKnuthTree :: (a, KnuthForest a) } - deriving (Show, Eq, Functor) +instance Arbitrary a => Arbitrary (KnuthTree a) where + arbitrary = do + x <- arbitrary + xs <- arbitrary + return $ KnuthTree (x,xs) --- | Breadth-first -instance Foldable KnuthTree where - foldr f acc (KnuthTree (x, xs)) = foldr f (f x acc) xs +firstTree :: KF.KnuthForest a -> Maybe (KnuthTree a) +firstTree KF.Nil = Nothing +firstTree (KF.Fork x xc _) = Just $ KnuthTree (x,xc) + + +instance Applicative KnuthTree where + pure x = KnuthTree (x,KF.Nil) + (KnuthTree (f,fs)) <*> (KnuthTree (x,xs)) = KnuthTree (f x,fs <*> xs) + +instance Monad KnuthTree where + return x = KnuthTree (x,KF.Nil) + (KnuthTree (x,xs)) >>= f = + let (KnuthTree (y,_)) = f x + in KnuthTree (y,xs >>= (snd . unKnuthTree . f)) + +instance Semigroup (KnuthTree a) where + (<>) = union + +instance Sets.HasSize (KnuthTree a) where + size = size + +instance Sets.HasSingleton a (KnuthTree a) where + singleton = singleton + +instance Sets.HasUnion (KnuthTree a) where + union = union + +-- ** Query +size :: KnuthTree a -> Int +size (KnuthTree (_,xs)) = 1 + KF.size xs + +elem :: Eq a => a -> KnuthTree a -> Bool +elem x (KnuthTree (y,ys)) = x == y || KF.elem x ys + +isSubtreeOf :: Eq a => KnuthTree a -> KnuthTree a -> Bool +isSubtreeOf xss yss@(KnuthTree (_,ys)) = xss == yss || go ys + where + go KF.Nil = False + go zss@(KF.Fork x xc xs) = xss == fromJust (firstTree zss) || go xs || go xc + +-- | Bottom-up depth-first +isSubtreeOf' :: Eq a => KnuthTree a -> KnuthTree a -> Bool +isSubtreeOf' xss yss@(KnuthTree (_,ys)) = go ys || xss == yss + where + go KF.Nil = False + go zss@(KF.Fork x xc xs) = go xc || go xs || xss == fromJust (firstTree zss) + +isProperSubtreeOf :: Eq a => KnuthTree a -> KnuthTree a -> Bool +isProperSubtreeOf xss (KnuthTree (_,ys)) = go ys + where + go KF.Nil = False + go zss@(KF.Fork x xc xs) = xss == fromJust (firstTree zss) || go xs || go xc + +-- | Bottom-up depth-first +isProperSubtreeOf' :: Eq a => KnuthTree a -> KnuthTree a -> Bool +isProperSubtreeOf' xss (KnuthTree (_,ys)) = go ys + where + go KF.Nil = False + go zss@(KF.Fork x xc xs) = go xc || go xs || xss == fromJust (firstTree zss) + +isChildOf :: Eq a => a -> KnuthTree a -> Bool +isChildOf x (KnuthTree (_,ys)) = KF.isChildOf x ys + +isDescendantOf :: Eq a => a -> KnuthTree a -> Bool +isDescendantOf x (KnuthTree (y,ys)) = x == y || KF.isDescendantOf x ys + +isProperDescendantOf :: Eq a => a -> KnuthTree a -> Bool +isProperDescendantOf x (KnuthTree (_,ys)) = KF.isDescendantOf x ys + +-- ** Construction + +singleton :: a -> KnuthTree a +singleton x = KnuthTree (x,KF.Nil) + +delete :: Eq a => a -> KnuthTree a -> Maybe (KnuthTree a) +delete x (KnuthTree (y,ys)) | x == y = Nothing + | otherwise = Just $ KnuthTree (y, KF.delete x ys) + +-- ** Combination + +union :: KnuthTree a -> KnuthTree a -> KnuthTree a +union (KnuthTree (_,xs)) (KnuthTree (y,ys)) = KnuthTree (y, KF.union xs ys) + +intersection :: Eq a => KnuthTree a -> KnuthTree a -> Maybe (KnuthTree a) +intersection (KnuthTree (x,xs)) (KnuthTree (y,ys)) = do + guard $ x == y + return $ KnuthTree (y,KF.intersection xs ys) + +difference :: Eq a => KnuthTree a -> KnuthTree a -> Maybe (KnuthTree a) +difference xss@(KnuthTree (x,xs)) (KnuthTree (y,ys)) = do + guard $ x /= y + return $ KnuthTree (x,go ys) + where + go KF.Nil = KF.Nil + go zss@(KF.Fork x xc xs) | xss == fromJust (firstTree zss) = KF.Nil + | otherwise = KF.Fork x (go xc) (go xs) diff --git a/src/Data/Tree/Knuth/Forest.hs b/src/Data/Tree/Knuth/Forest.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Knuth/Forest.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE + DeriveFunctor + , MultiParamTypeClasses + , FlexibleInstances + #-} + +module Data.Tree.Knuth.Forest where + +import Prelude hiding (foldr, elem) +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Data.Foldable hiding (elem) +import Data.Witherable +import Data.Traversable +import qualified Data.Set.Class as Sets +import Control.Applicative +import Control.Monad + +import Test.QuickCheck + + +-- * Forest + +data KnuthForest a = Fork { kNode :: a + , kChildren :: KnuthForest a + , kSiblings :: KnuthForest a } + | Nil + deriving (Show, Eq, Functor) + +instance Arbitrary a => Arbitrary (KnuthForest a) where + arbitrary = oneof [ return Nil + , liftA3 Fork arbitrary arbitrary arbitrary + ] + + +-- | Siblings before children +instance Ord a => Ord (KnuthForest a) where + compare (Fork x xc xs) (Fork y yc ys) = + compare x y <> compare xs ys <> compare xc yc + compare Nil Nil = EQ + compare Nil _ = LT + compare _ Nil = GT + +-- | Zippy +instance Applicative KnuthForest where + pure x = Fork x Nil Nil + Nil <*> _ = Nil + _ <*> Nil = Nil + (Fork f fc fs) <*> (Fork x xc xs) = + Fork (f x) (fc <*> xc) (fs <*> xs) + +instance Alternative KnuthForest where + empty = Nil + (<|>) = union + +-- | Breadth-first +instance Monad KnuthForest where + return x = Fork x Nil Nil + Nil >>= _ = Nil + (Fork x xc xs) >>= f = f x `union` (xs >>= f) `union` (xc >>= f) + +instance MonadPlus KnuthForest where + mzero = Nil + mplus = union + +instance Semigroup (KnuthForest a) where + (<>) = union + +instance Monoid (KnuthForest a) where + mempty = Nil + mappend = union + +-- | Breadth-first +instance Foldable KnuthForest where + foldr _ acc Nil = acc + foldr f acc (Fork x xc xs) = + foldr f (foldr f (f x acc) xs) xc + +instance Traversable KnuthForest where + sequenceA Nil = pure Nil + sequenceA (Fork x xc xs) = liftA3 Fork x (sequenceA xc) (sequenceA xs) + +instance Witherable KnuthForest where + catMaybes Nil = Nil + catMaybes (Fork mx xc xs) = case mx of + Nothing -> Nil + Just x -> Fork x (catMaybes xc) (catMaybes xs) + +instance Sets.HasUnion (KnuthForest a) where + union = union + +instance Eq a => Sets.HasIntersection (KnuthForest a) where + intersection = intersection + +instance Eq a => Sets.HasDifference (KnuthForest a) where + difference = difference + +instance Sets.HasSize (KnuthForest a) where + size = size + +instance Sets.HasEmpty (KnuthForest a) where + empty = Nil + +instance Sets.HasSingleton a (KnuthForest a) where + singleton = singleton + +instance Eq a => Sets.HasDelete a (KnuthForest a) where + delete = delete + +-- ** Query + +size :: KnuthForest a -> Int +size Nil = 0 +size (Fork _ xc xs) = 1 + size xc + size xs + +-- Breadth-first +elem :: Eq a => a -> KnuthForest a -> Bool +elem _ Nil = False +elem x (Fork y yc ys) = x == y || elem x ys || elem x yc + +-- Top-down, breadth-first +isSubforestOf :: Eq a => KnuthForest a -> KnuthForest a -> Bool +isSubforestOf Nil _ = True +isSubforestOf xss yss@(Fork _ yc ys) = + xss == yss || isSubforestOf xss ys || isSubforestOf xss yc +isSubforestOf _ Nil = False + +-- Bottom-up, depth-first +isSubforestOf' :: Eq a => KnuthForest a -> KnuthForest a -> Bool +isSubforestOf' Nil _ = True +isSubforestOf' xss yss@(Fork _ yc ys) = + isSubforestOf xss yc || isSubforestOf xss ys || xss == yss +isSubforestOf' _ Nil = False + +-- | No siblings +isProperSubforestOf :: Eq a => KnuthForest a -> KnuthForest a -> Bool +isProperSubforestOf Nil _ = True +isProperSubforestOf xss (Fork _ yc _) = isSubforestOf xss yc +isProperSubforestOf _ Nil = False + +-- | Depth-first +isProperSubforestOf' :: Eq a => KnuthForest a -> KnuthForest a -> Bool +isProperSubforestOf' Nil _ = True +isProperSubforestOf' xss (Fork _ yc _) = isSubforestOf' xss yc +isProperSubforestOf' _ Nil = False + +isSiblingOf :: Eq a => a -> KnuthForest a -> Bool +isSiblingOf _ Nil = False +isSiblingOf x (Fork y _ ys) = x == y || isSiblingOf x ys + +-- | depth of one +isChildOf :: Eq a => a -> KnuthForest a -> Bool +isChildOf _ Nil = False +isChildOf x (Fork _ yc ys) = isSiblingOf x yc || isChildOf x ys + + +isDescendantOf :: Eq a => a -> KnuthForest a -> Bool +isDescendantOf _ Nil = False +isDescendantOf x (Fork y yc _) = x == y || isDescendantOf x yc + +isProperDescendantOf :: Eq a => a -> KnuthForest a -> Bool +isProperDescendantOf _ Nil = False +isProperDescendantOf x (Fork _ yc _) = isDescendantOf x yc + + +-- ** Construction + +singleton :: a -> KnuthForest a +singleton x = Fork x Nil Nil + +delete :: Eq a => a -> KnuthForest a -> KnuthForest a +delete _ Nil = Nil +delete x (Fork y yc ys) | x == y = Nil + | otherwise = Fork y (delete x yc) (delete x ys) + +-- ** Combination + +union :: KnuthForest a -> KnuthForest a -> KnuthForest a +union Nil y = y +union (Fork x xc Nil) y = Fork x xc y +union (Fork x xc xs) y = Fork x xc $ union xs y + +intersection :: Eq a => KnuthForest a -> KnuthForest a -> KnuthForest a +intersection Nil _ = Nil +intersection _ Nil = Nil +intersection (Fork x xc xs) (Fork y yc ys) + | x == y = Fork y (intersection xc yc) (intersection xs ys) + | otherwise = Nil + +-- | Removes the possible subtree on the right, from the left. +difference :: Eq a => KnuthForest a -> KnuthForest a -> KnuthForest a +difference Nil _ = Nil +difference x Nil = x +difference (Fork x xc xs) yss@(Fork y _ _) + | x == y = Nil + | otherwise = Fork x (difference xc yss) (difference xs yss) diff --git a/src/Data/Tree/Rose.hs b/src/Data/Tree/Rose.hs --- a/src/Data/Tree/Rose.hs +++ b/src/Data/Tree/Rose.hs @@ -1,32 +1,56 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE + TypeFamilies + , KindSignatures + , MultiParamTypeClasses + , FunctionalDependencies + , FlexibleInstances + #-} module Data.Tree.Rose where -import Data.Tree.Rose.Internal - import Data.Tree (Tree (Node)) import Data.Tree.Knuth -import Data.Trie.Pseudo hiding (Nil) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Default -import Data.Functor.Identity +import Data.Tree.Knuth.Forest as KF +import Data.Tree.Set +import qualified Data.Set as Set -class RoseTree (c :: * -> *) (u :: * -> *) (t :: * -> *) | c -> u, c -> t where - (@->) :: t a -> u (c a) -> c a +type family Head (x :: *) :: * +type family Tail (y :: *) :: * + +class RoseTree (c :: * -> *) where + (@->) :: Head (c a) -> Tail (c a) -> c a + infixr 9 @-> -instance RoseTree Tree [] Identity where - (@->) (Identity x) xs = Node x xs -newtype PT t a = PT (t, Maybe a) +-- Data.Tree +type instance Head (Tree a) = a +type instance Tail (Tree a) = [Tree a] -instance Default t => RoseTree (PseudoTrie t) NonEmpty (PT t) where - (@->) (PT x) xs = More x xs +instance RoseTree Tree where + (@->) = Node -instance RoseTree KnuthForest Identity Identity where - (@->) (Identity x) (Identity xs) = Fork x xs Nil + +-- Data.Tree.Knuth.Forest +type instance Head (KnuthForest a) = a +type instance Tail (KnuthForest a) = KnuthForest a + +instance RoseTree KnuthForest where + x @-> xs = Fork x xs Nil + + +-- Data.Tree.Knuth +type instance Head (KnuthTree a) = a +type instance Tail (KnuthTree a) = KnuthForest a + +instance RoseTree KnuthTree where + x @-> xs = KnuthTree (x,xs) + + +-- Data.Tree.Set +type instance Head (SetTree a) = a +type instance Tail (SetTree a) = Set.Set (SetTree a) + +instance RoseTree SetTree where + (@->) = SetTree diff --git a/src/Data/Tree/Rose/Internal.hs b/src/Data/Tree/Rose/Internal.hs deleted file mode 100644 --- a/src/Data/Tree/Rose/Internal.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Data.Tree.Rose.Internal - ( - ) where diff --git a/src/Data/Tree/Set.hs b/src/Data/Tree/Set.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Set.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE + DeriveFoldable + , FlexibleInstances + , MultiParamTypeClasses + #-} + +module Data.Tree.Set where + +import Prelude hiding (map, elem, filter) +import qualified Data.Set as Set +import qualified Data.Foldable as F +import qualified Data.Maybe as M +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Data.Semigroup.Foldable +import qualified Data.Set.Class as Sets +import Control.Applicative +import Control.Monad + +import Test.QuickCheck +import Test.QuickCheck.Instances + + +data SetTree a = SetTree + { sNode :: a + , sChildren :: Set.Set (SetTree a) + } deriving (Show, Eq, Ord, Foldable) + +instance (Ord a, Arbitrary a) => Arbitrary (SetTree a) where + arbitrary = liftA2 SetTree arbitrary arbitrary + +instance Foldable1 SetTree where + fold1 (SetTree x xs) = F.foldr (\a acc -> sNode a <> acc) x xs + +instance Sets.HasSize (SetTree a) where + size = size + +instance Sets.HasSingleton a (SetTree a) where + singleton = singleton + + +-- * Query + +-- | set-like alias for @isDescendantOf@. +elem :: Eq a => a -> SetTree a -> Bool +elem = isDescendantOf + +size :: SetTree a -> Int +size (SetTree _ xs) = 1 + getSum (F.foldMap (Sum . size) xs) + +isChildOf :: Eq a => a -> SetTree a -> Bool +isChildOf x (SetTree _ ys) = + getAny $ F.foldMap (Any . (x ==) . sNode) ys + +isDescendantOf :: Eq a => a -> SetTree a -> Bool +isDescendantOf x (SetTree y ys) = + (x == y) || getAny (F.foldMap (Any . isDescendantOf x) ys) + +-- | Heirarchical analogue to subseteq. +isSubtreeOf :: Eq a => SetTree a -> SetTree a -> Bool +isSubtreeOf xss yss@(SetTree _ ys) = + xss == yss || getAny (F.foldMap (Any . isSubtreeOf xss) ys) + +-- | Bottom-up version +isSubtreeOf' :: Eq a => SetTree a -> SetTree a -> Bool +isSubtreeOf' xss yss@(SetTree _ ys) = + getAny (F.foldMap (Any . isSubtreeOf' xss) ys) || xss == yss + +isProperSubtreeOf :: Eq a => SetTree a -> SetTree a -> Bool +isProperSubtreeOf xss (SetTree _ ys) = + getAny $ F.foldMap (Any . isSubtreeOf xss) ys + +-- | Bottom-up version +isProperSubtreeOf' :: Eq a => SetTree a -> SetTree a -> Bool +isProperSubtreeOf' xss (SetTree _ ys) = + getAny $ F.foldMap (Any . isSubtreeOf' xss) ys + +eqHead :: Eq a => SetTree a -> SetTree a -> Bool +eqHead (SetTree x _) (SetTree y _) = x == y + +-- * Construction + +insertChild :: Ord a => SetTree a -> SetTree a -> SetTree a +insertChild x (SetTree y ys) = SetTree y $ Set.insert x ys + +delete :: Eq a => a -> SetTree a -> Maybe (SetTree a) +delete x = filter (/= x) + +singleton :: a -> SetTree a +singleton x = SetTree x Set.empty + +-- * Filtering + +filter :: Eq a => (a -> Bool) -> SetTree a -> Maybe (SetTree a) +filter p (SetTree x xs) = do + guard $ p x + return $ SetTree x $ Set.fromAscList $ M.mapMaybe (filter p) $ Set.toAscList xs + +-- * Mapping + +map :: Ord b => (a -> b) -> SetTree a -> SetTree b +map f (SetTree x xs) = SetTree (f x) $ Set.map (map f) xs + +mapMaybe :: Eq b => (a -> Maybe b) -> SetTree a -> Maybe (SetTree b) +mapMaybe p (SetTree x xs) = do + x' <- p x + return $ SetTree x' $ Set.fromAscList $ M.mapMaybe (mapMaybe p) $ Set.toAscList xs diff --git a/test/Data/Tree/RoseSpec.hs b/test/Data/Tree/RoseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Tree/RoseSpec.hs @@ -0,0 +1,46 @@ +module Data.Tree.RoseSpec where + +import Data.Tree.Rose + +import Data.Monoid +import qualified Data.Tree as T +import qualified Data.Set as Set +import qualified Data.Tree.Set as S +import qualified Data.Tree.Knuth as K +import qualified Data.Tree.Knuth.Forest as KF + + +import Test.Tasty +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck +import Test.QuickCheck.Instances + + +spec :: TestTree +spec = testGroup "Testing trees..." + [ testGroup "Data.Tree" + [ QC.testProperty "element after construction" prop_cons_exists_Tree + ] + , testGroup "Data.Tree.Set" + [ QC.testProperty "element after construction" prop_cons_exists_SetTree + ] + , testGroup "Data.Tree.Knuth" + [ QC.testProperty "element after construction" prop_cons_exists_KnuthTree + ] + ] + +newtype TreeWithElem t e = TreeWithElem {unTreeWithElem :: (e, t e)} + + +prop_cons_exists_Tree :: Int -> [T.Tree Int] -> Bool +prop_cons_exists_Tree x xs = elem' x $ x @-> xs + where elem' x (T.Node y ys) = x == y || getAny (foldMap (Any . elem' x) ys) + +prop_cons_exists_SetTree :: Int -> Set.Set (S.SetTree Int) -> Bool +prop_cons_exists_SetTree x xs = S.elem x $ x @-> xs + +prop_cons_exists_KnuthTree :: Int -> KF.KnuthForest Int -> Bool +prop_cons_exists_KnuthTree x xs = K.elem x $ x @-> xs + + +-- instance (Arbitrary e diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,13 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +module Main where + +import Data.Tree.RoseSpec + +import Test.Tasty + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Testing..." + [spec]