- Added bit-sets.

10 files changed, 309 insertions, 42 deletions

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]