Rearrange hs directory into an actual Haskell project
This commit is contained in:
parent
ee0442b3e4
commit
c97b39f9a9
|
@ -0,0 +1 @@
|
||||||
|
dist/
|
|
@ -0,0 +1,165 @@
|
||||||
|
GNU LESSER GENERAL PUBLIC LICENSE
|
||||||
|
Version 3, 29 June 2007
|
||||||
|
|
||||||
|
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||||
|
Everyone is permitted to copy and distribute verbatim copies
|
||||||
|
of this license document, but changing it is not allowed.
|
||||||
|
|
||||||
|
|
||||||
|
This version of the GNU Lesser General Public License incorporates
|
||||||
|
the terms and conditions of version 3 of the GNU General Public
|
||||||
|
License, supplemented by the additional permissions listed below.
|
||||||
|
|
||||||
|
0. Additional Definitions.
|
||||||
|
|
||||||
|
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||||
|
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||||
|
General Public License.
|
||||||
|
|
||||||
|
"The Library" refers to a covered work governed by this License,
|
||||||
|
other than an Application or a Combined Work as defined below.
|
||||||
|
|
||||||
|
An "Application" is any work that makes use of an interface provided
|
||||||
|
by the Library, but which is not otherwise based on the Library.
|
||||||
|
Defining a subclass of a class defined by the Library is deemed a mode
|
||||||
|
of using an interface provided by the Library.
|
||||||
|
|
||||||
|
A "Combined Work" is a work produced by combining or linking an
|
||||||
|
Application with the Library. The particular version of the Library
|
||||||
|
with which the Combined Work was made is also called the "Linked
|
||||||
|
Version".
|
||||||
|
|
||||||
|
The "Minimal Corresponding Source" for a Combined Work means the
|
||||||
|
Corresponding Source for the Combined Work, excluding any source code
|
||||||
|
for portions of the Combined Work that, considered in isolation, are
|
||||||
|
based on the Application, and not on the Linked Version.
|
||||||
|
|
||||||
|
The "Corresponding Application Code" for a Combined Work means the
|
||||||
|
object code and/or source code for the Application, including any data
|
||||||
|
and utility programs needed for reproducing the Combined Work from the
|
||||||
|
Application, but excluding the System Libraries of the Combined Work.
|
||||||
|
|
||||||
|
1. Exception to Section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
You may convey a covered work under sections 3 and 4 of this License
|
||||||
|
without being bound by section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
2. Conveying Modified Versions.
|
||||||
|
|
||||||
|
If you modify a copy of the Library, and, in your modifications, a
|
||||||
|
facility refers to a function or data to be supplied by an Application
|
||||||
|
that uses the facility (other than as an argument passed when the
|
||||||
|
facility is invoked), then you may convey a copy of the modified
|
||||||
|
version:
|
||||||
|
|
||||||
|
a) under this License, provided that you make a good faith effort to
|
||||||
|
ensure that, in the event an Application does not supply the
|
||||||
|
function or data, the facility still operates, and performs
|
||||||
|
whatever part of its purpose remains meaningful, or
|
||||||
|
|
||||||
|
b) under the GNU GPL, with none of the additional permissions of
|
||||||
|
this License applicable to that copy.
|
||||||
|
|
||||||
|
3. Object Code Incorporating Material from Library Header Files.
|
||||||
|
|
||||||
|
The object code form of an Application may incorporate material from
|
||||||
|
a header file that is part of the Library. You may convey such object
|
||||||
|
code under terms of your choice, provided that, if the incorporated
|
||||||
|
material is not limited to numerical parameters, data structure
|
||||||
|
layouts and accessors, or small macros, inline functions and templates
|
||||||
|
(ten or fewer lines in length), you do both of the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the object code that the
|
||||||
|
Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
4. Combined Works.
|
||||||
|
|
||||||
|
You may convey a Combined Work under terms of your choice that,
|
||||||
|
taken together, effectively do not restrict modification of the
|
||||||
|
portions of the Library contained in the Combined Work and reverse
|
||||||
|
engineering for debugging such modifications, if you also do each of
|
||||||
|
the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the Combined Work that
|
||||||
|
the Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
c) For a Combined Work that displays copyright notices during
|
||||||
|
execution, include the copyright notice for the Library among
|
||||||
|
these notices, as well as a reference directing the user to the
|
||||||
|
copies of the GNU GPL and this license document.
|
||||||
|
|
||||||
|
d) Do one of the following:
|
||||||
|
|
||||||
|
0) Convey the Minimal Corresponding Source under the terms of this
|
||||||
|
License, and the Corresponding Application Code in a form
|
||||||
|
suitable for, and under terms that permit, the user to
|
||||||
|
recombine or relink the Application with a modified version of
|
||||||
|
the Linked Version to produce a modified Combined Work, in the
|
||||||
|
manner specified by section 6 of the GNU GPL for conveying
|
||||||
|
Corresponding Source.
|
||||||
|
|
||||||
|
1) Use a suitable shared library mechanism for linking with the
|
||||||
|
Library. A suitable mechanism is one that (a) uses at run time
|
||||||
|
a copy of the Library already present on the user's computer
|
||||||
|
system, and (b) will operate properly with a modified version
|
||||||
|
of the Library that is interface-compatible with the Linked
|
||||||
|
Version.
|
||||||
|
|
||||||
|
e) Provide Installation Information, but only if you would otherwise
|
||||||
|
be required to provide such information under section 6 of the
|
||||||
|
GNU GPL, and only to the extent that such information is
|
||||||
|
necessary to install and execute a modified version of the
|
||||||
|
Combined Work produced by recombining or relinking the
|
||||||
|
Application with a modified version of the Linked Version. (If
|
||||||
|
you use option 4d0, the Installation Information must accompany
|
||||||
|
the Minimal Corresponding Source and Corresponding Application
|
||||||
|
Code. If you use option 4d1, you must provide the Installation
|
||||||
|
Information in the manner specified by section 6 of the GNU GPL
|
||||||
|
for conveying Corresponding Source.)
|
||||||
|
|
||||||
|
5. Combined Libraries.
|
||||||
|
|
||||||
|
You may place library facilities that are a work based on the
|
||||||
|
Library side by side in a single library together with other library
|
||||||
|
facilities that are not Applications and are not covered by this
|
||||||
|
License, and convey such a combined library under terms of your
|
||||||
|
choice, if you do both of the following:
|
||||||
|
|
||||||
|
a) Accompany the combined library with a copy of the same work based
|
||||||
|
on the Library, uncombined with any other library facilities,
|
||||||
|
conveyed under the terms of this License.
|
||||||
|
|
||||||
|
b) Give prominent notice with the combined library that part of it
|
||||||
|
is a work based on the Library, and explaining where to find the
|
||||||
|
accompanying uncombined form of the same work.
|
||||||
|
|
||||||
|
6. Revised Versions of the GNU Lesser General Public License.
|
||||||
|
|
||||||
|
The Free Software Foundation may publish revised and/or new versions
|
||||||
|
of the GNU Lesser General Public License from time to time. Such new
|
||||||
|
versions will be similar in spirit to the present version, but may
|
||||||
|
differ in detail to address new problems or concerns.
|
||||||
|
|
||||||
|
Each version is given a distinguishing version number. If the
|
||||||
|
Library as you received it specifies that a certain numbered version
|
||||||
|
of the GNU Lesser General Public License "or any later version"
|
||||||
|
applies to it, you have the option of following the terms and
|
||||||
|
conditions either of that published version or of any later version
|
||||||
|
published by the Free Software Foundation. If the Library as you
|
||||||
|
received it does not specify a version number of the GNU Lesser
|
||||||
|
General Public License, you may choose any version of the GNU Lesser
|
||||||
|
General Public License ever published by the Free Software Foundation.
|
||||||
|
|
||||||
|
If the Library as you received it specifies that a proxy can decide
|
||||||
|
whether future versions of the GNU Lesser General Public License shall
|
||||||
|
apply, that proxy's public statement of acceptance of any version is
|
||||||
|
permanent authorization for you to choose that version for the
|
||||||
|
Library.
|
|
@ -0,0 +1,3 @@
|
||||||
|
#!/usr/bin/env runhaskell
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
|
@ -0,0 +1,79 @@
|
||||||
|
module Syndicate.Dataspace.Trie.ESOP2016 where
|
||||||
|
-- ESOP 2016 implementation of dataspace tries.
|
||||||
|
-- Includes bug fixes wrt the paper.
|
||||||
|
|
||||||
|
import Prelude hiding (null, seq)
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
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
|
|
@ -1,10 +1,10 @@
|
||||||
module TreeTrie where
|
module Syndicate.Dataspace.Trie.ESOP2016v2 where
|
||||||
|
-- Close to the ESOP 2016 implementation of dataspace tries, but takes
|
||||||
|
-- a step toward efficiency by using collapse/update instead of dedup/distinct.
|
||||||
|
|
||||||
-- import Debug.Trace
|
|
||||||
import Prelude hiding (null, seq)
|
import Prelude hiding (null, seq)
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Test.HUnit
|
|
||||||
|
|
||||||
data Sigma = Open
|
data Sigma = Open
|
||||||
| Close
|
| Close
|
||||||
|
@ -96,52 +96,3 @@ unionCombine r1 r2 | null r1 = r2
|
||||||
unionCombine r1 r2 | null r2 = r1
|
unionCombine r1 r2 | null r2 = r1
|
||||||
|
|
||||||
unions rs = foldr union empty rs
|
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
|
|
||||||
]
|
|
|
@ -0,0 +1,84 @@
|
||||||
|
module Syndicate.Dataspace.Trie.ESOP2016v3 where
|
||||||
|
-- Explicitly separate Open/Close/Wild from other edges in Br nodes.
|
||||||
|
-- This gives an elegant presentation.
|
||||||
|
|
||||||
|
import Prelude hiding (null, seq)
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
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 :: 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 :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t)
|
||||||
|
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 :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t)
|
||||||
|
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
|
|
@ -0,0 +1,88 @@
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
module Syndicate.Dataspace.Trie.Prefix where
|
||||||
|
-- Alternate representation, where Open has an explicit *arity*
|
||||||
|
-- attached to it, and matching close-parens are implicitly tracked.
|
||||||
|
-- Where ESOP2016-style implementations have "<xyz>", this style has
|
||||||
|
-- "<3xyz".
|
||||||
|
|
||||||
|
import Prelude hiding (null, seq)
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
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 :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t)
|
||||||
|
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 :: Ord t => Trie (Set.Set t) -> Trie (Set.Set t) -> Trie (Set.Set t)
|
||||||
|
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
|
|
@ -0,0 +1,37 @@
|
||||||
|
name: syndicate
|
||||||
|
version: 0.1.0.0
|
||||||
|
synopsis: An Actor-based language with multicast, managed shared state, and grouping.
|
||||||
|
copyright: Copyright © 2016 Tony Garnock-Jones
|
||||||
|
homepage: http://syndicate-lang.org/
|
||||||
|
license: LGPL-3
|
||||||
|
license-file: LICENSE
|
||||||
|
author: Tony Garnock-Jones
|
||||||
|
maintainer: tonyg@leastfixedpoint.com
|
||||||
|
category: Concurrency
|
||||||
|
build-type: Simple
|
||||||
|
cabal-version: >=1.10
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: Syndicate.Dataspace.Trie.ESOP2016
|
||||||
|
, Syndicate.Dataspace.Trie.ESOP2016v2
|
||||||
|
, Syndicate.Dataspace.Trie.ESOP2016v3
|
||||||
|
, Syndicate.Dataspace.Trie.Prefix
|
||||||
|
build-depends: base
|
||||||
|
, containers
|
||||||
|
hs-source-dirs: src
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite syndicate-dataspace-testsuite
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
build-depends: base
|
||||||
|
, containers
|
||||||
|
, QuickCheck
|
||||||
|
, HUnit
|
||||||
|
, Cabal
|
||||||
|
, test-framework
|
||||||
|
, test-framework-hunit
|
||||||
|
, test-framework-quickcheck2
|
||||||
|
, syndicate
|
||||||
|
hs-source-dirs: test
|
||||||
|
default-language: Haskell2010
|
|
@ -0,0 +1,27 @@
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Test.Framework
|
||||||
|
import Test.Framework.Providers.HUnit
|
||||||
|
import Test.Framework.Providers.QuickCheck2
|
||||||
|
|
||||||
|
import Syndicate.Dataspace.Trie.Tests.ESOP2016 as ESOP2016
|
||||||
|
import Syndicate.Dataspace.Trie.Tests.ESOP2016v2 as ESOP2016v2
|
||||||
|
import Syndicate.Dataspace.Trie.Tests.ESOP2016v3 as ESOP2016v3
|
||||||
|
import Syndicate.Dataspace.Trie.Tests.Prefix as Prefix
|
||||||
|
|
||||||
|
testOpts = (mempty :: TestOptions)
|
||||||
|
{ topt_maximum_generated_tests = Just 1000
|
||||||
|
, topt_maximum_unsuitable_generated_tests = Just 10000
|
||||||
|
}
|
||||||
|
runnerOpts = (mempty :: RunnerOptions) { ropt_test_options = Just testOpts }
|
||||||
|
runTests tests = defaultMainWithOpts tests runnerOpts
|
||||||
|
|
||||||
|
main = runTests
|
||||||
|
[ testGroup "ESOP2016" $ hUnitTestToTests ESOP2016.hUnitSuite
|
||||||
|
, testGroup "ESOP2016v2" $ hUnitTestToTests ESOP2016v2.hUnitSuite
|
||||||
|
, testGroup "ESOP2016v3" $ hUnitTestToTests ESOP2016v3.hUnitSuite
|
||||||
|
, testGroup "Prefix" [ testGroup "HUnit tests" $ hUnitTestToTests Prefix.hUnitSuite
|
||||||
|
, testGroup "QuickCheck tests" Prefix.quickCheckSuite
|
||||||
|
]
|
||||||
|
]
|
|
@ -0,0 +1,55 @@
|
||||||
|
module Syndicate.Dataspace.Trie.Tests.ESOP2016 where
|
||||||
|
|
||||||
|
import Prelude hiding (null, seq)
|
||||||
|
import Syndicate.Dataspace.Trie.ESOP2016
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Test.HUnit
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
hUnitSuite = 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 "<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
|
||||||
|
]
|
|
@ -0,0 +1,55 @@
|
||||||
|
module Syndicate.Dataspace.Trie.Tests.ESOP2016v2 where
|
||||||
|
-- Close to the ESOP 2016 implementation of dataspace tries, but takes
|
||||||
|
-- a step toward efficiency by using collapse/update instead of dedup/distinct.
|
||||||
|
|
||||||
|
import Prelude hiding (null, seq)
|
||||||
|
import Syndicate.Dataspace.Trie.ESOP2016v2
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Test.HUnit
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
hUnitSuite = 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
|
||||||
|
]
|
|
@ -0,0 +1,95 @@
|
||||||
|
module Syndicate.Dataspace.Trie.Tests.ESOP2016v3 where
|
||||||
|
-- Explicitly separate Open/Close/Wild from other edges in Br nodes.
|
||||||
|
-- This gives an elegant presentation.
|
||||||
|
|
||||||
|
import Prelude hiding (null, seq)
|
||||||
|
import Syndicate.Dataspace.Trie.ESOP2016v3
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Test.HUnit
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
hUnitSuite = 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]))
|
||||||
|
]
|
|
@ -1,93 +1,22 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
module TreeTrie where
|
module Syndicate.Dataspace.Trie.Tests.Prefix where
|
||||||
|
-- Alternate representation, where Open has an explicit *arity*
|
||||||
|
-- attached to it, and matching close-parens are implicitly tracked.
|
||||||
|
-- Where ESOP2016-style implementations have "<xyz>", this style has
|
||||||
|
-- "<3xyz".
|
||||||
|
|
||||||
-- import Debug.Trace
|
import Prelude hiding (null)
|
||||||
import Prelude hiding (null, seq)
|
import Syndicate.Dataspace.Trie.Prefix
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
|
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
import Test.Framework
|
||||||
|
import Test.Framework.Providers.HUnit
|
||||||
|
import Test.Framework.Providers.QuickCheck2
|
||||||
import Control.Monad
|
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)
|
ok vs = Ok (Set.fromList vs)
|
||||||
|
|
||||||
seqs _ r | null r = r
|
seqs _ r | null r = r
|
||||||
|
@ -96,8 +25,8 @@ 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 ('*' : s) r = Br (Map.empty, seqs s r, Map.empty)
|
||||||
seqs (x : s) r = Br (Map.empty, Mt, Map.singleton x (seqs s r))
|
seqs (x : s) r = Br (Map.empty, Mt, Map.singleton x (seqs s r))
|
||||||
|
|
||||||
simpleTestCases = test [
|
hUnitSuite = test
|
||||||
"seqs simple" ~:
|
[ "seqs simple" ~:
|
||||||
Br (Map.singleton 0 (ok [1]), Mt, Map.empty) ~=? seqs "<0" (ok [1]),
|
Br (Map.singleton 0 (ok [1]), Mt, Map.empty) ~=? seqs "<0" (ok [1]),
|
||||||
"union simple1" ~:
|
"union simple1" ~:
|
||||||
Br (Map.empty, Mt,
|
Br (Map.empty, Mt,
|
||||||
|
@ -198,7 +127,7 @@ simpleTestCases = test [
|
||||||
(intersection
|
(intersection
|
||||||
(union (seqs "*" (ok [3])) (seqs "<2aa" (ok [1])))
|
(union (seqs "*" (ok [3])) (seqs "<2aa" (ok [1])))
|
||||||
(union (seqs "*" (ok [4])) (seqs "<1b" (ok [2]))))
|
(union (seqs "*" (ok [4])) (seqs "<1b" (ok [2]))))
|
||||||
]
|
]
|
||||||
|
|
||||||
---------------------------------------------------------------------------
|
---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -275,10 +204,7 @@ unionBasics = combineBasics union (||)
|
||||||
intersectionBasics = combineBasics intersection (&&)
|
intersectionBasics = combineBasics intersection (&&)
|
||||||
differenceBasics = combineBasics difference (\ x y -> x && not y)
|
differenceBasics = combineBasics difference (\ x y -> x && not y)
|
||||||
|
|
||||||
qCheck name t = do putStrLn name
|
quickCheckSuite = [ testProperty "differenceBasics" differenceBasics
|
||||||
quickCheckWith stdArgs { maxSuccess = 500 } t
|
, testProperty "intersectionBasics" intersectionBasics
|
||||||
|
, testProperty "unionBasics" unionBasics
|
||||||
main = do runTestTT simpleTestCases
|
]
|
||||||
qCheck "differenceBasics" differenceBasics
|
|
||||||
qCheck "intersectionBasics" intersectionBasics
|
|
||||||
qCheck "unionBasics" unionBasics
|
|
130
hs/treetrie1.hs
130
hs/treetrie1.hs
|
@ -1,130 +0,0 @@
|
||||||
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 "<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
170
hs/treetrie3.hs
|
@ -1,170 +0,0 @@
|
||||||
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]))
|
|
||||||
]
|
|
Loading…
Reference in New Issue