diff options
Diffstat (limited to '')
19 files changed, 484 insertions, 533 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 2add33e57..ebdf57efb 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2464,7 +2464,7 @@ high-bits ("lux i64 +" top)))) -(def:''' least-significant-bit-mask (list) Nat 1) +(def:''' least-significant-bit-mask (list) ($' I64 Any) 1) (def:''' (without-trailing-zeroes count remaining) (list) @@ -2502,8 +2502,8 @@ (text$ "Rev(olution) remainder.")]) (-> Rev Rev Rev) ("lux coerce" Rev - (n/% ("lux coerce" Nat subject) - ("lux coerce" Nat param)))) + (n/% ("lux coerce" Nat param) + ("lux coerce" Nat subject)))) (def:''' #export (r/scale param subject) (list [(tag$ ["lux" "doc"]) diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux index dff272a91..16ad5b51a 100644 --- a/stdlib/source/lux/data/collection/row.lux +++ b/stdlib/source/lux/data/collection/row.lux @@ -15,13 +15,12 @@ [number ["." i64]] [collection - ["." list ("#;." fold functor monoid)] - ["." array (#+ Array) ("#;." functor fold)]]] + ["." list ("#@." fold functor monoid)] + ["." array (#+ Array) ("#@." functor fold)]]] [macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax: Syntax)]]]) -## [Utils] (type: (Node a) (#Base (Array a)) (#Hierarchy (Array (Node a)))) @@ -66,11 +65,11 @@ (All [a] (-> Any (Hierarchy a))) (array.new full-node-size)) -(def: (tail-off vec-size) +(def: (tail-off row-size) (-> Nat Nat) - (if (n/< full-node-size vec-size) + (if (n/< full-node-size row-size) 0 - (|> (dec vec-size) + (|> (dec row-size) (i64.logic-right-shift branching-exponent) (i64.left-shift branching-exponent)))) @@ -169,17 +168,15 @@ (|> hierarchy array.to-list list.reverse - (list;fold (function (_ sub acc) (list;compose (to-list' sub) acc)) + (list@fold (function (_ sub acc) (list@compose (to-list' sub) acc)) #.Nil)))) -## [Types] (type: #export (Row a) {#level Level #size Nat #root (Hierarchy a) #tail (Base a)}) -## [Exports] (def: #export empty Row {#level (level-up root-level) @@ -191,48 +188,48 @@ (All [a] (-> (Row a) Nat)) (get@ #size row)) -(def: #export (add val vec) +(def: #export (add val row) (All [a] (-> a (Row a) (Row a))) ## Check if there is room in the tail. - (let [vec-size (get@ #size vec)] - (if (|> vec-size (n/- (tail-off vec-size)) (n/< full-node-size)) + (let [row-size (get@ #size row)] + (if (|> row-size (n/- (tail-off row-size)) (n/< full-node-size)) ## If so, append to it. - (|> vec + (|> row (update@ #size inc) (update@ #tail (expand-tail val))) ## Otherwise, push tail into the tree ## -------------------------------------------------------- ## Will the root experience an overflow with this addition? - (|> (if (n/> (i64.left-shift (get@ #level vec) 1) - (i64.logic-right-shift branching-exponent vec-size)) + (|> (if (n/> (i64.left-shift (get@ #level row) 1) + (i64.logic-right-shift branching-exponent row-size)) ## If so, a brand-new root must be established, that is ## 1-level taller. - (|> vec + (|> row (set@ #root (|> (: (Hierarchy ($ 0)) (new-hierarchy [])) ## TODO: Remove version above once new-luxc becomes the standard compiler. ## (new-hierarchy []) - (array.write 0 (#Hierarchy (get@ #root vec))) - (array.write 1 (new-path (get@ #level vec) (get@ #tail vec))))) + (array.write 0 (#Hierarchy (get@ #root row))) + (array.write 1 (new-path (get@ #level row) (get@ #tail row))))) (update@ #level level-up)) ## Otherwise, just push the current tail onto the root. - (|> vec - (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec))))) + (|> row + (update@ #root (push-tail row-size (get@ #level row) (get@ #tail row))))) ## Finally, update the size of the row and grow a new ## tail with the new element as it's sole member. (update@ #size inc) (set@ #tail (new-tail val))) ))) -(def: (base-for idx vec) +(def: (base-for idx row) (All [a] (-> Index (Row a) (Maybe (Base a)))) - (let [vec-size (get@ #size vec)] + (let [row-size (get@ #size row)] (if (and (n/>= 0 idx) - (n/< vec-size idx)) - (if (n/>= (tail-off vec-size) idx) - (#.Some (get@ #tail vec)) - (loop [level (get@ #level vec) - hierarchy (get@ #root vec)] + (n/< row-size idx)) + (if (n/>= (tail-off row-size) idx) + (#.Some (get@ #tail row)) + (loop [level (get@ #level row) + hierarchy (get@ #root row)] (case [(n/> branching-exponent level) (array.read (branch-idx (i64.logic-right-shift level idx)) hierarchy)] [#1 (#.Some (#Hierarchy sub))] @@ -248,61 +245,61 @@ (error! "Incorrect row structure.")))) #.None))) -(def: #export (nth idx vec) +(def: #export (nth idx row) (All [a] (-> Nat (Row a) (Maybe a))) (do maybe.monad - [base (base-for idx vec)] + [base (base-for idx row)] (array.read (branch-idx idx) base))) -(def: #export (put idx val vec) +(def: #export (put idx val row) (All [a] (-> Nat a (Row a) (Row a))) - (let [vec-size (get@ #size vec)] + (let [row-size (get@ #size row)] (if (and (n/>= 0 idx) - (n/< vec-size idx)) - (if (n/>= (tail-off vec-size) idx) - (|> vec + (n/< row-size idx)) + (if (n/>= (tail-off row-size) idx) + (|> row ## (update@ #tail (|>> array.clone (array.write (branch-idx idx) val))) ## TODO: Remove once new-luxc becomes the standard compiler. (update@ #tail (: (-> (Base ($ 0)) (Base ($ 0))) (|>> array.clone (array.write (branch-idx idx) val)))) ) - (|> vec - (update@ #root (put' (get@ #level vec) idx val)))) - vec))) + (|> row + (update@ #root (put' (get@ #level row) idx val)))) + row))) -(def: #export (update idx f vec) +(def: #export (update idx f row) (All [a] (-> Nat (-> a a) (Row a) (Row a))) - (case (nth idx vec) + (case (nth idx row) (#.Some val) - (put idx (f val) vec) + (put idx (f val) row) #.None - vec)) + row)) -(def: #export (pop vec) +(def: #export (pop row) (All [a] (-> (Row a) (Row a))) - (case (get@ #size vec) + (case (get@ #size row) 0 empty 1 empty - vec-size - (if (|> vec-size (n/- (tail-off vec-size)) (n/> 1)) - (let [old-tail (get@ #tail vec) + row-size + (if (|> row-size (n/- (tail-off row-size)) (n/> 1)) + (let [old-tail (get@ #tail row) new-tail-size (dec (array.size old-tail))] - (|> vec + (|> row (update@ #size dec) (set@ #tail (|> (array.new new-tail-size) (array.copy new-tail-size 0 old-tail 0))))) (maybe.assume (do maybe.monad - [new-tail (base-for (n/- 2 vec-size) vec) - #let [[level' root'] (let [init-level (get@ #level vec)] + [new-tail (base-for (n/- 2 row-size) row) + #let [[level' root'] (let [init-level (get@ #level row)] (loop [level init-level root (maybe.default (new-hierarchy []) - (pop-tail vec-size init-level (get@ #root vec)))] + (pop-tail row-size init-level (get@ #root row)))] (if (n/> branching-exponent level) (case [(array.read 1 root) (array.read 0 root)] [#.None (#.Some (#Hierarchy sub-node))] @@ -314,37 +311,35 @@ _ [level root]) [level root])))]] - (wrap (|> vec + (wrap (|> row (update@ #size dec) (set@ #level level') (set@ #root root') (set@ #tail new-tail)))))) )) -(def: #export (to-list vec) +(def: #export (to-list row) (All [a] (-> (Row a) (List a))) - (list;compose (to-list' (#Hierarchy (get@ #root vec))) - (to-list' (#Base (get@ #tail vec))))) + (list@compose (to-list' (#Hierarchy (get@ #root row))) + (to-list' (#Base (get@ #tail row))))) (def: #export from-list (All [a] (-> (List a) (Row a))) - (list;fold ..add ..empty)) + (list@fold ..add ..empty)) -(def: #export (member? a/Equivalence vec val) +(def: #export (member? a/Equivalence row val) (All [a] (-> (Equivalence a) (Row a) a Bit)) - (list.member? a/Equivalence (to-list vec) val)) + (list.member? a/Equivalence (to-list row) val)) (def: #export empty? (All [a] (-> (Row a) Bit)) (|>> (get@ #size) (n/= 0))) -## [Syntax] (syntax: #export (row {elems (p.some s.any)}) {#.doc (doc "Row literals." (row +10 +20 +30 +40))} (wrap (list (` (from-list (list (~+ elems))))))) -## [Structures] (structure: #export (node-equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Node a)))) (def: (= v1 v2) (case [v1 v2] @@ -370,10 +365,10 @@ (def: (fold f init xs) (case xs (#Base base) - (array;fold f init base) + (array@fold f init base) (#Hierarchy hierarchy) - (array;fold (function (_ node init') (fold f init' node)) + (array@fold (function (_ node init') (fold f init' node)) init hierarchy)))) @@ -390,23 +385,23 @@ (def: identity ..empty) (def: (compose xs ys) - (list;fold add xs (..to-list ys)))) + (list@fold add xs (..to-list ys)))) (structure: node-functor (Functor Node) (def: (map f xs) (case xs (#Base base) - (#Base (array;map f base)) + (#Base (array@map f base)) (#Hierarchy hierarchy) - (#Hierarchy (array;map (map f) hierarchy))))) + (#Hierarchy (array@map (map f) hierarchy))))) (structure: #export functor (Functor Row) (def: (map f xs) {#level (get@ #level xs) #size (get@ #size xs) - #root (|> xs (get@ #root) (array;map (:: node-functor map f))) - #tail (|> xs (get@ #tail) (array;map f))})) + #root (|> xs (get@ #root) (array@map (:: node-functor map f))) + #tail (|> xs (get@ #tail) (array@map f))})) (structure: #export apply (Apply Row) (def: &functor ..functor) @@ -429,13 +424,9 @@ (^open ".") ..monoid] (fold (function (_ post pre) (compose pre post)) identity)))) -## TODO: This definition of 'reverse' shouldn't work correctly. -## Investigate if/why it does. (def: #export reverse (All [a] (-> (Row a) (Row a))) - (let [(^open ".") ..fold - (^open ".") ..monoid] - (fold add identity))) + (|>> ..to-list list.reverse (list@fold add ..empty))) (do-template [<name> <array> <init> <op>] [(def: #export <name> diff --git a/stdlib/source/lux/data/number/frac.lux b/stdlib/source/lux/data/number/frac.lux index d67d582f6..02f7b4d88 100644 --- a/stdlib/source/lux/data/number/frac.lux +++ b/stdlib/source/lux/data/number/frac.lux @@ -3,8 +3,6 @@ [control [hash (#+ Hash)] [number (#+ Number)] - [enum (#+ Enum)] - [interval (#+ Interval)] [monoid (#+ Monoid)] [equivalence (#+ Equivalence)] ["." order (#+ Order)] @@ -29,16 +27,6 @@ (def: > f/>) (def: >= f/>=)) -(structure: #export enum (Enum Frac) - (def: &order ..order) - (def: succ (f/+ ("lux frac smallest"))) - (def: pred (f/- ("lux frac smallest")))) - -(structure: #export interval (Interval Frac) - (def: &enum ..enum) - (def: top ("lux frac max")) - (def: bottom ("lux frac min"))) - (structure: #export number (Number Frac) (def: + f/+) (def: - f/-) @@ -64,8 +52,8 @@ [addition f/+ +0.0] [multiplication f/* +1.0] - [maximum f/max (:: ..interval bottom)] - [minimum f/min (:: ..interval top)] + [maximum f/max ("lux frac min")] + [minimum f/min ("lux frac max")] ) (do-template [<name> <numerator> <doc>] diff --git a/stdlib/source/lux/data/number/nat.lux b/stdlib/source/lux/data/number/nat.lux index 8126bc0c3..70f8df0bd 100644 --- a/stdlib/source/lux/data/number/nat.lux +++ b/stdlib/source/lux/data/number/nat.lux @@ -177,10 +177,12 @@ (loop [input value output ""] (let [digit (maybe.assume (<to-character> (n/% <base> input))) - output' ("lux text concat" digit output) - input' (n// <base> input)] - (if (n/= 0 input') + output' ("lux text concat" digit output)] + (case (n// <base> input) + 0 output' + + input' (recur input' output'))))) (def: (decode repr) @@ -201,7 +203,7 @@ [binary 2 binary-character binary-value "Invalid binary syntax for Nat: "] [octal 8 octal-character octal-value "Invalid octal syntax for Nat: "] - [decimal 10 decimal-character decimal-value "Invalid syntax for Nat: "] + [decimal 10 decimal-character decimal-value "Invalid decimal syntax for Nat: "] [hex 16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "] ) diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux index 21176e998..9c7baaab8 100644 --- a/stdlib/source/lux/data/number/ratio.lux +++ b/stdlib/source/lux/data/number/ratio.lux @@ -3,6 +3,7 @@ [control [equivalence (#+ Equivalence)] [order (#+ Order)] + [monoid (#+ Monoid)] number codec monad @@ -12,9 +13,8 @@ ["." product] ["." maybe] [number - ["." nat ("#;." decimal)]] - ["." text ("#;." monoid) - format]] + ["." nat ("#@." decimal)]] + ["." text ("#@." monoid)]] ["." function] ["." math] ["." macro @@ -25,6 +25,13 @@ {#numerator Nat #denominator Nat}) +(def: (equalize parameter subject) + (-> Ratio Ratio [Nat Nat]) + [(n/* (get@ #denominator subject) + (get@ #numerator parameter)) + (n/* (get@ #denominator parameter) + (get@ #numerator subject))]) + (def: (normalize (^slots [#numerator #denominator])) (-> Ratio Ratio) (let [common (math.n/gcd numerator denominator)] @@ -32,21 +39,19 @@ #denominator (n// common denominator)})) (structure: #export equivalence (Equivalence Ratio) - (def: (= param input) - (and (n/= (get@ #numerator param) - (get@ #numerator input)) - (n/= (get@ #denominator param) - (get@ #denominator input))))) + (def: (= parameter subject) + (and (n/= (get@ #numerator parameter) + (get@ #numerator subject)) + (n/= (get@ #denominator parameter) + (get@ #denominator subject))))) (`` (structure: #export order (Order Ratio) (def: &equivalence ..equivalence) (~~ (do-template [<name> <op>] - [(def: (<name> param input) - (and (<op> (n/* (get@ #denominator input) - (get@ #numerator param)) - (n/* (get@ #denominator param) - (get@ #numerator input)))))] + [(def: (<name> parameter subject) + (let [[parameter' subject'] (..equalize parameter subject)] + (<op> parameter' subject')))] [< n/<] [<= n/<=] @@ -66,46 +71,38 @@ [max >] ) -(def: (- param input) - (normalize [(n/- (n/* (get@ #denominator input) - (get@ #numerator param)) - (n/* (get@ #denominator param) - (get@ #numerator input))) - (n/* (get@ #denominator param) - (get@ #denominator input))])) +(def: (- parameter subject) + (let [[parameter' subject'] (..equalize parameter subject)] + (normalize [(n/- parameter' subject') + (n/* (get@ #denominator parameter) + (get@ #denominator subject))]))) (structure: #export number (Number Ratio) - (def: (+ param input) - (normalize [(n/+ (n/* (get@ #denominator input) - (get@ #numerator param)) - (n/* (get@ #denominator param) - (get@ #numerator input))) - (n/* (get@ #denominator param) - (get@ #denominator input))])) + (def: (+ parameter subject) + (let [[parameter' subject'] (..equalize parameter subject)] + (normalize [(n/+ parameter' subject') + (n/* (get@ #denominator parameter) + (get@ #denominator subject))]))) (def: - ..-) - (def: (* param input) - (normalize [(n/* (get@ #numerator param) - (get@ #numerator input)) - (n/* (get@ #denominator param) - (get@ #denominator input))])) - - (def: (/ param input) - (normalize [(n/* (get@ #denominator param) - (get@ #numerator input)) - (n/* (get@ #numerator param) - (get@ #denominator input))])) - - (def: (% param input) - (let [quot (n// (n/* (get@ #denominator input) - (get@ #numerator param)) - (n/* (get@ #denominator param) - (get@ #numerator input)))] - (..- (update@ #numerator (n/* quot) param) - input))) + (def: (* parameter subject) + (normalize [(n/* (get@ #numerator parameter) + (get@ #numerator subject)) + (n/* (get@ #denominator parameter) + (get@ #denominator subject))])) + + (def: (/ parameter subject) + (let [[parameter' subject'] (..equalize parameter subject)] + (normalize [subject' parameter']))) + + (def: (% parameter subject) + (let [[parameter' subject'] (..equalize parameter subject) + quot (n// parameter' subject')] + (..- (update@ #numerator (n/* quot) parameter) + subject))) (def: (negate (^slots [#numerator #denominator])) {#numerator denominator @@ -120,31 +117,39 @@ (def: separator Text ":") -(def: part-encode - (-> Nat Text) - (|>> nat;encode (text.split 1) maybe.assume product.right)) - (structure: #export codec (Codec Text Ratio) (def: (encode (^slots [#numerator #denominator])) - ($_ text;compose (part-encode numerator) separator (part-encode denominator))) + ($_ text@compose (nat@encode numerator) separator (nat@encode denominator))) (def: (decode input) (case (text.split-with separator input) (#.Some [num denom]) (do error.monad - [numerator (nat;decode num) - denominator (nat;decode denom)] + [numerator (nat@decode num) + denominator (nat@decode denom)] (wrap (normalize {#numerator numerator #denominator denominator}))) #.None - (#.Left (text;compose "Invalid syntax for ratio: " input))))) + (#.Left (text@compose "Invalid syntax for ratio: " input))))) (syntax: #export (ratio numerator {?denominator (p.maybe s.any)}) {#.doc (doc "Rational literals." (ratio numerator denominator) "The denominator can be omitted if it's 1." (ratio numerator))} - (wrap (list (` ((~! normalize) {#..numerator (~ numerator) - #..denominator (~ (maybe.default (' 1) - ?denominator))}))))) + (wrap (list (` ((~! ..normalize) {#..numerator (~ numerator) + #..denominator (~ (maybe.default (' 1) + ?denominator))}))))) + +(do-template [<identity> <compose> <name>] + [(structure: #export <name> + (Monoid Ratio) + + (def: identity (..ratio <identity>)) + (def: compose (:: ..number <compose>)) + )] + + [0 + addition] + [1 * multiplication] + ) diff --git a/stdlib/source/lux/data/number/rev.lux b/stdlib/source/lux/data/number/rev.lux index 798844ba7..fcd2e223c 100644 --- a/stdlib/source/lux/data/number/rev.lux +++ b/stdlib/source/lux/data/number/rev.lux @@ -40,37 +40,25 @@ (def: top (.rev -1)) (def: bottom (.rev 0))) -(structure: #export number (Number Rev) - (def: + r/+) - (def: - r/-) - (def: * r/*) - (def: / r//) - (def: % r/%) - (def: (negate x) (r/- x (:coerce Rev -1))) - (def: abs function.identity) - (def: (signum x) - (:coerce Rev -1))) - (do-template [<name> <compose> <identity>] [(structure: #export <name> (Monoid Rev) - (def: identity <identity>) + (def: identity (:: interval <identity>)) (def: compose <compose>))] - [addition r/+ (:: interval bottom)] - [multiplication r/* (:: interval top)] - [maximum r/max (:: interval bottom)] - [minimum r/min (:: interval top)] + [addition r/+ bottom] + [maximum r/max bottom] + [minimum r/min top] ) (def: (de-prefix input) (-> Text Text) ("lux text clip" input 1 ("lux text size" input))) -(do-template [<struct> <nat> <char-bit-size> <error>] +(do-template [<struct> <codec> <char-bit-size> <error>] [(with-expansions [<error-output> (as-is (#error.Failure ("lux text concat" <error> repr)))] (structure: #export <struct> (Codec Text Rev) (def: (encode value) - (let [raw-output (de-prefix (:: <nat> encode (:coerce Nat value))) + (let [raw-output (:: <codec> encode (:coerce Nat value)) max-num-chars (n// <char-bit-size> 64) raw-size ("lux text size" raw-output) zero-padding (loop [zeroes-left (n/- raw-size max-num-chars) @@ -78,16 +66,17 @@ (if (n/= 0 zeroes-left) output (recur (dec zeroes-left) - ("lux text concat" "0" output)))) - padded-output ("lux text concat" zero-padding raw-output)] - ("lux text concat" "." padded-output))) + ("lux text concat" "0" output))))] + (|> raw-output + ("lux text concat" zero-padding) + ("lux text concat" ".")))) (def: (decode repr) (let [repr-size ("lux text size" repr)] - (if (n/>= 2 repr-size) + (if (n/> 1 repr-size) (case ("lux text char" repr 0) (^ (char ".")) - (case (:: <nat> decode (de-prefix repr)) + (case (:: <codec> decode (de-prefix repr)) (#error.Success output) (#error.Success (:coerce Rev output)) @@ -196,7 +185,7 @@ (loop [idx 0 output (make-digits [])] (if (n/< length idx) - (case ("lux text index" "+0123456789" ("lux text clip" input idx (inc idx)) 0) + (case ("lux text index" "0123456789" ("lux text clip" input idx (inc idx)) 0) #.None #.None @@ -239,10 +228,12 @@ (structure: #export decimal (Codec Text Rev) (def: (encode input) - (let [input (:coerce Nat input) - last-idx (dec //i64.width)] - (if (n/= 0 input) - ".0" + (case (:coerce Nat input) + 0 + ".0" + + input + (let [last-idx (dec //i64.width)] (loop [idx last-idx digits (make-digits [])] (if (i/>= +0 (.int idx)) @@ -257,16 +248,16 @@ ))))) (def: (decode input) - (let [length ("lux text size" input) - dotted? (case ("lux text index" input "." 0) + (let [dotted? (case ("lux text index" input "." 0) (#.Some 0) #1 _ - #0)] - (if (and dotted? - (n/<= (inc //i64.width) length)) - (case (text-to-digits ("lux text clip" input 1 length)) + #0) + within-limits? (n/<= (inc //i64.width) + ("lux text size" input))] + (if (and dotted? within-limits?) + (case (text-to-digits (de-prefix input)) (#.Some digits) (loop [digits digits idx 0 diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index f6a53358d..b96606cdc 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -10,7 +10,8 @@ ["." nat] ["." int] ["." rev] - ["." frac]] + ["." frac] + ["." ratio]] ["." text] [format ["." xml] @@ -49,6 +50,7 @@ [%i Int (:: int.decimal encode)] [%r Rev (:: rev.decimal encode)] [%f Frac (:: frac.decimal encode)] + [%ratio ratio.Ratio (:: ratio.codec encode)] [%t Text text.encode] [%name Name (:: name.codec encode)] [%code Code code.to-text] diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 30abe1b37..a52c70fd4 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -9,7 +9,7 @@ [common (#+)] [host (#+)]])] (.module: - [lux #* + ["/" lux #* [cli (#+ program:)] ["." io (#+ io)] [control @@ -19,8 +19,7 @@ [number ["." i64]]] ["." function] - ["." math - ["r" random (#+ Random) ("#@." functor)]] + ["." math] ["_" test (#+ Test)] ## These modules do not need to be tested. [type @@ -28,11 +27,8 @@ [locale (#+) [language (#+)] [territory (#+)]] - [data - [text - [format (#+)]]] - ## [math - ## [random (#+)]] + data/text/format + ["r" math/random (#+ Random) ("#@." functor)] ## TODO: Test these modules [data [format @@ -235,8 +231,8 @@ (def: frac-rev (r.Random Rev) - (|> r.rev - (:: r.functor map (|>> (i64.left-shift 11) (i64.logic-right-shift 11))))) + (let [bits-to-ignore 11] + (:: r.functor map (i64.left-shift bits-to-ignore) r.rev))) (def: prelude-macros Test @@ -314,73 +310,71 @@ on-default)))))) (def: test - ($_ _.and - (<| (_.context "Identity.") - ..identity) - (<| (_.context "Increment & decrement.") - ..increment-and-decrement) - (<| (_.context "Even or odd.") - ($_ _.and - (<| (_.context "Natural numbers.") - (..even-or-odd r.nat n/even? n/odd?)) - (<| (_.context "Integers.") - (..even-or-odd r.int i/even? i/odd?)))) - (<| (_.context "Minimum and maximum.") - (`` ($_ _.and - (~~ (do-template [<=> <lt> <min> <gt> <max> <gen> <context>] - [(<| (_.context <context>) - (..minimum-and-maximum <gen> <=> [<lt> <min>] [<gt> <max>]))] + (<| (_.context (%name (name-of /._))) + ($_ _.and + (<| (_.context "Identity.") + ..identity) + (<| (_.context "Increment & decrement.") + ..increment-and-decrement) + (<| (_.context "Even or odd.") + ($_ _.and + (<| (_.context "Natural numbers.") + (..even-or-odd r.nat n/even? n/odd?)) + (<| (_.context "Integers.") + (..even-or-odd r.int i/even? i/odd?)))) + (<| (_.context "Minimum and maximum.") + (`` ($_ _.and + (~~ (do-template [<=> <lt> <min> <gt> <max> <gen> <context>] + [(<| (_.context <context>) + (..minimum-and-maximum <gen> <=> [<lt> <min>] [<gt> <max>]))] - [i/= i/< i/min i/> i/max r.int "Integers."] - [n/= n/< n/min n/> n/max r.nat "Natural numbers."] - [r/= r/< r/min r/> r/max r.rev "Revolutions."] - [f/= f/< f/min f/> f/max r.frac "Fractions."] - ))))) - (<| (_.context "Conversion.") - (`` ($_ _.and - (~~ (do-template [<context> <=> <forward> <backward> <gen>] - [(<| (_.context <context>) - (..conversion <gen> <forward> <backward> <=>))] + [i/= i/< i/min i/> i/max r.int "Integers."] + [n/= n/< n/min n/> n/max r.nat "Natural numbers."] + [r/= r/< r/min r/> r/max r.rev "Revolutions."] + [f/= f/< f/min f/> f/max r.frac "Fractions."] + ))))) + (<| (_.context "Conversion.") + (`` ($_ _.and + (~~ (do-template [<=> <forward> <backward> <gen>] + [(<| (_.context (format (%name (name-of <forward>)) + " " (%name (name-of <backward>)))) + (..conversion <gen> <forward> <backward> <=>))] - ["Int -> Nat" - i/= .nat .int (r@map (i/% +1,000,000) r.int)] - ["Nat -> Int" - n/= .int .nat (r@map (n/% 1,000,000) r.nat)] - ["Int -> Frac" - i/= int-to-frac frac-to-int (r@map (i/% +1,000,000) r.int)] - ["Frac -> Int" - f/= frac-to-int int-to-frac (r@map math.floor r.frac)] - ["Rev -> Frac" - r/= rev-to-frac frac-to-rev frac-rev] - ))))) - (<| (_.context "Prelude macros.") - ..prelude-macros) - (<| (_.context "Templates.") - ..template) - (<| (_.context "Cross-platform support.") - ..cross-platform-support) - /cli.test - /io.test - (<| (_.context "/control") - /control.test) - (<| (_.context "/data") - /data.test) - /macro.test - (<| (_.context "/math") - /math.test) - (<| (_.context "/time") - /time.test) - /type.test - /world.test - (<| (_.context "/host Host-platform interoperation") - ($_ _.and - /host.test - (<| (_.context "/jvm JVM (Java Virtual Machine)") - /host/jvm.test))) - )) + [i/= .nat .int (r@map (i/% +1,000,000) r.int)] + [n/= .int .nat (r@map (n/% 1,000,000) r.nat)] + [i/= .int-to-frac .frac-to-int (r@map (i/% +1,000,000) r.int)] + [f/= .frac-to-int .int-to-frac (r@map (|>> (i/% +1,000,000) .int-to-frac) r.int)] + [r/= .rev-to-frac .frac-to-rev frac-rev] + ))))) + (<| (_.context "Prelude macros.") + ..prelude-macros) + (<| (_.context "Templates.") + ..template) + (<| (_.context "Cross-platform support.") + ..cross-platform-support) + /cli.test + /io.test + (<| (_.context "/control") + /control.test) + (<| (_.context "/data") + /data.test) + /macro.test + (<| (_.context "/math") + /math.test) + (<| (_.context "/time") + /time.test) + /type.test + /world.test + (<| (_.context "/host Host-platform interoperation") + ($_ _.and + /host.test + (<| (_.context "/jvm JVM (Java Virtual Machine)") + /host/jvm.test))) + ))) (program: args (<| io _.run! - (_.times 100) + ## (_.times 100) + (_.seed 4035274984803317370) ..test)) diff --git a/stdlib/source/test/lux/control/enum.lux b/stdlib/source/test/lux/control/enum.lux index 030dee037..5c7832260 100644 --- a/stdlib/source/test/lux/control/enum.lux +++ b/stdlib/source/test/lux/control/enum.lux @@ -10,19 +10,19 @@ {1 ["." / (#+ Enum)]}) -(def: #export (spec (^open "_@.") gen-sample) +(def: #export (spec (^open "/@.") gen-sample) (All [a] (-> (Enum a) (Random a) Test)) (do r.monad [sample gen-sample] (<| (_.context (%name (name-of /.Order))) ($_ _.and (_.test "Successor and predecessor are inverse functions." - (and (_@= (|> sample _@succ _@pred) + (and (/@= (|> sample /@succ /@pred) (function.identity sample)) - (_@= (|> sample _@pred _@succ) + (/@= (|> sample /@pred /@succ) (function.identity sample)) - (not (_@= (|> sample _@succ) + (not (/@= (|> sample /@succ) (function.identity sample))) - (not (_@= (|> sample _@pred) + (not (/@= (|> sample /@pred) (function.identity sample))))) )))) diff --git a/stdlib/source/test/lux/control/number.lux b/stdlib/source/test/lux/control/number.lux index c1ffb0075..57bee6ee3 100644 --- a/stdlib/source/test/lux/control/number.lux +++ b/stdlib/source/test/lux/control/number.lux @@ -13,35 +13,35 @@ [// [order (#+ Order)]]]}) -(def: #export (spec (^open "_@.") (^open "_@.") gen-sample) +(def: #export (spec (^open "/@.") (^open "/@.") gen-sample) (All [a] (-> (Order a) (Number a) (Random a) Test)) (do r.monad [#let [non-zero (r.filter (function (_ sample) - (|> sample (_@+ sample) (_@= sample) not)) + (|> sample (/@+ sample) (/@= sample) not)) gen-sample)] parameter non-zero subject non-zero] (<| (_.context (%name (name-of /.Number))) ($_ _.and (_.test "Addition and subtraction are inverse functions." - (|> subject (_@+ parameter) (_@- parameter) (_@= subject))) + (|> subject (/@+ parameter) (/@- parameter) (/@= subject))) (_.test "Multiplication and division are inverse functions." - (|> subject (_@* parameter) (_@/ parameter) (_@= subject))) + (|> subject (/@* parameter) (/@/ parameter) (/@= subject))) (_.test "Modulus fills all the information division misses." - (let [modulus (_@% parameter subject) - multiple (_@- modulus subject) - times (_@/ modulus multiple)] - (|> parameter (_@* times) (_@+ modulus) (_@= subject)))) + (let [modulus (/@% parameter subject) + multiple (/@- modulus subject) + factor (/@/ parameter multiple)] + (|> parameter (/@* factor) (/@+ modulus) (/@= subject)))) (_.test "Negation flips the sign of a number and mimics subtraction." - (let [unsigned? (_@= (_@signum parameter) - (_@signum (_@negate parameter)))] + (let [unsigned? (/@= (/@signum parameter) + (/@signum (/@negate parameter)))] (or unsigned? - (_@= (_@+ (_@negate parameter) subject) - (_@- parameter subject))))) + (/@= (/@+ (/@negate parameter) subject) + (/@- parameter subject))))) (_.test "The absolute value is always positive." - (let [unsigned? (_@= (_@abs parameter) - (_@abs (_@negate parameter)))] + (let [unsigned? (/@= parameter + (/@negate parameter))] (if unsigned? - (_@= subject (_@abs subject)) - (_@>= subject (_@abs subject))))) + (/@= subject (/@abs subject)) + (/@>= subject (/@abs subject))))) )))) diff --git a/stdlib/source/test/lux/data/collection/row.lux b/stdlib/source/test/lux/data/collection/row.lux index cf678e0b4..1fa55e135 100644 --- a/stdlib/source/test/lux/data/collection/row.lux +++ b/stdlib/source/test/lux/data/collection/row.lux @@ -25,9 +25,9 @@ (def: #export test Test - (<| (_.context (%name (name-of /.Row))) + (<| (_.context (%name (name-of /._))) (do r.monad - [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1))))] + [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))] ($_ _.and ($equivalence.spec (/.equivalence nat.equivalence) (r.row size r.nat)) ($monoid.spec (/.equivalence nat.equivalence) /.monoid (r.row size r.nat)) @@ -43,34 +43,38 @@ non-member (|> r.nat (r.filter (|>> (/.member? nat.equivalence sample) not))) #let [(^open "/@.") (/.equivalence nat.equivalence)]] ($_ _.and - (_.test "Can query size of row." + (_.test (format (%name (name-of /.size)) + " " (%name (name-of /.empty?))) (if (/.empty? sample) (and (n/= 0 size) (n/= 0 (/.size sample))) (n/= size (/.size sample)))) - (_.test "Can add and remove elements to rows." + (_.test (format (%name (name-of /.add)) + " " (%name (name-of /.pop))) (and (n/= (inc size) (/.size (/.add non-member sample))) (n/= (dec size) (/.size (/.pop sample))))) - (_.test "Can put and get elements into rows." + (_.test (format (%name (name-of /.put)) + " " (%name (name-of /.nth))) (|> sample (/.put idx non-member) (/.nth idx) maybe.assume (is? non-member))) - (_.test "Can update elements of rows." + (_.test (%name (name-of /.update)) (|> sample (/.put idx non-member) (/.update idx inc) (/.nth idx) maybe.assume (n/= (inc non-member)))) - (_.test "Can safely transform to/from lists." + (_.test (format (%name (name-of /.to-list)) + " " (%name (name-of /.from-list))) (|> sample /.to-list /.from-list (/@= sample))) - (_.test "Can identify members of a row." + (_.test (%name (name-of /.member?)) (and (not (/.member? nat.equivalence sample non-member)) (/.member? nat.equivalence (/.add non-member sample) non-member))) - (_.test "Can reverse." + (_.test (%name (name-of /.reverse)) (and (not (/@= sample (/.reverse sample))) - (not (/@= sample - (/.reverse (/.reverse sample)))))) + (/@= sample + (/.reverse (/.reverse sample))))) )) )))) diff --git a/stdlib/source/test/lux/data/collection/stack.lux b/stdlib/source/test/lux/data/collection/stack.lux index 0a6fcf698..2886fa815 100644 --- a/stdlib/source/test/lux/data/collection/stack.lux +++ b/stdlib/source/test/lux/data/collection/stack.lux @@ -28,7 +28,7 @@ (def: #export test Test - (<| (_.context (%name (name-of /.Stack))) + (<| (_.context (%name (name-of /._))) (do r.monad [size gen-nat sample (r.stack size gen-nat) @@ -37,14 +37,13 @@ ($equivalence.spec (/.equivalence nat.equivalence) (r.stack size r.nat)) ($functor.spec ..injection /.equivalence /.functor) - (_.test "Can query the size of a stack." + (_.test (%name (name-of /.size)) (n/= size (/.size sample))) - (_.test "Can peek inside non-empty stacks." + (_.test (%name (name-of /.peek)) (case (/.peek sample) #.None (/.empty? sample) (#.Some _) (not (/.empty? sample)))) - (_.test (format "Popping empty stacks doesn't change anything." - "But, if they're non-empty, the top of the stack is removed.") + (_.test (%name (name-of /.pop)) (case (/.size sample) 0 (case (/.pop sample) #.None @@ -54,12 +53,12 @@ false) expected (case (/.pop sample) (#.Some sample') - (and (n/= expected (/.size sample')) + (and (n/= (dec expected) (/.size sample')) (not (/.empty? sample))) #.None false))) - (_.test "Pushing onto a stack always increases it by 1, adding a new value at the top." + (_.test (%name (name-of /.push)) (and (is? sample (|> sample (/.push new-top) /.pop maybe.assume)) (n/= (inc (/.size sample)) diff --git a/stdlib/source/test/lux/data/number/complex.lux b/stdlib/source/test/lux/data/number/complex.lux index 278e8ec58..19db6081d 100644 --- a/stdlib/source/test/lux/data/number/complex.lux +++ b/stdlib/source/test/lux/data/number/complex.lux @@ -56,7 +56,6 @@ (let [r+i (/.complex real imaginary)] (and (f/= real (get@ #/.real r+i)) (f/= imaginary (get@ #/.imaginary r+i))))) - (_.test "If either the real part or the imaginary part is NaN, the composite is NaN." (and (/.not-a-number? (/.complex frac.not-a-number imaginary)) (/.not-a-number? (/.complex real frac.not-a-number)))) @@ -73,11 +72,9 @@ abs (get@ #/.real (/.abs r+i))] (and (f/>= (frac@abs real) abs) (f/>= (frac@abs imaginary) abs)))) - (_.test "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value." (and (frac.not-a-number? (get@ #/.real (/.abs (/.complex frac.not-a-number imaginary)))) (frac.not-a-number? (get@ #/.real (/.abs (/.complex real frac.not-a-number)))))) - (_.test "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value." (and (f/= frac.positive-infinity (get@ #/.real (/.abs (/.complex frac.positive-infinity imaginary)))) (f/= frac.positive-infinity (get@ #/.real (/.abs (/.complex real frac.positive-infinity)))) @@ -99,7 +96,6 @@ (get@ #/.real x)) (f/+ (get@ #/.imaginary y) (get@ #/.imaginary x))))))) - (_.test "Subtracting 2 complex numbers is the same as adding their parts." (let [z (/.- y x)] (and (/.= z @@ -107,17 +103,13 @@ (get@ #/.real x)) (f/- (get@ #/.imaginary y) (get@ #/.imaginary x))))))) - (_.test "Subtraction is the inverse of addition." (and (|> x (/.+ y) (/.- y) (within? margin-of-error x)) (|> x (/.- y) (/.+ y) (within? margin-of-error x)))) - (_.test "Division is the inverse of multiplication." (|> x (/.* y) (/./ y) (within? margin-of-error x))) - (_.test "Scalar division is the inverse of scalar multiplication." (|> x (/.*' factor) (/./' factor) (within? margin-of-error x))) - (_.test "If you subtract the remainder, all divisions must be exact." (let [rem (/.% y x) quotient (|> x (/.- rem) (/./ y)) @@ -140,25 +132,20 @@ (get@ #/.real cx)) (f/= (frac@negate (get@ #/.imaginary x)) (get@ #/.imaginary cx))))) - (_.test "The reciprocal functions is its own inverse." (|> x /.reciprocal /.reciprocal (within? margin-of-error x))) - (_.test "x*(x^-1) = 1" (|> x (/.* (/.reciprocal x)) (within? margin-of-error /.one))) - (_.test "Absolute value of signum is always root2(2), 1 or 0." (let [signum-abs (|> x /.signum /.abs (get@ #/.real))] (or (f/= +0.0 signum-abs) (f/= +1.0 signum-abs) (f/= (math.pow +0.5 +2.0) signum-abs)))) - (_.test "Negation is its own inverse." (let [there (/.negate x) back-again (/.negate there)] (and (not (/.= there x)) (/.= back-again x)))) - (_.test "Negation doesn't change the absolute value." (f/= (get@ #/.real (/.abs x)) (get@ #/.real (/.abs (/.negate x))))) @@ -178,10 +165,8 @@ ($_ _.and (_.test "Arc-sine is the inverse of sine." (trigonometric-symmetry /.sin /.asin angle)) - (_.test "Arc-cosine is the inverse of cosine." (trigonometric-symmetry /.cos /.acos angle)) - (_.test "Arc-tangent is the inverse of tangent." (trigonometric-symmetry /.tan /.atan angle)))))) @@ -192,7 +177,6 @@ ($_ _.and (_.test "Root 2 is inverse of power 2." (|> x (/.pow' +2.0) (/.pow' +0.5) (within? margin-of-error x))) - (_.test "Logarithm is inverse of exponentiation." (|> x /.log /.exp (within? margin-of-error x))) ))) @@ -210,12 +194,13 @@ (def: #export test Test - ($_ _.and - ..construction - ..absolute-value - ..number - ..conjugate&reciprocal&signum&negation - ..trigonometry - ..exponentiation&logarithm - ..root - )) + (<| (_.context (%name (name-of /._))) + ($_ _.and + ..construction + ..absolute-value + ..number + ..conjugate&reciprocal&signum&negation + ..trigonometry + ..exponentiation&logarithm + ..root + ))) diff --git a/stdlib/source/test/lux/data/number/frac.lux b/stdlib/source/test/lux/data/number/frac.lux index 319debddd..87b937a93 100644 --- a/stdlib/source/test/lux/data/number/frac.lux +++ b/stdlib/source/test/lux/data/number/frac.lux @@ -9,8 +9,6 @@ ["$." equivalence] ["$." order] ["$." number] - ["$." enum] - ["$." interval] ["$." monoid] ["$." codec]]}] [math @@ -21,40 +19,35 @@ (def: #export test Test - (<| (_.context (%name (name-of .Frac))) - ($_ _.and - ($equivalence.spec /.equivalence r.frac) - ($order.spec /.order r.frac) - ($number.spec /.order /.number r.frac) - ($enum.spec /.enum r.frac) - ($interval.spec /.interval r.frac) - (<| (_.context "Addition.") - ($monoid.spec /.equivalence /.addition r.frac)) - (<| (_.context "Multiplication.") - ($monoid.spec /.equivalence /.multiplication r.frac)) - (<| (_.context "Minimum.") - ($monoid.spec /.equivalence /.minimum r.frac)) - (<| (_.context "Maximum.") - ($monoid.spec /.equivalence /.multiplication r.frac)) - ## TODO: Uncomment ASAP - ## (<| (_.context "Binary.") - ## ($codec.spec /.equivalence /.binary r.frac)) - ## (<| (_.context "Octal.") - ## ($codec.spec /.equivalence /.octal r.frac)) - ## (<| (_.context "Decimal.") - ## ($codec.spec /.equivalence /.decimal r.frac)) - ## (<| (_.context "Hexadecimal.") - ## ($codec.spec /.equivalence /.hex r.frac)) + (let [gen-frac (:: r.monad map (|>> (i/% +100) .int-to-frac) r.int)] + (<| (_.context (%name (name-of /._))) + (`` ($_ _.and + ($equivalence.spec /.equivalence gen-frac) + ($order.spec /.order gen-frac) + ($number.spec /.order /.number gen-frac) + (~~ (do-template [<monoid>] + [(<| (_.context (%name (name-of <monoid>))) + ($monoid.spec /.equivalence <monoid> gen-frac))] - (_.test "Alternate notations." - (and (f/= (bin "+1100.1001") - (bin "+11,00.10,01")) - (f/= (oct "-6152.43") - (oct "-615,2.43")) - (f/= (hex "+deadBE.EF") - (hex "+dead,BE.EF")))) - (do r.monad - [sample r.frac] - (_.test "Can convert frac values to/from their bit patterns." - (|> sample /.frac-to-bits /.bits-to-frac (f/= sample)))) - ))) + [/.addition] [/.multiplication] [/.minimum] [/.maximum] + )) + ## TODO: Uncomment ASAP + ## (~~ (do-template [<codec>] + ## [(<| (_.context (%name (name-of /.binary))) + ## ($codec.spec /.equivalence <codec> gen-frac))] + + ## [/.binary] [/.octal] [/.decimal] [/.hex] + ## )) + + (_.test "Alternate notations." + (and (f/= (bin "+1100.1001") + (bin "+11,00.10,01")) + (f/= (oct "-6152.43") + (oct "-615,2.43")) + (f/= (hex "+deadBE.EF") + (hex "+dead,BE.EF")))) + (do r.monad + [sample gen-frac] + (_.test (format (%name (name-of /.frac-to-bits)) " " (%name (name-of /.bits-to-frac))) + (|> sample /.frac-to-bits /.bits-to-frac (f/= sample)))) + ))))) diff --git a/stdlib/source/test/lux/data/number/i64.lux b/stdlib/source/test/lux/data/number/i64.lux index 1eb207e19..3e251d1e6 100644 --- a/stdlib/source/test/lux/data/number/i64.lux +++ b/stdlib/source/test/lux/data/number/i64.lux @@ -16,68 +16,69 @@ (def: #export test Test - (do r.monad - [pattern r.nat - idx (:: @ map (n/% /.width) r.nat)] - ($_ _.and - ($monoid.spec //nat.equivalence /.disjunction r.nat) - ($monoid.spec //nat.equivalence /.conjunction r.nat) - - (_.test "Clearing and settings bits should alter the count." - (and (n/= (dec (/.count (/.set idx pattern))) - (/.count (/.clear idx pattern))) - (|> (/.count pattern) - (n/- (/.count (/.clear idx pattern))) - (n/<= 1)) - (|> (/.count (/.set idx pattern)) - (n/- (/.count pattern)) - (n/<= 1)))) - (_.test "Can query whether a bit is set." - (and (or (and (/.set? idx pattern) - (not (/.set? idx (/.clear idx pattern)))) - (and (not (/.set? idx pattern)) - (/.set? idx (/.set idx pattern)))) + (<| (_.context (%name (name-of /._))) + (do r.monad + [pattern r.nat + idx (:: @ map (n/% /.width) r.nat)] + ($_ _.and + ($monoid.spec //nat.equivalence /.disjunction r.nat) + ($monoid.spec //nat.equivalence /.conjunction r.nat) + + (_.test "Clearing and settings bits should alter the count." + (and (n/= (dec (/.count (/.set idx pattern))) + (/.count (/.clear idx pattern))) + (|> (/.count pattern) + (n/- (/.count (/.clear idx pattern))) + (n/<= 1)) + (|> (/.count (/.set idx pattern)) + (n/- (/.count pattern)) + (n/<= 1)))) + (_.test "Can query whether a bit is set." + (and (or (and (/.set? idx pattern) + (not (/.set? idx (/.clear idx pattern)))) + (and (not (/.set? idx pattern)) + (/.set? idx (/.set idx pattern)))) - (or (and (/.set? idx pattern) - (not (/.set? idx (/.flip idx pattern)))) - (and (not (/.set? idx pattern)) - (/.set? idx (/.flip idx pattern)))))) - (_.test "The negation of a bit pattern should have a complementary bit-count." - (n/= /.width - (n/+ (/.count pattern) - (/.count (/.not pattern))))) - (_.test "Can do simple binary logic." - (and (n/= 0 - (/.and pattern - (/.not pattern))) - (n/= (/.not 0) - (/.or pattern - (/.not pattern))) - (n/= (/.not 0) - (/.xor pattern - (/.not pattern))) - (n/= 0 - (/.xor pattern - pattern)))) - (_.test "rotate-left and rotate-right are inverses of one another." - (and (|> pattern - (/.rotate-left idx) - (/.rotate-right idx) - (n/= pattern)) - (|> pattern - (/.rotate-right idx) - (/.rotate-left idx) - (n/= pattern)))) - (_.test "Rotate as many spaces as the bit-pattern's width leaves the pattern unchanged." - (and (|> pattern - (/.rotate-left /.width) - (n/= pattern)) - (|> pattern - (/.rotate-right /.width) - (n/= pattern)))) - (_.test "Shift right respect the sign of ints." - (let [value (.int pattern)] - (if (i/< +0 value) - (i/< +0 (/.arithmetic-right-shift idx value)) - (i/>= +0 (/.arithmetic-right-shift idx value))))) - ))) + (or (and (/.set? idx pattern) + (not (/.set? idx (/.flip idx pattern)))) + (and (not (/.set? idx pattern)) + (/.set? idx (/.flip idx pattern)))))) + (_.test "The negation of a bit pattern should have a complementary bit-count." + (n/= /.width + (n/+ (/.count pattern) + (/.count (/.not pattern))))) + (_.test "Can do simple binary logic." + (and (n/= 0 + (/.and pattern + (/.not pattern))) + (n/= (/.not 0) + (/.or pattern + (/.not pattern))) + (n/= (/.not 0) + (/.xor pattern + (/.not pattern))) + (n/= 0 + (/.xor pattern + pattern)))) + (_.test "rotate-left and rotate-right are inverses of one another." + (and (|> pattern + (/.rotate-left idx) + (/.rotate-right idx) + (n/= pattern)) + (|> pattern + (/.rotate-right idx) + (/.rotate-left idx) + (n/= pattern)))) + (_.test "Rotate as many spaces as the bit-pattern's width leaves the pattern unchanged." + (and (|> pattern + (/.rotate-left /.width) + (n/= pattern)) + (|> pattern + (/.rotate-right /.width) + (n/= pattern)))) + (_.test "Shift right respect the sign of ints." + (let [value (.int pattern)] + (if (i/< +0 value) + (i/< +0 (/.arithmetic-right-shift idx value)) + (i/>= +0 (/.arithmetic-right-shift idx value))))) + )))) diff --git a/stdlib/source/test/lux/data/number/int.lux b/stdlib/source/test/lux/data/number/int.lux index e83571653..b9ed4f856 100644 --- a/stdlib/source/test/lux/data/number/int.lux +++ b/stdlib/source/test/lux/data/number/int.lux @@ -21,35 +21,31 @@ (def: #export test Test - (<| (_.context (%name (name-of .Int))) - ($_ _.and - ($equivalence.spec /.equivalence r.int) - ($order.spec /.order r.int) - ($number.spec /.order /.number r.int) - ($enum.spec /.enum r.int) - ($interval.spec /.interval r.int) - (<| (_.context "Addition.") - ($monoid.spec /.equivalence /.addition r.int)) - (<| (_.context "Multiplication.") - ($monoid.spec /.equivalence /.multiplication r.int)) - (<| (_.context "Minimum.") - ($monoid.spec /.equivalence /.minimum r.int)) - (<| (_.context "Maximum.") - ($monoid.spec /.equivalence /.multiplication r.int)) - (<| (_.context "Binary.") - ($codec.spec /.equivalence /.binary r.int)) - (<| (_.context "Octal.") - ($codec.spec /.equivalence /.octal r.int)) - (<| (_.context "Decimal.") - ($codec.spec /.equivalence /.decimal r.int)) - (<| (_.context "Hexadecimal.") - ($codec.spec /.equivalence /.hex r.int)) + (<| (_.context (%name (name-of /._))) + (`` ($_ _.and + ($equivalence.spec /.equivalence r.int) + ($order.spec /.order r.int) + ($number.spec /.order /.number (:: r.monad map (i/% +1,000,000) r.int)) + ($enum.spec /.enum r.int) + ($interval.spec /.interval r.int) + (~~ (do-template [<monoid>] + [(<| (_.context (%name (name-of <monoid>))) + ($monoid.spec /.equivalence <monoid> r.int))] - (_.test "Alternate notations." - (and (i/= (bin "+11001001") - (bin "+11,00,10,01")) - (i/= (oct "-615243") - (oct "-615,243")) - (i/= (hex "+deadBEEF") - (hex "+dead,BEEF")))) - ))) + [/.addition] [/.multiplication] [/.minimum] [/.maximum] + )) + (~~ (do-template [<codec>] + [(<| (_.context (%name (name-of /.binary))) + ($codec.spec /.equivalence <codec> r.int))] + + [/.binary] [/.octal] [/.decimal] [/.hex] + )) + + (_.test "Alternate notations." + (and (i/= (bin "+11001001") + (bin "+11,00,10,01")) + (i/= (oct "-615243") + (oct "-615,243")) + (i/= (hex "+deadBEEF") + (hex "+dead,BEEF")))) + )))) diff --git a/stdlib/source/test/lux/data/number/nat.lux b/stdlib/source/test/lux/data/number/nat.lux index e570de094..17ee0503b 100644 --- a/stdlib/source/test/lux/data/number/nat.lux +++ b/stdlib/source/test/lux/data/number/nat.lux @@ -21,35 +21,31 @@ (def: #export test Test - (<| (_.context (%name (name-of .Nat))) - ($_ _.and - ($equivalence.spec /.equivalence r.nat) - ($order.spec /.order r.nat) - ($number.spec /.order /.number r.nat) - ($enum.spec /.enum r.nat) - ($interval.spec /.interval r.nat) - (<| (_.context "Addition.") - ($monoid.spec /.equivalence /.addition r.nat)) - (<| (_.context "Multiplication.") - ($monoid.spec /.equivalence /.multiplication r.nat)) - (<| (_.context "Minimum.") - ($monoid.spec /.equivalence /.minimum r.nat)) - (<| (_.context "Maximum.") - ($monoid.spec /.equivalence /.multiplication r.nat)) - (<| (_.context "Binary.") - ($codec.spec /.equivalence /.binary r.nat)) - (<| (_.context "Octal.") - ($codec.spec /.equivalence /.octal r.nat)) - (<| (_.context "Decimal.") - ($codec.spec /.equivalence /.decimal r.nat)) - (<| (_.context "Hexadecimal.") - ($codec.spec /.equivalence /.hex r.nat)) + (<| (_.context (%name (name-of /._))) + (`` ($_ _.and + ($equivalence.spec /.equivalence r.nat) + ($order.spec /.order r.nat) + ($number.spec /.order /.number (:: r.monad map (n/% 1,000,000) r.nat)) + ($enum.spec /.enum r.nat) + ($interval.spec /.interval r.nat) + (~~ (do-template [<monoid>] + [(<| (_.context (%name (name-of <monoid>))) + ($monoid.spec /.equivalence <monoid> r.nat))] - (_.test "Alternate notations." - (and (n/= (bin "11001001") - (bin "11,00,10,01")) - (n/= (oct "615243") - (oct "615,243")) - (n/= (hex "deadBEEF") - (hex "dead,BEEF")))) - ))) + [/.addition] [/.multiplication] [/.minimum] [/.maximum] + )) + (~~ (do-template [<codec>] + [(<| (_.context (%name (name-of /.binary))) + ($codec.spec /.equivalence <codec> r.nat))] + + [/.binary] [/.octal] [/.decimal] [/.hex] + )) + + (_.test "Alternate notations." + (and (n/= (bin "11001001") + (bin "11,00,10,01")) + (n/= (oct "615243") + (oct "615,243")) + (n/= (hex "deadBEEF") + (hex "dead,BEEF")))) + )))) diff --git a/stdlib/source/test/lux/data/number/ratio.lux b/stdlib/source/test/lux/data/number/ratio.lux index 654c489c3..5b74956c4 100644 --- a/stdlib/source/test/lux/data/number/ratio.lux +++ b/stdlib/source/test/lux/data/number/ratio.lux @@ -9,6 +9,7 @@ ["$." equivalence] ["$." order] ["$." number] + ["$." monoid] ["$." codec]]}] [math ["r" random (#+ Random)]]] @@ -17,30 +18,35 @@ (def: part (Random Nat) - (|> r.nat (:: r.monad map (|>> (n/% 1000) (n/max 1))))) + (|> r.nat (:: r.monad map (|>> (n/% 1,000,000) (n/max 1))))) (def: #export ratio (Random Ratio) (do r.monad [numerator ..part - denominator (|> ..part - (r.filter (|>> (n/= 0) not)) - (r.filter (|>> (n/= numerator) not)))] + denominator (r.filter (|>> (n/= 0) not) ..part)] (wrap (/.ratio numerator denominator)))) (def: #export test Test - (do r.monad - [denom0 ..part - denom1 ..part] - ($_ _.and - ($equivalence.spec /.equivalence ..ratio) - ($order.spec /.order ..ratio) - ($number.spec /.order /.number ..ratio) - ($codec.spec /.equivalence /.codec ..ratio) + (<| (_.context (%name (name-of /._))) + (`` ($_ _.and + ($equivalence.spec /.equivalence ..ratio) + ($order.spec /.order ..ratio) + ($number.spec /.order /.number ..ratio) + (~~ (do-template [<monoid>] + [(<| (_.context (%name (name-of <monoid>))) + ($monoid.spec /.equivalence <monoid> ..ratio))] + + [/.addition] [/.multiplication] + )) + ($codec.spec /.equivalence /.codec ..ratio) - (_.test "All zeroes are the same." - (let [(^open "/@.") /.equivalence] - (/@= (/.ratio 0 denom0) - (/.ratio 0 denom1)))) - ))) + (do r.monad + [denom0 ..part + denom1 ..part] + (_.test "All zeroes are the same." + (let [(^open "/@.") /.equivalence] + (/@= (/.ratio 0 denom0) + (/.ratio 0 denom1))))) + )))) diff --git a/stdlib/source/test/lux/data/number/rev.lux b/stdlib/source/test/lux/data/number/rev.lux index 427ce4edf..dba639ae9 100644 --- a/stdlib/source/test/lux/data/number/rev.lux +++ b/stdlib/source/test/lux/data/number/rev.lux @@ -13,6 +13,10 @@ ["$." interval] ["$." monoid] ["$." codec]]}] + [data + ["." error] + [number + ["." i64]]] [math ["r" random]]] {1 @@ -21,35 +25,29 @@ (def: #export test Test - (<| (_.context (%name (name-of .Rev))) - ($_ _.and - ($equivalence.spec /.equivalence r.rev) - ($order.spec /.order r.rev) - ($number.spec /.order /.number r.rev) - ($enum.spec /.enum r.rev) - ($interval.spec /.interval r.rev) - (<| (_.context "Addition.") - ($monoid.spec /.equivalence /.addition r.rev)) - (<| (_.context "Multiplication.") - ($monoid.spec /.equivalence /.multiplication r.rev)) - (<| (_.context "Minimum.") - ($monoid.spec /.equivalence /.minimum r.rev)) - (<| (_.context "Maximum.") - ($monoid.spec /.equivalence /.multiplication r.rev)) - (<| (_.context "Binary.") - ($codec.spec /.equivalence /.binary r.rev)) - (<| (_.context "Octal.") - ($codec.spec /.equivalence /.octal r.rev)) - (<| (_.context "Decimal.") - ($codec.spec /.equivalence /.decimal r.rev)) - (<| (_.context "Hexadecimal.") - ($codec.spec /.equivalence /.hex r.rev)) + (<| (_.context (%name (name-of /._))) + (`` ($_ _.and + ($equivalence.spec /.equivalence r.rev) + ($order.spec /.order r.rev) + ($enum.spec /.enum r.rev) + ($interval.spec /.interval r.rev) + (~~ (do-template [<monoid>] + [(<| (_.context (%name (name-of <monoid>))) + ($monoid.spec /.equivalence <monoid> r.rev))] - (_.test "Alternate notations." - (and (r/= (bin ".11001001") - (bin ".11,00,10,01")) - (r/= (oct ".615243") - (oct ".615,243")) - (r/= (hex ".deadBEEF") - (hex ".dead,BEEF")))) - ))) + [/.addition] [/.minimum] [/.maximum] + )) + (~~ (do-template [<codec>] + [(<| (_.context (%name (name-of /.binary))) + ($codec.spec /.equivalence <codec> r.rev))] + + [/.binary] [/.octal] [/.decimal] [/.hex] + )) + (_.test "Alternate notations." + (and (r/= (bin ".11001001") + (bin ".11,00,10,01")) + (r/= (oct ".615243") + (oct ".615,243")) + (r/= (hex ".deadBEEF") + (hex ".dead,BEEF")))) + )))) |