diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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) ] ] ] diff --git a/src/Data/Trie/Knuth.hs b/src/Data/Trie/Knuth.hs --- a/src/Data/Trie/Knuth.hs +++ b/src/Data/Trie/Knuth.hs @@ -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 diff --git a/src/Data/Trie/List.hs b/src/Data/Trie/List.hs --- a/src/Data/Trie/List.hs +++ b/src/Data/Trie/List.hs @@ -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' diff --git a/src/Data/Trie/Map.hs b/src/Data/Trie/Map.hs --- a/src/Data/Trie/Map.hs +++ b/src/Data/Trie/Map.hs @@ -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 diff --git a/test/Data/TrieSpec.hs b/test/Data/TrieSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/TrieSpec.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,12 @@ +module Main where + +import Data.TrieSpec + +import Test.Tasty + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Testing..." trieSpec diff --git a/tries.cabal b/tries.cabal --- a/tries.cabal +++ b/tries.cabal @@ -1,5 +1,5 @@ Name: tries -Version: 0.0.1 +Version: 0.0.2 Author: Athan Clark Maintainer: Athan Clark 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