From 8f071917892ac919b91da12c2bf02d5d9b79f81a Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 31 Dec 2017 00:51:30 -0400
Subject: - Added bit-sets.
---
stdlib/source/lux.lux | 13 +++
stdlib/source/lux/control/pipe.lux | 48 +++++-----
stdlib/source/lux/data/bit.lux | 5 +
stdlib/source/lux/data/coll/bits.lux | 165 ++++++++++++++++++++++++++++++++
stdlib/source/lux/math.lux | 8 +-
stdlib/source/lux/math/modular.lux | 13 +--
stdlib/test/test/lux/control/eq.lux | 13 +++
stdlib/test/test/lux/control/pipe.lux | 3 +-
stdlib/test/test/lux/data/coll/bits.lux | 80 ++++++++++++++++
stdlib/test/tests.lux | 3 +-
10 files changed, 309 insertions(+), 42 deletions(-)
create mode 100644 stdlib/source/lux/data/coll/bits.lux
create mode 100644 stdlib/test/test/lux/control/eq.lux
create mode 100644 stdlib/test/test/lux/data/coll/bits.lux
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index e4214a899..51e9af4dc 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -6054,3 +6054,16 @@
_
(fail "Wrong syntax for ^code")))
+
+(def: #export (n/mod param subject)
+ (-> Nat Nat Nat)
+ (let [exact (|> subject (n// param) (n/* param))]
+ (|> subject (n/- exact))))
+
+(def: #export (i/mod param subject)
+ (All [m] (-> Int Int Int))
+ (let [raw (i/% param subject)]
+ (if (i/< 0 raw)
+ (let [shift (if (i/< 0 param) i/- i/+)]
+ (|> raw (shift param)))
+ raw)))
diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux
index a5ba038f5..b70ec8f8a 100644
--- a/stdlib/source/lux/control/pipe.lux
+++ b/stdlib/source/lux/control/pipe.lux
@@ -1,8 +1,9 @@
(.module: {#.doc "Composable extensions to the piping macros (|> and <|) that enhance them with various abilities."}
lux
- (lux (control ["M" monad #+ do Monad]
+ (lux (control [monad #+ do]
["p" parser])
- (data (coll [list #+ Monad<List> "L/" Fold<List> Monad<List>]))
+ (data ["e" error]
+ (coll [list #+ "list/" Fold<List> Monad<List>]))
[macro #+ with-gensyms]
(macro ["s" syntax #+ syntax: Syntax]
[code])
@@ -11,7 +12,7 @@
## [Syntax]
(def: body^
(Syntax (List Code))
- (s.tuple (p.many s.any)))
+ (s.tuple (p.some s.any)))
(syntax: #export (new> [tokens (p.at-least +2 s.any)])
{#.doc (doc "Ignores the piped argument, and begins a new pipe."
@@ -33,12 +34,18 @@
(wrap (list (` (let [(~ binding) (~ prev)]
(~ body))))))
-(syntax: #export (cond> [branches (p.many (p.seq body^ body^))]
- [?else (p.maybe body^)]
- prev)
+(def: _reverse_
+ (Syntax Unit)
+ (function [tokens]
+ (#e.Success [(list.reverse tokens) []])))
+
+(syntax: #export (cond> [_ _reverse_]
+ prev
+ [else body^]
+ [_ _reverse_]
+ [branches (p.many (p.seq body^ body^))])
{#.doc (doc "Branching for pipes."
"Both the tests and the bodies are piped-code, and must be given inside a tuple."
- "If a last else-pipe is not given, the piped-argument will be used instead."
(|> 5
(cond> [i/even?] [(i/* 2)]
[i/odd?] [(i/* 3)]
@@ -46,16 +53,11 @@
(with-gensyms [g!temp]
(wrap (list (` (with-expansions
[(~ g!temp) (~ prev)]
- (cond (~+ (do Monad<List>
+ (cond (~+ (do list.Monad<List>
[[test then] branches]
(list (` (|> (~ g!temp) (~+ test)))
(` (|> (~ g!temp) (~+ then))))))
- (~ (case ?else
- (#.Some else)
- (` (|> (~ g!temp) (~+ else)))
-
- _
- g!temp)))))))))
+ (|> (~ g!temp) (~+ else)))))))))
(syntax: #export (loop> [test body^] [then body^] prev)
{#.doc (doc "Loops for pipes."
@@ -80,13 +82,13 @@
(with-gensyms [g!temp]
(case (list.reverse steps)
(^ (list& last-step prev-steps))
- (let [step-bindings (do Monad<List>
+ (let [step-bindings (do list.Monad<List>
[step (list.reverse prev-steps)]
(list g!temp (` (|> (~ g!temp) (~+ step)))))]
- (wrap (list (` (do (~ monad)
- [(~ g!temp) (~ prev)
- (~+ step-bindings)]
- (|> (~ g!temp) (~+ last-step)))))))
+ (wrap (list (` ((~! do) (~ monad)
+ [(~ g!temp) (~ prev)
+ (~+ step-bindings)]
+ (|> (~ g!temp) (~+ last-step)))))))
_
(wrap (list prev)))))
@@ -112,8 +114,8 @@
"Will become: [50 2 \"5\"]")}
(with-gensyms [g!temp]
(wrap (list (` (let [(~ g!temp) (~ prev)]
- [(~+ (L/map (function [body] (` (|> (~ g!temp) (~+ body))))
- paths))]))))))
+ [(~+ (list/map (function [body] (` (|> (~ g!temp) (~+ body))))
+ paths))]))))))
(syntax: #export (case> [branches (p.many (p.seq s.any s.any))] prev)
{#.doc (doc "Pattern-matching for pipes."
@@ -131,5 +133,5 @@
9 "nine"
_ "???")))}
(wrap (list (` (case (~ prev)
- (~+ (L/join (L/map (function [[pattern body]] (list pattern body))
- branches))))))))
+ (~+ (list/join (list/map (function [[pattern body]] (list pattern body))
+ branches))))))))
diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux
index 4f9474a90..65d1bef84 100644
--- a/stdlib/source/lux/data/bit.lux
+++ b/stdlib/source/lux/data/bit.lux
@@ -59,3 +59,8 @@
[rotate-left shift-left shift-right]
[rotate-right shift-right shift-left]
)
+
+(def: #export (region-mask size offset)
+ (-> Nat Nat Nat)
+ (let [pattern (|> +1 (shift-left size) n/dec)]
+ (shift-left offset pattern)))
diff --git a/stdlib/source/lux/data/coll/bits.lux b/stdlib/source/lux/data/coll/bits.lux
new file mode 100644
index 000000000..e7a407b1c
--- /dev/null
+++ b/stdlib/source/lux/data/coll/bits.lux
@@ -0,0 +1,165 @@
+(.module:
+ [lux #- not and or]
+ (lux (control [eq #+ Eq]
+ pipe)
+ (data [maybe]
+ [bit]
+ (coll [array "array/" Fold<Array>])
+ text/format)))
+
+(type: #export Chunk Nat)
+
+(def: #export chunk-size bit.width)
+
+(type: #export Bits
+ (Array Chunk))
+
+(def: empty-chunk Chunk +0)
+
+(def: (n//% param subject)
+ (-> Nat Nat [Nat Nat])
+ [(n// param subject)
+ (n/% param subject)])
+
+(def: #export empty
+ Bits
+ (array.new +0))
+
+(def: #export (size bits)
+ (-> Bits Nat)
+ (array/fold (function [chunk total]
+ (n/+ total (bit.count chunk)))
+ +0
+ bits))
+
+(def: #export (capacity bits)
+ (-> Bits Nat)
+ (|> bits array.size (n/* chunk-size)))
+
+(def: #export (empty? bits)
+ (-> Bits Bool)
+ (n/= +0 (size bits)))
+
+(def: #export (get index bits)
+ (-> Nat Bits Bool)
+ (let [[chunk-index bit-index] (n//% chunk-size index)]
+ (.and (n/< (array.size bits) chunk-index)
+ (|> (array.read chunk-index bits)
+ (maybe.default empty-chunk)
+ (bit.set? bit-index)))))
+
+(def: (chunk idx bits)
+ (-> Nat Bits Chunk)
+ (if (n/< (array.size bits) idx)
+ (|> bits (array.read idx) (maybe.default empty-chunk))
+ empty-chunk))
+
+(do-template [<name> <op>]
+ [(def: #export (<name> index input)
+ (-> Nat Bits Bits)
+ (let [[chunk-index bit-index] (n//% chunk-size index)]
+ (loop [size|output (n/max (n/inc chunk-index)
+ (array.size input))
+ output ..empty]
+ (let [idx|output (n/dec size|output)]
+ (if (n/> +0 size|output)
+ (case (|> (chunk idx|output input)
+ (cond> [(new> (n/= chunk-index idx|output))]
+ [(<op> bit-index)]
+
+ ## else
+ []))
+ +0
+ ## TODO: Remove 'no-op' once new-luxc is the official compiler.
+ (let [no-op (recur (n/dec size|output) output)]
+ no-op)
+
+ chunk
+ (|> (if (is ..empty output)
+ (: Bits (array.new size|output))
+ output)
+ (array.write idx|output chunk)
+ (recur (n/dec size|output))))
+ output)))))]
+
+ [set bit.set]
+ [clear bit.clear]
+ [flip bit.flip]
+ )
+
+(def: #export (intersects? reference sample)
+ (-> Bits Bits Bool)
+ (let [chunks (n/min (array.size reference)
+ (array.size sample))]
+ (loop [idx +0]
+ (if (n/< chunks idx)
+ (.or (|> (chunk idx sample)
+ (bit.and (chunk idx reference))
+ (n/= empty-chunk)
+ .not)
+ (recur (n/inc idx)))
+ false))))
+
+(def: #export (not input)
+ (-> Bits Bits)
+ (case (array.size input)
+ +0
+ ..empty
+
+ size|output
+ (loop [size|output size|output
+ output ..empty]
+ (let [idx (n/dec size|output)]
+ (case (bit.not (chunk idx input))
+ +0
+ (recur (n/dec size|output) output)
+
+ chunk
+ (if (n/> +0 size|output)
+ (|> (if (is ..empty output)
+ (: Bits (array.new size|output))
+ output)
+ (array.write idx chunk)
+ (recur (n/dec size|output)))
+ output))))))
+
+(do-template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (-> Bits Bits Bits)
+ (case (n/max (array.size param)
+ (array.size subject))
+ +0
+ ..empty
+
+ size|output
+ (loop [size|output size|output
+ output ..empty]
+ (let [idx (n/dec size|output)]
+ (if (n/> +0 size|output)
+ (case (<op> (chunk idx param) (chunk idx subject))
+ +0
+ (recur (n/dec size|output) output)
+
+ chunk
+ (|> (if (is ..empty output)
+ (: Bits (array.new size|output))
+ output)
+ (array.write idx chunk)
+ (recur (n/dec size|output))))
+ output)))))]
+
+ [and bit.and]
+ [or bit.or]
+ [xor bit.xor]
+ )
+
+(struct: #export _ (Eq Bits)
+ (def: (= reference sample)
+ (let [size|= (n/max (array.size reference)
+ (array.size sample))]
+ (loop [idx +0]
+ (if (n/< size|= idx)
+ (.and (n/= (chunk idx reference)
+ (chunk idx sample))
+ (recur (n/inc idx)))
+ true)))))
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
index 1e18af14e..d6001b3a6 100644
--- a/stdlib/source/lux/math.lux
+++ b/stdlib/source/lux/math.lux
@@ -58,6 +58,7 @@
)
(def: #export (log' base input)
+ (-> Frac Frac Frac)
(f// (log base)
(log input)))
@@ -75,12 +76,7 @@
(pow 2.0 catB))))
(do-template [<type> <mod> <gcd> <lcm> <zero> <*> </> <->]
- [(def: (<mod> param subject)
- (-> <type> <type> <type>)
- (let [exact (|> subject (</> param) (<*> param))]
- (|> subject (<-> exact))))
-
- (def: #export (<gcd> a b)
+ [(def: #export (<gcd> a b)
{#.doc "Greatest Common Divisor."}
(-> <type> <type> <type>)
(case b
diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux
index 7618a3a55..7fadcd8b3 100644
--- a/stdlib/source/lux/math/modular.lux
+++ b/stdlib/source/lux/math/modular.lux
@@ -49,15 +49,6 @@
(#e.Error error)
(p.fail error)))
-(def: (i/mod (^|> modulus [to-int])
- value)
- (All [m] (-> (Modulus m) Int Int))
- (let [raw (i/% modulus value)]
- (if (i/< 0 raw)
- (let [shift (if (i/< 0 modulus) i/- i/+)]
- (|> raw (shift modulus)))
- raw)))
-
(def: intL
(Lexer Int)
(p.codec number.Codec<Text,Int>
@@ -73,7 +64,7 @@
(def: #export (mod modulus)
(All [m] (-> (Modulus m) (-> Int (Mod m))))
(function [value]
- (@abstraction {#remainder (i/mod modulus value)
+ (@abstraction {#remainder (i/mod (to-int modulus) value)
#modulus modulus})))
(def: #export (un-mod modular)
@@ -137,7 +128,7 @@
[subject _] (@representation subject)]
(@abstraction {#remainder (|> subject
(<op> param)
- (i/mod modulus))
+ (i/mod (to-int modulus)))
#modulus modulus})))]
[m/+ i/+]
diff --git a/stdlib/test/test/lux/control/eq.lux b/stdlib/test/test/lux/control/eq.lux
new file mode 100644
index 000000000..9d33d4693
--- /dev/null
+++ b/stdlib/test/test/lux/control/eq.lux
@@ -0,0 +1,13 @@
+(.module:
+ lux
+ (lux (control ["/" eq]
+ [monad #+ do])
+ (math ["r" random])
+ test))
+
+(def: #export (spec Eq<a> gen<a>)
+ (All [a] (-> (/.Eq a) (r.Random a) Test))
+ (do r.Monad<Random>
+ [sample gen<a>]
+ (test "Equality is reflexive."
+ (:: Eq<a> = sample sample))))
diff --git a/stdlib/test/test/lux/control/pipe.lux b/stdlib/test/test/lux/control/pipe.lux
index 545640030..79e920468 100644
--- a/stdlib/test/test/lux/control/pipe.lux
+++ b/stdlib/test/test/lux/control/pipe.lux
@@ -33,7 +33,8 @@
(i/= 15))
(|> 4
(cond> [i/even?] [(i/* 2)]
- [i/odd?] [(i/* 3)])
+ [i/odd?] [(i/* 3)]
+ [])
(i/= 8))
(|> 5
(cond> [i/even?] [(i/* 2)]
diff --git a/stdlib/test/test/lux/data/coll/bits.lux b/stdlib/test/test/lux/data/coll/bits.lux
new file mode 100644
index 000000000..ccf0ff63d
--- /dev/null
+++ b/stdlib/test/test/lux/data/coll/bits.lux
@@ -0,0 +1,80 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ [predicate])
+ (data (coll ["/" bits]))
+ ["r" math/random])
+ lux/test
+ (test (lux (control ["_." eq]))))
+
+(def: (size min max)
+ (-> Nat Nat (r.Random Nat))
+ (|> r.nat
+ (:: r.Monad<Random> map (|>> (n/% max) (n/max min)))))
+
+(def: bits
+ (r.Random /.Bits)
+ (do r.Monad<Random>
+ [size (size +1 +1_000)
+ idx (|> r.nat (:: @ map (n/% size)))]
+ (wrap (|> /.empty (/.set idx)))))
+
+(context: "Bits."
+ (<| (times +100)
+ (do @
+ [size (size +1 +1_000)
+ idx (|> r.nat (:: @ map (n/% size)))
+ sample bits]
+ ($_ seq
+ (test "Can set individual bits."
+ (and (|> /.empty (/.get idx) not)
+ (|> /.empty (/.set idx) (/.get idx))))
+ (test "Can clear individual bits."
+ (|> /.empty (/.set idx) (/.clear idx) (/.get idx) not))
+ (test "Can flip individual bits."
+ (and (|> /.empty (/.flip idx) (/.get idx))
+ (|> /.empty (/.flip idx) (/.flip idx) (/.get idx) not)))
+
+ (test "Bits (only) grow when (and as much as) necessary."
+ (and (n/= +0 (/.capacity /.empty))
+ (|> /.empty (/.set idx) /.capacity
+ (n/- idx)
+ (predicate.union (n/>= +0)
+ (n/< /.chunk-size)))))
+ (test "Bits (must) shrink when (and as much as) possible."
+ (let [grown (/.flip idx /.empty)]
+ (and (n/> +0 (/.capacity grown))
+ (is /.empty (/.flip idx grown)))))
+
+ (test "Intersection can be detected when there are set bits in common."
+ (and (not (/.intersects? /.empty
+ /.empty))
+ (/.intersects? (/.set idx /.empty)
+ (/.set idx /.empty))
+ (not (/.intersects? (/.set (n/inc idx) /.empty)
+ (/.set idx /.empty)))))
+ (test "Cannot intersect with one's opposite."
+ (not (/.intersects? sample (/.not sample))))
+
+ (test "'and' with oneself changes nothing"
+ (:: /.Eq<Bits> = sample (/.and sample sample)))
+ (test "'and' with one's opposite yields the empty bit-set."
+ (is /.empty (/.and sample (/.not sample))))
+
+ (test "'or' with one's opposite fully saturates a bit-set."
+ (n/= (/.size (/.or sample (/.not sample)))
+ (/.capacity sample)))
+
+ (test "'xor' with oneself yields the empty bit-set."
+ (is /.empty (/.xor sample sample)))
+ (test "'xor' with one's opposite fully saturates a bit-set."
+ (n/= (/.size (/.xor sample (/.not sample)))
+ (/.capacity sample)))
+
+ (test "Double negation results in original bit-set."
+ (:: /.Eq<Bits> = sample (/.not (/.not sample))))
+ (test "Negation does not affect the empty bit-set."
+ (is /.empty (/.not /.empty)))
+
+ (_eq.spec /.Eq<Bits> ..bits)
+ ))))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index e234b6b48..ecce3d56b 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -39,6 +39,7 @@
(format ["_." json]
["_." xml])
(coll ["_." array]
+ ["_." bits]
["_." dict]
["_." list]
["_." queue]
@@ -66,7 +67,7 @@
["poly_." functor]))
(type ["_." implicit]
["_." object])
- (lang ["lang_." syntax]
+ (lang ["lang/_." syntax]
["_." type]
(type ["_." check]))
(world ["_." blob]
--
cgit v1.2.3