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
+ ]
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..13619ba
--- /dev/null
+++ b/hs/treetrie4.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE FlexibleInstances #-}
+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
+
+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
+ 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 :: 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
+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))
+
+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