Other implementations

This commit is contained in:
Tony Garnock-Jones 2016-03-07 17:23:06 +00:00
parent 54056da195
commit 5a9e51c640
3 changed files with 514 additions and 0 deletions

147
hs/treetrie2.hs Normal file
View File

@ -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 "<a>" (ok [2])),
"route union wild1" ~: Set.fromList [1,2] ~=?
route [Open, Ch 'a', Close] (union
(seqs "*" (ok [1]))
(seqs "<a>" (ok [2]))) Set.empty,
"route union wild2" ~: Set.fromList [1] ~=?
route [Open, Ch 'b', Close] (union
(seqs "*" (ok [1]))
(seqs "<a>" (ok [2]))) Set.empty,
"route union wild3" ~: Set.fromList [1] ~=?
route [Open, Close] (union
(seqs "*" (ok [1]))
(seqs "<a>" (ok [2]))) Set.empty,
"route union wild4" ~: Set.fromList [1] ~=?
route [Open, Ch 'a', Ch 'a', Close] (union
(seqs "*" (ok [1]))
(seqs "<a>" (ok [2]))) Set.empty
]

170
hs/treetrie3.hs Normal file
View File

@ -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 "<a>" (ok [2])),
"route union wild1" ~: Set.fromList [1,2] ~=?
route "<a>" (union
(seqs "*" (ok [1]))
(seqs "<a>" (ok [2]))) Set.empty,
"route union wild2" ~: Set.fromList [1] ~=?
route "<b>" (union
(seqs "*" (ok [1]))
(seqs "<a>" (ok [2]))) Set.empty,
"route union wild3" ~: Set.fromList [1] ~=?
route "<>" (union
(seqs "*" (ok [1]))
(seqs "<a>" (ok [2]))) Set.empty,
"route union wild4" ~: Set.fromList [1] ~=?
route "<aa>" (union
(seqs "*" (ok [1]))
(seqs "<a>" (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]))
]

197
hs/treetrie4.hs Normal file
View File

@ -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]))))
]