tries 0.0.1 → 0.0.2
raw patch · 7 files changed
+245/−23 lines, 7 filesdep +QuickCheckdep +quickcheck-instancesdep +tastydep ~basedep ~composition-extradep ~rose-trees
Dependencies added: QuickCheck, quickcheck-instances, tasty, tasty-quickcheck
Dependency ranges changed: base, composition-extra, rose-trees, sets
Files
- bench/Bench.hs +25/−6
- src/Data/Trie/Knuth.hs +5/−3
- src/Data/Trie/List.hs +36/−7
- src/Data/Trie/Map.hs +33/−6
- test/Data/TrieSpec.hs +93/−0
- test/Spec.hs +12/−0
- tries.cabal +41/−1
bench/Bench.hs view
@@ -5,6 +5,8 @@ import Data.Tree (Tree (..)) import Data.Trie.List as L import Data.Trie.Map as M+import Data.Tree.Knuth.Forest as K+import Data.Trie.Knuth as K import Data.Trie.Class as TC import qualified Data.Map as Map import Criterion.Main@@ -36,16 +38,25 @@ else Just $ MapTrie $ MapStep $ genMapTree (n-1))) 1 +genKnuthTrie :: Int -> KnuthTrie Int Int+genKnuthTrie n = KnuthTrie $ Fork (0, Just 0) (genKnuthForest n n) Nil+ where+ genKnuthForest :: Int -> Int -> KnuthForest (Int, Maybe Int)+ genKnuthForest 0 _ = Nil+ genKnuthForest n s = let cs = if n <= 1 then Nil else genKnuthForest (n-1) (n-1)+ ss = if s <= 1 then Nil else genKnuthForest n (s-1)+ in Fork (s, Just s) cs ss + main = defaultMain [ bgroup "lookup" [ bgroup "ListTrie"- [ bench "1" $ whnf (L.lookup $ 0 :| [100]) (genListTrie 100)- , bench "2" $ whnf (L.lookup $ 0 :| [100,99..81]) (genListTrie 100)- , bench "3" $ whnf (L.lookup $ 0 :| [100,99..61]) (genListTrie 100)- , bench "4" $ whnf (L.lookup $ 0 :| [100,99..41]) (genListTrie 100)- , bench "5" $ whnf (L.lookup $ 0 :| [100,99..21]) (genListTrie 100)- , bench "6" $ whnf (L.lookup $ 0 :| [100,99..1]) (genListTrie 100)+ [ bench "1" $ whnf (TC.lookup $ 0 :| [100]) (genListTrie 100)+ , bench "2" $ whnf (TC.lookup $ 0 :| [100,99..81]) (genListTrie 100)+ , bench "3" $ whnf (TC.lookup $ 0 :| [100,99..61]) (genListTrie 100)+ , bench "4" $ whnf (TC.lookup $ 0 :| [100,99..41]) (genListTrie 100)+ , bench "5" $ whnf (TC.lookup $ 0 :| [100,99..21]) (genListTrie 100)+ , bench "6" $ whnf (TC.lookup $ 0 :| [100,99..1]) (genListTrie 100) ] , bgroup "MapTrie" [ bench "1" $ whnf (TC.lookup $ 0 :| [100]) (genMapTrie 100)@@ -54,6 +65,14 @@ , bench "4" $ whnf (TC.lookup $ 0 :| [100,99..41]) (genMapTrie 100) , bench "5" $ whnf (TC.lookup $ 0 :| [100,99..21]) (genMapTrie 100) , bench "6" $ whnf (TC.lookup $ 0 :| [100,99..1]) (genMapTrie 100)+ ]+ , bgroup "KnuthTrie"+ [ bench "1" $ whnf (TC.lookup $ 0 :| [100]) (genKnuthTrie 100)+ , bench "2" $ whnf (TC.lookup $ 0 :| [100,99..81]) (genKnuthTrie 100)+ , bench "3" $ whnf (TC.lookup $ 0 :| [100,99..61]) (genKnuthTrie 100)+ , bench "4" $ whnf (TC.lookup $ 0 :| [100,99..41]) (genKnuthTrie 100)+ , bench "5" $ whnf (TC.lookup $ 0 :| [100,99..21]) (genKnuthTrie 100)+ , bench "6" $ whnf (TC.lookup $ 0 :| [100,99..1]) (genKnuthTrie 100) ] ] ]
src/Data/Trie/Knuth.hs view
@@ -16,10 +16,12 @@ import Data.Trie.Class +import Test.QuickCheck + newtype KnuthTrie s x = KnuthTrie {unKnuthTrie :: KnuthForest (s, Maybe x)}- deriving (Show, Eq, Functor, Foldable, Traversable)+ deriving (Show, Eq, Functor, Foldable, Traversable, Arbitrary) instance Eq s => Trie NonEmpty s KnuthTrie where lookup _ (KnuthTrie Nil) = Nothing@@ -32,7 +34,7 @@ | null ts = KnuthTrie $ Fork (t,Just x) Nil Nil | otherwise = let cs' = unKnuthTrie $ insert (NE.fromList ts) x $ KnuthTrie Nil in KnuthTrie $ Fork (t,Nothing) cs' Nil- insert tss@(t:|ts) x (KnuthTrie (Fork s@(t',mx) cs ss))+ insert tss@(t:|ts) x (KnuthTrie (Fork s@(t',_) cs ss)) | t == t' = if null ts then KnuthTrie $ Fork (t',Just x) cs ss else let cs' = unKnuthTrie $ insert (NE.fromList ts) x $ KnuthTrie cs@@ -40,7 +42,7 @@ | otherwise = KnuthTrie $ Fork s cs $ unKnuthTrie $ insert tss x $ KnuthTrie ss delete _ xs@(KnuthTrie Nil) = xs- delete tss@(t:|ts) (KnuthTrie (Fork s@(t',mx) cs ss))+ delete tss@(t:|ts) (KnuthTrie (Fork s@(t',_) cs ss)) | t == t' = if null ts then KnuthTrie $ Fork (t',Nothing) cs ss else let cs' = unKnuthTrie $ delete (NE.fromList ts) $ KnuthTrie cs
src/Data/Trie/List.hs view
@@ -4,31 +4,60 @@ , DeriveFoldable , DeriveTraversable , GeneralizedNewtypeDeriving+ , FlexibleInstances+ , MultiParamTypeClasses #-} module Data.Trie.List where +import Data.Trie.Class+ import Prelude hiding (lookup) import Data.Tree (Tree (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) import Data.Key hiding (lookup) import Data.Monoid import Control.Monad +import Test.QuickCheck+import Test.QuickCheck.Instances + newtype ListTrie t x = ListTrie { unListTrie :: Tree (t, Maybe x)- } deriving (Show, Eq, Functor, Foldable, Traversable)+ } deriving (Show, Eq, Functor, Foldable, Traversable, Arbitrary) -type instance Key (ListTrie t) = NonEmpty t+type instance Key (ListTrie s) = NonEmpty s -- TODO: Trie instance +instance Eq s => Trie NonEmpty s ListTrie where+ lookup (t:|ts) (ListTrie (Node (t',mx) xs)) = do+ guard $ t == t'+ if null ts then mx+ else getFirst $ foldMap (First . lookup (NE.fromList ts) . ListTrie) xs -lookup :: Eq t => NonEmpty t -> ListTrie t x -> Maybe x-lookup (t:|ts) (ListTrie (Node (t',mx) xs)) = do- guard $ t == t'- if null ts then mx- else getFirst $ foldMap (First . lookup (NE.fromList ts) . ListTrie) xs+ delete (t:|ts) xss@(ListTrie (Node (t',mx) xs)) =+ fromMaybe xss $ do+ guard $ t == t'+ return $ if null ts+ then ListTrie $ Node (t',Nothing) xs+ else ListTrie $ Node (t',mx) $ fmap go xs+ where go = unListTrie . delete (NE.fromList ts) . ListTrie++ insert (t:|ts) x yss@(ListTrie ys) =+ fromMaybe yss $ go ys+ where+ go (Node (t',mx) xs) = do+ guard $ t == t'+ return $ if null ts+ then ListTrie $ Node (t',Just x) xs+ else ListTrie $ Node (t',mx) $+ if any (hasHead $ head ts) xs+ then fmap (unListTrie . insert (NE.fromList ts) x . ListTrie) xs+ else xs ++ [unListTrie $ insert (NE.fromList ts) x $ ListTrie $+ Node (head ts, Nothing) []]+ hasHead t (Node (t',_) _) = t == t'
src/Data/Trie/Map.hs view
@@ -24,26 +24,36 @@ import qualified Data.Foldable as F import Data.Maybe import Data.Monoid+import Control.Monad +import Test.QuickCheck+import Test.QuickCheck.Instances ++ -- * One Step newtype MapStep c p a = MapStep { unMapStep :: Map.Map p (Maybe a, Maybe (c p a)) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) +instance (Arbitrary a, Arbitrary p, Arbitrary (c p a), Ord p) => Arbitrary (MapStep c p a) where+ arbitrary = sized go+ where+ go n = do+ i <- choose (0,n)+ xs <- replicateM i $ (,) <$> arbitrary <*> resize (floor (fromIntegral n / 2 :: Float)) arbitrary+ return $ MapStep $ Map.fromList xs ++-- | No insertion instance - requires children nodes to be a monoid. Use @Data.Trie.Map.insert@+-- instead. instance (Ord p, Trie NonEmpty p c) => Trie NonEmpty p (MapStep c) where lookup (p:|ps) (MapStep xs) | F.null ps = do (mx,_) <- Map.lookup p xs mx | otherwise = do (_,mxs) <- Map.lookup p xs lookup (NE.fromList ps) =<< mxs- insert (p:|ps) x (MapStep xs)- | F.null ps = let mxs = snd =<< Map.lookup p xs- in MapStep $ Map.insert p (Just x,mxs) xs- | otherwise = let (mx,mxs) = fromMaybe (Nothing,Nothing) $ Map.lookup p xs- in MapStep $ Map.insert p (mx, insert (NE.fromList ps) x <$> mxs) xs delete (p:|ps) (MapStep xs) | F.null ps = let mxs = snd =<< Map.lookup p xs in MapStep $ Map.insert p (Nothing,mxs) xs@@ -51,6 +61,18 @@ in MapStep $ Map.insert p (mx, delete (NE.fromList ps) <$> mxs) xs +insert :: ( Ord p+ , Trie NonEmpty p c+ , Monoid (c p a)+ ) => NonEmpty p -> a -> MapStep c p a -> MapStep c p a+insert (p:|ps) x (MapStep xs)+ | F.null ps = let mxs = snd =<< Map.lookup p xs+ in MapStep $ Map.insert p (Just x,mxs) xs+ | otherwise = let mx = fst =<< Map.lookup p xs+ xs' = fromMaybe mempty (snd =<< Map.lookup p xs)+ in MapStep $ Map.insert p (mx, Just $ Data.Trie.Class.insert (NE.fromList ps) x xs') xs++ instance (Ord s, Monoid (c s a)) => Monoid (MapStep c s a) where mempty = empty mappend (MapStep xs) (MapStep ys) = MapStep $ Map.unionWith go xs ys@@ -67,7 +89,12 @@ newtype MapTrie s a = MapTrie { unMapTrie :: MapStep MapTrie s a }- deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Monoid, Trie NonEmpty s)+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Monoid, Arbitrary)++instance Ord s => Trie NonEmpty s MapTrie where+ lookup ts (MapTrie xs) = lookup ts xs+ delete ts (MapTrie xs) = MapTrie $ delete ts xs+ insert ts x (MapTrie xs) = MapTrie $ Data.Trie.Map.insert ts x xs type instance K.Key (MapTrie s) = NonEmpty s
+ test/Data/TrieSpec.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE+ FlexibleInstances+ , FlexibleContexts+ #-}++module Data.TrieSpec (trieSpec) where++import Prelude hiding (lookup)+import Data.Maybe (isJust, isNothing)+import Data.Trie.Class as TC+import Data.Trie.List as L+import Data.Tree (Tree (..))+import Data.Trie.Map as M hiding (insert)+import Data.Trie.Knuth as K hiding (lookup, insert, delete)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.QuickCheck+import Test.QuickCheck.Instances++++trieSpec :: [TestTree]+trieSpec =+ [ testGroup "Data.Trie.List"+ [ QC.testProperty "lookup after insertion should exist" lookupInsertExists_List+ , QC.testProperty "lookup after deletion should not exist" lookupDeleteNotExists_List+ ]+ , testGroup "Data.Trie.Map"+ [ QC.testProperty "lookup after insertion should exist" lookupInsertExists_Map+ , QC.testProperty "lookup after deletion should not exist" lookupDeleteNotExists_Map+ ]+ , testGroup "Data.Trie.Knuth"+ [ QC.testProperty "lookup after insertion should exist" lookupInsertExists_Knuth+ , QC.testProperty "lookup after deletion should not exist" lookupDeleteNotExists_Knuth+ ]+ ]++++newtype PathWithHead c p a = PathWithHead (NonEmpty p, c p a)+ deriving (Show)++instance (Arbitrary a, Arbitrary p, Eq p) => Arbitrary (PathWithHead ListTrie p a) where+ arbitrary = do ts@(t:|_) <- arbitrary+ xss <- arbitrary `suchThat` hasHead t+ return $ PathWithHead (ts,xss)+ where hasHead t (ListTrie (Node (t',_) _)) = t == t'++++lookupInsertExists_List :: PathWithHead ListTrie Int Int -> Int -> Bool+lookupInsertExists_List (PathWithHead (ts,trie)) x = lookupInsertExists ts x trie++lookupInsertExists_Map :: NonEmpty Int -> Int -> MapTrie Int Int -> Bool+lookupInsertExists_Map = lookupInsertExists++lookupInsertExists_Knuth :: NonEmpty Int -> Int -> KnuthTrie Int Int -> Bool+lookupInsertExists_Knuth = lookupInsertExists++lookupInsertExists :: ( Arbitrary (p s)+ , Arbitrary (t s a)+ , Arbitrary a+ , Trie p s t+ ) => p s -> a -> t s a -> Bool+lookupInsertExists ps x trie = isJust $ lookup ps $ insert ps x trie++++lookupDeleteNotExists_List :: NonEmpty Int -> ListTrie Int Int -> Bool+lookupDeleteNotExists_List = lookupDeleteNotExists++lookupDeleteNotExists_Map :: NonEmpty Int -> MapTrie Int Int -> Bool+lookupDeleteNotExists_Map = lookupDeleteNotExists++lookupDeleteNotExists_Knuth :: NonEmpty Int -> KnuthTrie Int Int -> Bool+lookupDeleteNotExists_Knuth = lookupDeleteNotExists++lookupDeleteNotExists :: ( Arbitrary (p s)+ , Arbitrary (t s a)+ , Arbitrary a+ , Trie p s t+ ) => p s -> t s a -> Bool+lookupDeleteNotExists ps trie = isNothing $ lookup ps $ delete ps trie++++-- Instances -------------++instance Arbitrary a => Arbitrary (NonEmpty a) where+ arbitrary = NE.fromList <$> arbitrary `suchThat` (not . null)
+ test/Spec.hs view
@@ -0,0 +1,12 @@+module Main where++import Data.TrieSpec++import Test.Tasty+++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Testing..." trieSpec
tries.cabal view
@@ -1,5 +1,5 @@ Name: tries-Version: 0.0.1+Version: 0.0.2 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -29,9 +29,42 @@ , composition-extra >= 2.0.0 , keys , sets >= 0.0.5+ , QuickCheck+ , quickcheck-instances , mtl , criterion +Test-Suite test+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , test+ Ghc-Options: -Wall+ Main-Is: Spec.hs+ Other-Modules: Data.TrieSpec+ Data.Trie.Class+ Data.Trie.Knuth+ Data.Trie.List+ Data.Trie.Map+ Data.Trie.Pseudo+ Build-Depends: base+ , tries+ , tasty+ , tasty-quickcheck+ , QuickCheck+ , quickcheck-instances+ , containers+ , bytestring+ , bytestring-trie+ , semigroups+ , rose-trees+ , composition+ , composition-extra+ , keys+ , sets+ , mtl++ Benchmark bench Type: exitcode-stdio-1.0 Default-Language: Haskell2010@@ -39,6 +72,11 @@ , bench Ghc-Options: -Wall Main-Is: Bench.hs+ Other-Modules: Data.Trie.Class+ Data.Trie.Knuth+ Data.Trie.List+ Data.Trie.Map+ Data.Trie.Pseudo Build-Depends: base , tries , criterion@@ -52,6 +90,8 @@ , keys , sets , mtl+ , QuickCheck+ , quickcheck-instances Source-Repository head Type: git