From 54056da195b5d9b13f4ef80be825c6ad75a06c43 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 7 Mar 2016 17:22:15 +0000 Subject: [PATCH 1/3] --- hs/treetrie1.hs | 130 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 130 insertions(+) create mode 100644 hs/treetrie1.hs diff --git a/hs/treetrie1.hs b/hs/treetrie1.hs new file mode 100644 index 0000000..ae1adbd --- /dev/null +++ b/hs/treetrie1.hs @@ -0,0 +1,130 @@ +module TreeTrie where + +-- import Debug.Trace +import Prelude hiding (null, seq) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.HUnit + +data Sigma = Open + | Close + | Wild + | Ch Char + deriving (Eq, Ord, Show) + +data Trie a = Ok a + | Tl (Trie a) + | Br (Map.Map Sigma (Trie a)) + deriving (Eq, Show) + +empty = Br Map.empty + +null (Br h) = Map.null h +null _ = False + +tl r = if null r then empty else Tl r + +untl (Tl r) = r +untl _ = empty + +route [] (Ok v) f = v +route [] _ f = f +route (_ : _) (Ok v) f = f +route (x : s) (Br h) f = if Map.null h + then f + else route s (get h x) f +route (Close : s) (Tl r) f = route s r f +route (Open : s) (Tl r) f = route s (tl (tl r)) f +route (x : s) (Tl r) f = route s (tl r) f + +get h x = case Map.lookup x h of + Just r -> r + Nothing -> case x of + Open -> tl (get h Wild) + Close -> untl (get h Wild) + Wild -> empty + x -> get h Wild + +combine r1 r2 f leftEmpty rightEmpty = g r1 r2 + where g (Tl r1) (Tl r2) = tl (g r1 r2) + g (Tl r1) r2 = g (expand r1) r2 + g r1 (Tl r2) = g r1 (expand r2) + g (Ok v) r2 = f (Ok v) r2 + g r1 (Ok v) = f r1 (Ok v) + g r1 r2 | null r1 = dedup $ leftEmpty r2 + g r1 r2 | null r2 = dedup $ rightEmpty r1 + g (Br h1) (Br h2) = dedup $ Br (foldKeys g h1 h2) + +foldKeys g h1 h2 = Set.foldr f Map.empty keys + where f x acc = Map.insert x (g (get h1 x) (get h2 x)) acc + keys = Set.union (Map.keysSet h1) (Map.keysSet h2) + +expand r = Br (Map.fromList [(Wild, tl r), (Close, r)]) + +dedup (Br h) = Br (Map.filterWithKey (distinct h) h) + +distinct h Wild r = not (null r) +distinct h Open (Tl r) = r /= get h Wild +distinct h Open r = not (null r) +distinct h Close r = r /= untl (get h Wild) +distinct h x r = r /= get h Wild + +--------------------------------------------------------------------------- + +union r1 r2 = combine r1 r2 unionCombine id id +unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +unionCombine r1 r2 | null r1 = r2 +unionCombine r1 r2 | null r2 = r1 + +unions rs = foldr union empty rs + +--------------------------------------------------------------------------- + +ok vs = Ok (Set.fromList vs) +seq x r = if null r then r else Br (Map.singleton x r) + +seqCh '<' = Open +seqCh '>' = Close +seqCh '*' = Wild +seqCh x = Ch x + +seqs s r = foldr (\ x r -> seq (seqCh x) r) r s + +main = runTestTT $ + test [ + "seqs simple" ~: seq Open (seq Close (Ok (Set.singleton 1))) ~=? seqs "<>" (ok [1]), + "union simple1" ~: Br (Map.fromList [(Ch 'a', ok [1]), + (Ch 'b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: Br (Map.fromList [(Ch 'a', ok [1,2]), + (Ch 'b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + -- This is noisier than it needs to be. + Br (Map.fromList [(Open,Br (Map.fromList [(Close, ok [1]), + (Wild,Br (Map.fromList [(Wild,Tl (ok [1]))])), + (Ch 'a',Br (Map.fromList [(Close, ok [1,2]), + (Wild,Br (Map.fromList [(Wild,Tl (ok [1]))]))]))])), + (Wild, ok [1])]) + ~=? union (seqs "*" (ok [1])) (seqs "" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route [Open, Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route [Open, Ch 'b', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route [Open, Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route [Open, Ch 'a', Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty + ] From 5a9e51c6408fd0dc0c8533aa312bf6ed8ae4a0d6 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 7 Mar 2016 17:23:06 +0000 Subject: [PATCH 2/3] Other implementations --- hs/treetrie2.hs | 147 ++++++++++++++++++++++++++++++++++++ hs/treetrie3.hs | 170 +++++++++++++++++++++++++++++++++++++++++ hs/treetrie4.hs | 197 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 514 insertions(+) create mode 100644 hs/treetrie2.hs create mode 100644 hs/treetrie3.hs create mode 100644 hs/treetrie4.hs diff --git a/hs/treetrie2.hs b/hs/treetrie2.hs new file mode 100644 index 0000000..a6309c1 --- /dev/null +++ b/hs/treetrie2.hs @@ -0,0 +1,147 @@ +module TreeTrie where + +-- import Debug.Trace +import Prelude hiding (null, seq) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.HUnit + +data Sigma = Open + | Close + | Wild + | Ch Char + deriving (Eq, Ord, Show) + +data Trie a = Ok a + | Tl (Trie a) + | Br (Map.Map Sigma (Trie a)) + deriving (Eq, Show) + +empty = Br Map.empty + +null (Br h) = Map.null h +null _ = False + +tl r = if null r then empty else Tl r + +untl (Tl r) = r +untl _ = empty + +route [] (Ok v) f = v +route [] _ f = f +route (_ : _) (Ok v) f = f +route (x : s) (Br h) f = if Map.null h + then f + else route s (get h x) f +route (Close : s) (Tl r) f = route s r f +route (Open : s) (Tl r) f = route s (tl (tl r)) f +route (x : s) (Tl r) f = route s (tl r) f + +get h x = case Map.lookup x h of + Just r -> r + Nothing -> case x of + Open -> tl (get h Wild) + Close -> untl (get h Wild) + Wild -> empty + x -> get h Wild + +combine r1 r2 f leftEmpty rightEmpty = g r1 r2 + where g (Tl r1) (Tl r2) = tl (g r1 r2) + g (Tl r1) r2 = g (expand r1) r2 + g r1 (Tl r2) = g r1 (expand r2) + g (Ok v) r2 = f (Ok v) r2 + g r1 (Ok v) = f r1 (Ok v) + g r1 r2 | null r1 = collapse $ leftEmpty r2 + g r1 r2 | null r2 = collapse $ rightEmpty r1 + g (Br h1) (Br h2) = collapse $ Br (foldKeys g h1 h2) + +foldKeys g h1 h2 = Set.foldr f Map.empty keys + where f x acc = update x (g (get h1 x) (get h2 x)) acc + keys = Set.union (Map.keysSet h1) (Map.keysSet h2) + +expand r = Br (Map.fromList [(Wild, tl r), (Close, r)]) + +collapse (Br h) = if Map.size h == 2 + then case (Map.lookup Wild h, Map.lookup Close h) of + (Just (w @ (Tl k1)), Just k2) | k1 == k2 -> w + _ -> Br h + else if Map.size h == 1 + then case Map.lookup Wild h of + Just (w @ (Tl _)) -> w + _ -> Br h + else Br h + +update Wild k h = + if null k + then Map.delete Wild h + else Map.insert Wild k h +update Open (Tl k) h = + case Map.lookup Wild h of + Just k' | k' == k -> Map.delete Open h + _ -> Map.insert Open (Tl k) h +update Close k h = + case Map.lookup Wild h of + Just (Tl k') | k' == k -> Map.delete Close h + _ -> Map.insert Close k h +update x k h = + case Map.lookup Wild h of + Just k' | k' == k -> Map.delete x h + _ -> Map.insert x k h + +--------------------------------------------------------------------------- + +union r1 r2 = combine r1 r2 unionCombine id id +unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +unionCombine r1 r2 | null r1 = r2 +unionCombine r1 r2 | null r2 = r1 + +unions rs = foldr union empty rs + +--------------------------------------------------------------------------- + +ok vs = Ok (Set.fromList vs) +seq x r = if null r then r else Br (Map.singleton x r) + +seqCh '<' = Open +seqCh '>' = Close +seqCh '*' = Wild +seqCh x = Ch x + +seqs s r = foldr (\ x r -> seq (seqCh x) r) r s + +main = runTestTT $ + test [ + "seqs simple" ~: seq Open (seq Close (Ok (Set.singleton 1))) ~=? seqs "<>" (ok [1]), + "union simple1" ~: Br (Map.fromList [(Ch 'a', ok [1]), + (Ch 'b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: Br (Map.fromList [(Ch 'a', ok [1,2]), + (Ch 'b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + Br (Map.fromList [(Open,Br (Map.fromList [(Wild,Tl (ok [1])), + (Ch 'a',Br (Map.fromList [(Close,ok [1,2]), + (Wild,Tl (ok [1]))]))])), + (Wild,ok [1])]) + ~=? union (seqs "*" (ok [1])) (seqs "" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route [Open, Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route [Open, Ch 'b', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route [Open, Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route [Open, Ch 'a', Ch 'a', Close] (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty + ] diff --git a/hs/treetrie3.hs b/hs/treetrie3.hs new file mode 100644 index 0000000..49a9161 --- /dev/null +++ b/hs/treetrie3.hs @@ -0,0 +1,170 @@ +module TreeTrie where + +-- import Debug.Trace +import Prelude hiding (null, seq) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.HUnit + +data Trie a = Mt + | Ok a + | Tl (Trie a) + | Br (Trie a, Trie a, Trie a, Map.Map Char (Trie a)) -- Open, Close, Wild, rest + deriving (Eq, Show) + +empty = Mt + +null Mt = True +null _ = False + +tl r = if null r then empty else Tl r + +untl (Tl r) = r +untl _ = empty + +route _ Mt f = f +route [] (Ok v) f = v +route [] _ f = f +route (_ : _) (Ok v) f = f +route ('<' : s) (Br (r, _, _, _)) f = route s r f +route ('>' : s) (Br (_, r, _, _)) f = route s r f +route (x : s) (Br (_, _, w, h)) f = route s (Map.findWithDefault w x h) f +route ('<' : s) (Tl r) f = route s (tl (tl r)) f +route ('>' : s) (Tl r) f = route s r f +route (x : s) (Tl r) f = route s (tl r) f + +get w h x = Map.findWithDefault w x h + +combine f leftEmpty rightEmpty r1 r2 = g r1 r2 + where g (Tl r1) (Tl r2) = tl (g r1 r2) + g (Tl r1) r2 = g (expand r1) r2 + g r1 (Tl r2) = g r1 (expand r2) + g (Ok v) r2 = f (Ok v) r2 + g r1 (Ok v) = f r1 (Ok v) + g r1 r2 | null r1 = collapse $ leftEmpty r2 + g r1 r2 | null r2 = collapse $ rightEmpty r1 + g r1 r2 = collapse $ foldKeys g r1 r2 + +foldKeys g (Br (o1, c1, w1, h1)) (Br (o2, c2, w2, h2)) = + Br (g o1 o2, g c1 c2, w, Set.foldr f Map.empty keys) + where w = g w1 w2 + f x acc = update x (g (get w1 h1 x) (get w2 h2 x)) w acc + keys = Set.union (Map.keysSet h1) (Map.keysSet h2) + +expand r = Br (Mt, r, tl r, Map.empty) + +collapse (Br (Mt, k, Tl k', h)) | Map.null h && k == k' = tl k +collapse (Br (Mt, Mt, Tl k, h)) | Map.null h = tl k +collapse (Br (Mt, Mt, Mt, h)) | Map.null h = empty +collapse r = r + +update x k w h = if k == w then Map.delete x h else Map.insert x k h + +--------------------------------------------------------------------------- + +union = combine unionCombine id id +unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +unionCombine r1 r2 | null r1 = r2 +unionCombine r1 r2 | null r2 = r1 + +unions rs = foldr union empty rs + +intersection = combine intersectionCombine (const empty) (const empty) +intersectionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +intersectionCombine r1 r2 | null r1 = empty +intersectionCombine r1 r2 | null r2 = empty + +difference = combine differenceCombine (const empty) id +differenceCombine (Ok vs) (Ok ws) = let xs = Set.difference vs ws in + if Set.null xs then empty else (Ok xs) +differenceCombine r1 r2 | null r1 = empty +differenceCombine r1 r2 | null r2 = r1 + +--------------------------------------------------------------------------- + +ok vs = Ok (Set.fromList vs) + +seq _ r | null r = r +seq '<' r = Br (r, Mt, Mt, Map.empty) +seq '>' r = Br (Mt, r, Mt, Map.empty) +seq '*' r = Br (tl r, untl r, r, Map.empty) +seq x r = Br (Mt, Mt, Mt, Map.singleton x r) + +seqs s r = foldr seq r s + +main = runTestTT $ + test [ + "seqs simple" ~: + Br (Br (Mt, ok [1], Mt, Map.empty), Mt, Mt, Map.empty) ~=? seqs "<>" (ok [1]), + "union simple1" ~: + Br (Mt, Mt, Mt, + Map.fromList [('a', ok [1]), + ('b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: + Br (Mt, Mt, Mt, + Map.fromList [('a', ok [1,2]), + ('b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: + (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + Br (Br (Mt, + ok [1], + Tl (ok [1]), + Map.fromList [('a', Br (Mt, + ok [1,2], + Tl (ok [1]), + Map.empty))]), + Mt, + ok [1], + Map.empty) ~=? + union (seqs "*" (ok [1])) (seqs "" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route "" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route "" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route "<>" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route "" (union + (seqs "*" (ok [1])) + (seqs "" (ok [2]))) Set.empty, + "intersection simple1" ~: + seqs "a" (ok [1,2]) ~=? intersection (seqs "a" (ok [1])) (seqs "a" (ok [2])), + "intersection simple2" ~: + empty ~=? intersection (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "intersection idem" ~: + (seqs "abc" (ok [1])) ~=? + intersection (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "difference simple1" ~: + seqs "a" (ok [1]) ~=? difference (seqs "a" (ok [1,2])) (seqs "a" (ok [2])), + "difference simple1a" ~: + seqs "ab" (ok [1]) ~=? difference (seqs "ab" (ok [1,2])) (seqs "ab" (ok [2])), + "difference simple2" ~: + empty ~=? difference (seqs "a" (ok [1])) (seqs "a" (ok [1])), + "difference wild" ~: + Br (Tl (ok [1]), + Mt, + ok [1], + Map.fromList [('a', Mt)]) ~=? + difference (seqs "*" (ok [1])) (seqs "a" (ok [1])), + "union after difference" ~: + seqs "*" (ok [1]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [1])), + "union after difference 2" ~: + Br (Tl (ok [1]), + Mt, + ok [1], + Map.fromList [('a', ok [2])]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [2])) + ] diff --git a/hs/treetrie4.hs b/hs/treetrie4.hs new file mode 100644 index 0000000..a7bf783 --- /dev/null +++ b/hs/treetrie4.hs @@ -0,0 +1,197 @@ +module TreeTrie where + +-- import Debug.Trace +import Prelude hiding (null, seq) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Test.HUnit + +data Trie a = Mt + | Ok a + | Br (Map.Map Integer (Trie a), Trie a, Map.Map Char (Trie a)) -- Opens, Wild, rest + deriving (Eq, Show) + +empty = Mt + +null Mt = True +null _ = False + +makeTail _ r | null r = r +makeTail 0 r = r +makeTail n r = Br (Map.empty, makeTail (n - 1) r, Map.empty) + +stripTail _ r | null r = Just r +stripTail 0 r = Just r +stripTail n (Br (os, r, h)) | Map.null os && Map.null h = stripTail (n - 1) r +stripTail _ _ = Nothing + +route _ Mt f = f +route [] (Ok v) f = v +route [] _ f = f +route (_ : _) (Ok v) f = f +route ('<' : nc : s) (Br (os, w, _)) f = + let n = (read (nc : []) :: Integer) in + case Map.lookup n os of + Just r -> route s r f + Nothing -> route s (makeTail n w) f +route (x : s) (Br (_, w, h)) f = route s (Map.findWithDefault w x h) f + +get w h x = Map.findWithDefault w x h + +combine f leftEmpty rightEmpty r1 r2 = g r1 r2 + where g (Ok v) r2 = f (Ok v) r2 + g r1 (Ok v) = f r1 (Ok v) + g r1 r2 | null r1 = collapse $ leftEmpty r2 + g r1 r2 | null r2 = collapse $ rightEmpty r1 + g r1 r2 = collapse $ foldKeys g r1 r2 + +foldKeys g (Br (os1, w1, h1)) (Br (os2, w2, h2)) = + Br (Set.foldr fo Map.empty sizes, w, Set.foldr f Map.empty keys) + where sizes = Set.union (Map.keysSet os1) (Map.keysSet os2) + w = g w1 w2 + fo size acc = let o1 = Map.findWithDefault (makeTail size w1) size os1 in + let o2 = Map.findWithDefault (makeTail size w2) size os2 in + let o = g o1 o2 in + if stripTail size o == Just w then acc else Map.insert size o acc + f x acc = update x (g (get w1 h1 x) (get w2 h2 x)) w acc + keys = Set.union (Map.keysSet h1) (Map.keysSet h2) + +collapse (Br (os, Mt, h)) | Map.null os && Map.null h = empty +collapse r = r + +update x k w h = if k == w then Map.delete x h else Map.insert x k h + +--------------------------------------------------------------------------- + +union = combine unionCombine id id +unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +unionCombine r1 r2 | null r1 = r2 +unionCombine r1 r2 | null r2 = r1 + +unions rs = foldr union empty rs + +intersection = combine intersectionCombine (const empty) (const empty) +intersectionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) +intersectionCombine r1 r2 | null r1 = empty +intersectionCombine r1 r2 | null r2 = empty + +difference = combine differenceCombine (const empty) id +differenceCombine (Ok vs) (Ok ws) = let xs = Set.difference vs ws in + if Set.null xs then empty else (Ok xs) +differenceCombine r1 r2 | null r1 = empty +differenceCombine r1 r2 | null r2 = r1 + +--------------------------------------------------------------------------- + +ok vs = Ok (Set.fromList vs) + +seqs _ r | null r = r +seqs [] r = r +seqs ('<' : n : s) r = Br (Map.singleton (read (n : []) :: Integer) (seqs s r), Mt, Map.empty) +seqs ('*' : s) r = Br (Map.empty, seqs s r, Map.empty) +seqs (x : s) r = Br (Map.empty, Mt, Map.singleton x (seqs s r)) + +main = runTestTT $ + test [ + "seqs simple" ~: + Br (Map.singleton 0 (ok [1]), Mt, Map.empty) ~=? seqs "<0" (ok [1]), + "union simple1" ~: + Br (Map.empty, Mt, + Map.fromList [('a', ok [1]), + ('b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: + Br (Map.empty, Mt, + Map.fromList [('a', ok [1,2]), + ('b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: + (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + Br (Map.singleton 1 (Br (Map.empty, + ok [1], + Map.singleton 'a' (ok [1,2]))), + ok [1], + Map.empty) ~=? + union (seqs "*" (ok [1])) (seqs "<1a" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route "<1a" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route "<1b" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route "<0" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route "<2aa" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "intersection simple1" ~: + seqs "a" (ok [1,2]) ~=? intersection (seqs "a" (ok [1])) (seqs "a" (ok [2])), + "intersection simple2" ~: + empty ~=? intersection (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "intersection idem" ~: + (seqs "abc" (ok [1])) ~=? + intersection (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "difference simple1" ~: + seqs "a" (ok [1]) ~=? difference (seqs "a" (ok [1,2])) (seqs "a" (ok [2])), + "difference simple1a" ~: + seqs "ab" (ok [1]) ~=? difference (seqs "ab" (ok [1,2])) (seqs "ab" (ok [2])), + "difference simple2" ~: + empty ~=? difference (seqs "a" (ok [1])) (seqs "a" (ok [1])), + "difference wild" ~: + Br (Map.empty, + ok [1], + Map.fromList [('a', Mt)]) ~=? + difference (seqs "*" (ok [1])) (seqs "a" (ok [1])), + "difference wild 2" ~: + Br (Map.singleton 1 (Br (Map.empty, + ok [1], + Map.singleton 'a' Mt)), + ok [1], + Map.empty) ~=? + difference (seqs "*" (ok [1])) (seqs "<1a" (ok [1])), + "difference wild 3" ~: + Br (Map.singleton 0 Mt, + ok [1], + Map.empty) ~=? + difference (seqs "*" (ok [1])) (seqs "<0" (ok [1])), + "union after difference" ~: + seqs "*" (ok [1]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [1])), + "union after difference 2" ~: + Br (Map.empty, + ok [1], + Map.fromList [('a', ok [2])]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [2])), + "intersection no overlap opens" ~: + empty ~=? + intersection (seqs "<2aa" (ok [1])) (seqs "<1b" (ok [2])), + "intersection no overlap opens 2" ~: + Br (Map.empty, Mt, Map.singleton 'x' (ok [1,2])) ~=? + (intersection + (union (seqs "x" (ok [1])) (seqs "<2aa" (ok [1]))) + (union (seqs "x" (ok [2])) (seqs "<1b" (ok [2])))), + "intersection no overlap opens 3" ~: + Br (Map.fromList [(1,Br (Map.empty, + ok [3,4], + Map.fromList [('b', ok [2,3,4])])), + (2,Br (Map.empty, + Br (Map.empty, ok [3,4], Map.empty), + Map.fromList [('a',Br (Map.empty, + ok [3,4], + Map.fromList [('a', + ok [1,3,4])]))]))], + ok [3,4], + Map.empty) ~=? + (intersection + (union (seqs "*" (ok [3])) (seqs "<2aa" (ok [1]))) + (union (seqs "*" (ok [4])) (seqs "<1b" (ok [2])))) + ] From 4b2332053254918470c27344dbb2c9bf52e99f3e Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 8 Mar 2016 17:07:35 +0000 Subject: [PATCH 3/3] Quickcheck tests. --- hs/treetrie4.hs | 295 +++++++++++++++++++++++++++++++----------------- 1 file changed, 191 insertions(+), 104 deletions(-) diff --git a/hs/treetrie4.hs b/hs/treetrie4.hs index a7bf783..13619ba 100644 --- a/hs/treetrie4.hs +++ b/hs/treetrie4.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} module TreeTrie where -- import Debug.Trace @@ -6,6 +7,9 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Test.HUnit +import Test.QuickCheck +import Control.Monad + data Trie a = Mt | Ok a | Br (Map.Map Integer (Trie a), Trie a, Map.Map Char (Trie a)) -- Opens, Wild, rest @@ -63,6 +67,7 @@ update x k w h = if k == w then Map.delete x h else Map.insert x k h --------------------------------------------------------------------------- +union :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t) union = combine unionCombine id id unionCombine (Ok vs) (Ok ws) = Ok (Set.union vs ws) unionCombine r1 r2 | null r1 = r2 @@ -91,107 +96,189 @@ seqs ('<' : n : s) r = Br (Map.singleton (read (n : []) :: Integer) (seqs s r), seqs ('*' : s) r = Br (Map.empty, seqs s r, Map.empty) seqs (x : s) r = Br (Map.empty, Mt, Map.singleton x (seqs s r)) -main = runTestTT $ - test [ - "seqs simple" ~: - Br (Map.singleton 0 (ok [1]), Mt, Map.empty) ~=? seqs "<0" (ok [1]), - "union simple1" ~: - Br (Map.empty, Mt, - Map.fromList [('a', ok [1]), - ('b', ok [2])]) ~=? - union (seqs "a" (ok [1])) (seqs "b" (ok [2])), - "union simple2" ~: - Br (Map.empty, Mt, - Map.fromList [('a', ok [1,2]), - ('b', ok [2])]) ~=? - unions [seqs "a" (ok [1]), - seqs "b" (ok [2]), - seqs "a" (ok [2])], - "union idem" ~: - (seqs "abc" (ok [1])) ~=? - union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), - "union wild" ~: - Br (Map.singleton 1 (Br (Map.empty, - ok [1], - Map.singleton 'a' (ok [1,2]))), - ok [1], - Map.empty) ~=? - union (seqs "*" (ok [1])) (seqs "<1a" (ok [2])), - "route union wild1" ~: Set.fromList [1,2] ~=? - route "<1a" (union - (seqs "*" (ok [1])) - (seqs "<1a" (ok [2]))) Set.empty, - "route union wild2" ~: Set.fromList [1] ~=? - route "<1b" (union - (seqs "*" (ok [1])) - (seqs "<1a" (ok [2]))) Set.empty, - "route union wild3" ~: Set.fromList [1] ~=? - route "<0" (union - (seqs "*" (ok [1])) - (seqs "<1a" (ok [2]))) Set.empty, - "route union wild4" ~: Set.fromList [1] ~=? - route "<2aa" (union - (seqs "*" (ok [1])) - (seqs "<1a" (ok [2]))) Set.empty, - "intersection simple1" ~: - seqs "a" (ok [1,2]) ~=? intersection (seqs "a" (ok [1])) (seqs "a" (ok [2])), - "intersection simple2" ~: - empty ~=? intersection (seqs "a" (ok [1])) (seqs "b" (ok [2])), - "intersection idem" ~: - (seqs "abc" (ok [1])) ~=? - intersection (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), - "difference simple1" ~: - seqs "a" (ok [1]) ~=? difference (seqs "a" (ok [1,2])) (seqs "a" (ok [2])), - "difference simple1a" ~: - seqs "ab" (ok [1]) ~=? difference (seqs "ab" (ok [1,2])) (seqs "ab" (ok [2])), - "difference simple2" ~: - empty ~=? difference (seqs "a" (ok [1])) (seqs "a" (ok [1])), - "difference wild" ~: - Br (Map.empty, - ok [1], - Map.fromList [('a', Mt)]) ~=? - difference (seqs "*" (ok [1])) (seqs "a" (ok [1])), - "difference wild 2" ~: - Br (Map.singleton 1 (Br (Map.empty, - ok [1], - Map.singleton 'a' Mt)), - ok [1], - Map.empty) ~=? - difference (seqs "*" (ok [1])) (seqs "<1a" (ok [1])), - "difference wild 3" ~: - Br (Map.singleton 0 Mt, - ok [1], - Map.empty) ~=? - difference (seqs "*" (ok [1])) (seqs "<0" (ok [1])), - "union after difference" ~: - seqs "*" (ok [1]) ~=? - union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [1])), - "union after difference 2" ~: - Br (Map.empty, - ok [1], - Map.fromList [('a', ok [2])]) ~=? - union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [2])), - "intersection no overlap opens" ~: - empty ~=? - intersection (seqs "<2aa" (ok [1])) (seqs "<1b" (ok [2])), - "intersection no overlap opens 2" ~: - Br (Map.empty, Mt, Map.singleton 'x' (ok [1,2])) ~=? - (intersection - (union (seqs "x" (ok [1])) (seqs "<2aa" (ok [1]))) - (union (seqs "x" (ok [2])) (seqs "<1b" (ok [2])))), - "intersection no overlap opens 3" ~: - Br (Map.fromList [(1,Br (Map.empty, - ok [3,4], - Map.fromList [('b', ok [2,3,4])])), - (2,Br (Map.empty, - Br (Map.empty, ok [3,4], Map.empty), - Map.fromList [('a',Br (Map.empty, - ok [3,4], - Map.fromList [('a', - ok [1,3,4])]))]))], - ok [3,4], - Map.empty) ~=? - (intersection - (union (seqs "*" (ok [3])) (seqs "<2aa" (ok [1]))) - (union (seqs "*" (ok [4])) (seqs "<1b" (ok [2])))) - ] +simpleTestCases = test [ + "seqs simple" ~: + Br (Map.singleton 0 (ok [1]), Mt, Map.empty) ~=? seqs "<0" (ok [1]), + "union simple1" ~: + Br (Map.empty, Mt, + Map.fromList [('a', ok [1]), + ('b', ok [2])]) ~=? + union (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "union simple2" ~: + Br (Map.empty, Mt, + Map.fromList [('a', ok [1,2]), + ('b', ok [2])]) ~=? + unions [seqs "a" (ok [1]), + seqs "b" (ok [2]), + seqs "a" (ok [2])], + "union idem" ~: + (seqs "abc" (ok [1])) ~=? + union (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "union wild" ~: + Br (Map.singleton 1 (Br (Map.empty, + ok [1], + Map.singleton 'a' (ok [1,2]))), + ok [1], + Map.empty) ~=? + union (seqs "*" (ok [1])) (seqs "<1a" (ok [2])), + "route union wild1" ~: Set.fromList [1,2] ~=? + route "<1a" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "route union wild2" ~: Set.fromList [1] ~=? + route "<1b" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "route union wild3" ~: Set.fromList [1] ~=? + route "<0" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "route union wild4" ~: Set.fromList [1] ~=? + route "<2aa" (union + (seqs "*" (ok [1])) + (seqs "<1a" (ok [2]))) Set.empty, + "intersection simple1" ~: + seqs "a" (ok [1,2]) ~=? intersection (seqs "a" (ok [1])) (seqs "a" (ok [2])), + "intersection simple2" ~: + empty ~=? intersection (seqs "a" (ok [1])) (seqs "b" (ok [2])), + "intersection idem" ~: + (seqs "abc" (ok [1])) ~=? + intersection (seqs "abc" (ok [1])) (seqs "abc" (ok [1])), + "difference simple1" ~: + seqs "a" (ok [1]) ~=? difference (seqs "a" (ok [1,2])) (seqs "a" (ok [2])), + "difference simple1a" ~: + seqs "ab" (ok [1]) ~=? difference (seqs "ab" (ok [1,2])) (seqs "ab" (ok [2])), + "difference simple2" ~: + empty ~=? difference (seqs "a" (ok [1])) (seqs "a" (ok [1])), + "difference wild" ~: + Br (Map.empty, + ok [1], + Map.fromList [('a', Mt)]) ~=? + difference (seqs "*" (ok [1])) (seqs "a" (ok [1])), + "difference wild 2" ~: + Br (Map.singleton 1 (Br (Map.empty, + ok [1], + Map.singleton 'a' Mt)), + ok [1], + Map.empty) ~=? + difference (seqs "*" (ok [1])) (seqs "<1a" (ok [1])), + "difference wild 3" ~: + Br (Map.singleton 0 Mt, + ok [1], + Map.empty) ~=? + difference (seqs "*" (ok [1])) (seqs "<0" (ok [1])), + "union after difference" ~: + seqs "*" (ok [1]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [1])), + "union after difference 2" ~: + Br (Map.empty, + ok [1], + Map.fromList [('a', ok [2])]) ~=? + union (difference (seqs "*" (ok [1])) (seqs "a" (ok [1]))) (seqs "a" (ok [2])), + "intersection no overlap opens" ~: + empty ~=? + intersection (seqs "<2aa" (ok [1])) (seqs "<1b" (ok [2])), + "intersection no overlap opens 2" ~: + Br (Map.empty, Mt, Map.singleton 'x' (ok [1,2])) ~=? + (intersection + (union (seqs "x" (ok [1])) (seqs "<2aa" (ok [1]))) + (union (seqs "x" (ok [2])) (seqs "<1b" (ok [2])))), + "intersection no overlap opens 3" ~: + Br (Map.fromList [(1,Br (Map.empty, + ok [3,4], + Map.fromList [('b', ok [2,3,4])])), + (2,Br (Map.empty, + Br (Map.empty, ok [3,4], Map.empty), + Map.fromList [('a',Br (Map.empty, + ok [3,4], + Map.fromList [('a', + ok [1,3,4])]))]))], + ok [3,4], + Map.empty) ~=? + (intersection + (union (seqs "*" (ok [3])) (seqs "<2aa" (ok [1]))) + (union (seqs "*" (ok [4])) (seqs "<1b" (ok [2])))) + ] + +--------------------------------------------------------------------------- + +newtype Pattern = Pattern { getPattern :: String } deriving (Eq, Ord, Show) +newtype Message = Message { getMessage :: String } deriving (Eq, Ord, Show) + +instance Arbitrary Pattern where + arbitrary = liftM Pattern $ sized $ trieNoLargerThan + where leaf = oneof $ [return "x", + return "y", + return "z", + return "*"] + trieNoLargerThan leafLimit = + if leafLimit >= 1 + then frequency [(2, leaf), (3, node leafLimit)] + else leaf + node leafLimit = + do degree <- choose (0, min 4 leafLimit) + kids <- genChildren leafLimit degree + return $ "<" ++ show degree ++ concat kids + genChildren leafLimit 0 = return [] + genChildren leafLimit degree = + do childLimit <- choose (1, leafLimit - (degree - 1)) + child <- trieNoLargerThan childLimit + rest <- genChildren (leafLimit - childLimit) (degree - 1) + return (child : rest) + +instance Arbitrary Message where + arbitrary = do Pattern p <- arbitrary + m <- sequence $ [if c == '*' + then do Message m <- scale (`div` 2) arbitrary + return m + else return (c : []) + | c <- p] + return $ Message $ concat m + +instance Arbitrary (Set.Set Integer) where + arbitrary = resize 5 $ sized set + where set 0 = return Set.empty + set n = do v <- arbitrary `suchThat` (\v -> v >= 0) + s <- set (n - 1) + return $ Set.insert v s + +genTrie k 0 = return Mt +genTrie k n = do Pattern p <- arbitrary + rest <- genTrie k (n - 1) + return $ union (seqs p k) rest + +type TrieOfPids = Trie (Set.Set Integer) + +instance Arbitrary TrieOfPids where + -- arbitrary = do vs <- arbitrary + -- resize 6 $ sized $ genTrie (Ok vs) + arbitrary = resize 6 $ sized $ genTrie (ok [1]) + +isWild (Br (os, w, h)) = Map.null os && Map.null h +isWild _ = False + +trieContains t (Message m) = not $ Set.null $ route m t Set.empty + +combineBasics :: (TrieOfPids -> TrieOfPids -> TrieOfPids) -> + (Bool -> Bool -> Bool) -> + (TrieOfPids, TrieOfPids, Message) -> + Property +combineBasics tf bf (trie1, trie2, element) = + not (isWild trie1) && not (isWild trie2) && (p || q1 || q2) ==> p == q + where p = combined `trieContains` element + q1 = trie1 `trieContains` element + q2 = trie2 `trieContains` element + q = bf q1 q2 + combined = tf trie1 trie2 + +unionBasics = combineBasics union (||) +intersectionBasics = combineBasics intersection (&&) +differenceBasics = combineBasics difference (\ x y -> x && not y) + +qCheck name t = do putStrLn name + quickCheckWith stdArgs { maxSuccess = 500 } t + +main = do runTestTT simpleTestCases + qCheck "differenceBasics" differenceBasics + qCheck "intersectionBasics" intersectionBasics + qCheck "unionBasics" unionBasics