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 "L/" Fold Monad])) + (data ["e" error] + (coll [list #+ "list/" Fold Monad])) [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 + (cond (~+ (do list.Monad [[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 + (let [step-bindings (do list.Monad [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]) + 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 [ ] + [(def: #export ( 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))] + [( 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 [ ] + [(def: #export ( 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 ( (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 [ <*> <->] - [(def: ( param subject) - (-> ) - (let [exact (|> subject ( param) (<*> param))] - (|> subject (<-> exact)))) - - (def: #export ( a b) + [(def: #export ( a b) {#.doc "Greatest Common Divisor."} (-> ) (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 @@ -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 ( 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 gen) + (All [a] (-> (/.Eq a) (r.Random a) Test)) + (do r.Monad + [sample gen] + (test "Equality is reflexive." + (:: Eq = 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 map (|>> (n/% max) (n/max min))))) + +(def: bits + (r.Random /.Bits) + (do r.Monad + [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 = 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 = sample (/.not (/.not sample)))) + (test "Negation does not affect the empty bit-set." + (is /.empty (/.not /.empty))) + + (_eq.spec /.Eq ..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