From 1d7a328afcb649fa0a69f6df4bd7b1ca6aa8a59c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 24 Mar 2017 17:38:39 -0400 Subject: - Moved lux/random to lux/math/random. - Moved lux/math/ratio to lux/number/ratio. - Moved lux/math/complex to lux/number/complex. --- stdlib/source/lux/data/number/complex.lux | 331 +++++++++++++++++++++++ stdlib/source/lux/data/number/ratio.lux | 158 +++++++++++ stdlib/source/lux/math/complex.lux | 331 ----------------------- stdlib/source/lux/math/random.lux | 303 +++++++++++++++++++++ stdlib/source/lux/math/ratio.lux | 158 ----------- stdlib/source/lux/random.lux | 302 --------------------- stdlib/source/lux/test.lux | 2 +- stdlib/test/test/lux.lux | 2 +- stdlib/test/test/lux/cli.lux | 2 +- stdlib/test/test/lux/codata/coll/stream.lux | 2 +- stdlib/test/test/lux/codata/cont.lux | 2 +- stdlib/test/test/lux/codata/thunk.lux | 2 +- stdlib/test/test/lux/concurrency/atom.lux | 2 +- stdlib/test/test/lux/concurrency/promise.lux | 2 +- stdlib/test/test/lux/concurrency/stm.lux | 2 +- stdlib/test/test/lux/data/bit.lux | 2 +- stdlib/test/test/lux/data/bool.lux | 2 +- stdlib/test/test/lux/data/char.lux | 2 +- stdlib/test/test/lux/data/coll/array.lux | 2 +- stdlib/test/test/lux/data/coll/dict.lux | 2 +- stdlib/test/test/lux/data/coll/list.lux | 2 +- stdlib/test/test/lux/data/coll/queue.lux | 2 +- stdlib/test/test/lux/data/coll/set.lux | 2 +- stdlib/test/test/lux/data/coll/stack.lux | 2 +- stdlib/test/test/lux/data/coll/tree/rose.lux | 2 +- stdlib/test/test/lux/data/coll/tree/zipper.lux | 2 +- stdlib/test/test/lux/data/coll/vector.lux | 2 +- stdlib/test/test/lux/data/error/exception.lux | 2 +- stdlib/test/test/lux/data/format/json.lux | 2 +- stdlib/test/test/lux/data/ident.lux | 2 +- stdlib/test/test/lux/data/number.lux | 2 +- stdlib/test/test/lux/data/number/complex.lux | 200 ++++++++++++++ stdlib/test/test/lux/data/number/ratio.lux | 107 ++++++++ stdlib/test/test/lux/data/text.lux | 2 +- stdlib/test/test/lux/effect.lux | 2 +- stdlib/test/test/lux/host.js.lux | 2 +- stdlib/test/test/lux/host.jvm.lux | 2 +- stdlib/test/test/lux/lexer.lux | 2 +- stdlib/test/test/lux/lexer/regex.lux | 2 +- stdlib/test/test/lux/macro/ast.lux | 2 +- stdlib/test/test/lux/macro/poly/eq.lux | 2 +- stdlib/test/test/lux/macro/poly/functor.lux | 2 +- stdlib/test/test/lux/macro/poly/text-encoder.lux | 2 +- stdlib/test/test/lux/macro/syntax.lux | 2 +- stdlib/test/test/lux/math.lux | 2 +- stdlib/test/test/lux/math/complex.lux | 200 -------------- stdlib/test/test/lux/math/logic/continuous.lux | 2 +- stdlib/test/test/lux/math/logic/fuzzy.lux | 3 +- stdlib/test/test/lux/math/ratio.lux | 107 -------- stdlib/test/test/lux/math/simple.lux | 2 +- stdlib/test/test/lux/pipe.lux | 2 +- stdlib/test/test/lux/type.lux | 2 +- stdlib/test/test/lux/type/auto.lux | 2 +- stdlib/test/test/lux/type/check.lux | 2 +- stdlib/test/tests.lux | 6 +- 55 files changed, 1146 insertions(+), 1146 deletions(-) create mode 100644 stdlib/source/lux/data/number/complex.lux create mode 100644 stdlib/source/lux/data/number/ratio.lux delete mode 100644 stdlib/source/lux/math/complex.lux create mode 100644 stdlib/source/lux/math/random.lux delete mode 100644 stdlib/source/lux/math/ratio.lux delete mode 100644 stdlib/source/lux/random.lux create mode 100644 stdlib/test/test/lux/data/number/complex.lux create mode 100644 stdlib/test/test/lux/data/number/ratio.lux delete mode 100644 stdlib/test/test/lux/math/complex.lux delete mode 100644 stdlib/test/test/lux/math/ratio.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux new file mode 100644 index 000000000..87b1a7d18 --- /dev/null +++ b/stdlib/source/lux/data/number/complex.lux @@ -0,0 +1,331 @@ +(;module: {#;doc "Complex arithmetic."} + lux + (lux [math] + (control eq + [ord] + number + codec + monad) + (data [number "r/" Number Codec] + [text "Text/" Monoid] + text/format + error + maybe + (coll [list "List/" Monad])) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## Based on org.apache.commons.math4.complex.Complex +## https://github.com/apache/commons-math/blob/master/src/main/java/org/apache/commons/math4/complex/Complex.java + +(type: #export Complex + {#real Real + #imaginary Real}) + +(syntax: #export (complex real [?imaginary (s;opt s;any)]) + {#;doc (doc "Complex literals." + (complex real imaginary) + "The imaginary part can be omitted if it's 0." + (complex real))} + (wrap (list (` {#;;real (~ real) + #;;imaginary (~ (default (' 0.0) + ?imaginary))})))) + +(def: #export i Complex (complex 0.0 1.0)) + +(def: #export one Complex (complex 1.0 0.0)) + +(def: #export zero Complex (complex 0.0 0.0)) + +(def: #export (not-a-number? complex) + (or (number;not-a-number? (get@ #real complex)) + (number;not-a-number? (get@ #imaginary complex)))) + +(def: #export (c.= param input) + (-> Complex Complex Bool) + (and (r.= (get@ #real param) + (get@ #real input)) + (r.= (get@ #imaginary param) + (get@ #imaginary input)))) + +(do-template [ ] + [(def: #export ( param input) + (-> Complex Complex Complex) + {#real ( (get@ #real param) + (get@ #real input)) + #imaginary ( (get@ #imaginary param) + (get@ #imaginary input))})] + + [c.+ r.+] + [c.- r.-] + ) + +(struct: #export _ (Eq Complex) + (def: = c.=)) + +(def: #export c.negate + (-> Complex Complex) + (|>. (update@ #real r/negate) + (update@ #imaginary r/negate))) + +(def: #export c.signum + (-> Complex Complex) + (|>. (update@ #real r/signum) + (update@ #imaginary r/signum))) + +(def: #export conjugate + (-> Complex Complex) + (update@ #imaginary r/negate)) + +(def: #export (c.*' param input) + (-> Real Complex Complex) + {#real (r.* param + (get@ #real input)) + #imaginary (r.* param + (get@ #imaginary input))}) + +(def: #export (c.* param input) + (-> Complex Complex Complex) + {#real (r.- (r.* (get@ #imaginary param) + (get@ #imaginary input)) + (r.* (get@ #real param) + (get@ #real input))) + #imaginary (r.+ (r.* (get@ #real param) + (get@ #imaginary input)) + (r.* (get@ #imaginary param) + (get@ #real input)))}) + +(def: #export (c./ param input) + (-> Complex Complex Complex) + (let [(^slots [#real #imaginary]) param] + (if (r.< (r/abs imaginary) + (r/abs real)) + (let [quot (r./ imaginary real) + denom (|> real (r.* quot) (r.+ imaginary))] + {#real (|> (get@ #real input) (r.* quot) (r.+ (get@ #imaginary input)) (r./ denom)) + #imaginary (|> (get@ #imaginary input) (r.* quot) (r.- (get@ #real input)) (r./ denom))}) + (let [quot (r./ real imaginary) + denom (|> imaginary (r.* quot) (r.+ real))] + {#real (|> (get@ #imaginary input) (r.* quot) (r.+ (get@ #real input)) (r./ denom)) + #imaginary (|> (get@ #imaginary input) (r.- (r.* quot (get@ #real input))) (r./ denom))})))) + +(def: #export (c./' param subject) + (-> Real Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (r./ param real) + #imaginary (r./ param imaginary)})) + +(def: #export (c.% param input) + (-> Complex Complex Complex) + (let [scaled (c./ param input) + quotient (|> scaled + (update@ #real math;floor) + (update@ #imaginary math;floor))] + (c.- (c.* quotient param) + input))) + +(def: #export (cos subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (r.* (math;cosh imaginary) + (math;cos real)) + #imaginary (r.* (math;sinh imaginary) + (r/negate (math;sin real)))})) + +(def: #export (cosh subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (r.* (math;cos imaginary) + (math;cosh real)) + #imaginary (r.* (math;sin imaginary) + (math;sinh real))})) + +(def: #export (sin subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (r.* (math;cosh imaginary) + (math;sin real)) + #imaginary (r.* (math;sinh imaginary) + (math;cos real))})) + +(def: #export (sinh subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (r.* (math;cos imaginary) + (math;sinh real)) + #imaginary (r.* (math;sin imaginary) + (math;cosh real))})) + +(def: #export (tan subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject + r2 (r.* 2.0 real) + i2 (r.* 2.0 imaginary) + d (r.+ (math;cos r2) (math;cosh i2))] + {#real (r./ d (math;sin r2)) + #imaginary (r./ d (math;sinh i2))})) + +(def: #export (tanh subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject + r2 (r.* 2.0 real) + i2 (r.* 2.0 imaginary) + d (r.+ (math;cosh r2) (math;cos i2))] + {#real (r./ d (math;sinh r2)) + #imaginary (r./ d (math;sin i2))})) + +(def: #export (c.abs subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + (complex (if (r.< (r/abs imaginary) + (r/abs real)) + (if (r.= 0.0 imaginary) + (r/abs real) + (let [q (r./ imaginary real)] + (r.* (math;root2 (r.+ 1.0 (r.* q q))) + (r/abs imaginary)))) + (if (r.= 0.0 real) + (r/abs imaginary) + (let [q (r./ real imaginary)] + (r.* (math;root2 (r.+ 1.0 (r.* q q))) + (r/abs real)))) + )))) + +(struct: #export _ (Number Complex) + (def: + c.+) + (def: - c.-) + (def: * c.*) + (def: / c./) + (def: % c.%) + (def: (negate x) + (|> x + (update@ #real r/negate) + (update@ #imaginary r/negate))) + (def: abs c.abs) + (def: (signum x) + (|> x + (update@ #real r/signum) + (update@ #imaginary r/signum)))) + +(def: #export (exp subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject + r-exp (math;exp real)] + {#real (r.* r-exp (math;cos imaginary)) + #imaginary (r.* r-exp (math;sin imaginary))})) + +(def: #export (log subject) + (-> Complex Complex) + (let [(^slots [#real #imaginary]) subject] + {#real (|> subject c.abs (get@ #real) math;log) + #imaginary (math;atan2 real imaginary)})) + +(do-template [ ] + [(def: #export ( param input) + (-> Complex Complex) + (|> input log ( param) exp))] + + [pow Complex c.*] + [pow' Real c.*'] + ) + +(def: (copy-sign sign magnitude) + (-> Real Real Real) + (r.* (r/signum sign) magnitude)) + +(def: #export (root2 (^@ input (^slots [#real #imaginary]))) + (-> Complex Complex) + (let [t (|> input c.abs (get@ #real) (r.+ (r/abs real)) (r./ 2.0) math;root2)] + (if (r.>= 0.0 real) + {#real t + #imaginary (r./ (r.* 2.0 t) + imaginary)} + {#real (r./ (r.* 2.0 t) + (r/abs imaginary)) + #imaginary (r.* t (copy-sign imaginary 1.0))}))) + +(def: #export (root2-1z input) + (-> Complex Complex) + (|> (complex 1.0) (c.- (c.* input input)) root2)) + +(def: #export (reciprocal (^slots [#real #imaginary])) + (-> Complex Complex) + (if (r.< (r/abs imaginary) + (r/abs real)) + (let [q (r./ imaginary real) + scale (r./ (|> real (r.* q) (r.+ imaginary)) + 1.0)] + {#real (r.* q scale) + #imaginary (r/negate scale)}) + (let [q (r./ real imaginary) + scale (r./ (|> imaginary (r.* q) (r.+ real)) + 1.0)] + {#real scale + #imaginary (|> scale r/negate (r.* q))}))) + +(def: #export (acos input) + (-> Complex Complex) + (|> input + (c.+ (|> input root2-1z (c.* i))) + log + (c.* (c.negate i)))) + +(def: #export (asin input) + (-> Complex Complex) + (|> input + root2-1z + (c.+ (c.* i input)) + log + (c.* (c.negate i)))) + +(def: #export (atan input) + (-> Complex Complex) + (|> input + (c.+ i) + (c./ (c.- input i)) + log + (c.* (c./ (complex 2.0) i)))) + +(def: #export (argument (^slots [#real #imaginary])) + (-> Complex Real) + (math;atan2 real imaginary)) + +(def: #export (nth-roots nth input) + (-> Nat Complex (List Complex)) + (if (n.= +0 nth) + (list) + (let [r-nth (|> nth nat-to-int int-to-real) + nth-root-of-abs (|> input c.abs (get@ #real) (math;pow (r./ r-nth 1.0))) + nth-phi (|> input argument (r./ r-nth)) + slice (|> math;pi (r.* 2.0) (r./ r-nth))] + (|> (list;n.range +0 (n.dec nth)) + (List/map (lambda [nth'] + (let [inner (|> nth' nat-to-int int-to-real + (r.* slice) + (r.+ nth-phi)) + real (r.* nth-root-of-abs + (math;cos inner)) + imaginary (r.* nth-root-of-abs + (math;sin inner))] + {#real real + #imaginary imaginary}))))))) + +(struct: #export _ (Codec Text Complex) + (def: (encode (^slots [#real #imaginary])) + ($_ Text/append "(" (r/encode real) ", " (r/encode imaginary) ")")) + + (def: (decode input) + (case (do Monad + [input' (text;clip +1 (n.- +1 (text;size input)) input)] + (text;split-with "," input')) + #;None + (#;Left (Text/append "Wrong syntax for complex numbers: " input)) + + (#;Some [r' i']) + (do Monad + [r (r/decode (text;trim r')) + i (r/decode (text;trim i'))] + (wrap {#real r + #imaginary i})) + ))) diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux new file mode 100644 index 000000000..fb86b1fed --- /dev/null +++ b/stdlib/source/lux/data/number/ratio.lux @@ -0,0 +1,158 @@ +(;module: {#;doc "Rational arithmetic."} + lux + (lux [math] + (control eq + [ord] + number + codec + monad) + (data [number "n/" Number Codec] + [text "Text/" Monoid] + text/format + error + [product]) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +(type: #export Ratio + {#numerator Nat + #denominator Nat}) + +(def: #hidden (normalize (^slots [#numerator #denominator])) + (-> Ratio Ratio) + (let [common (math;gcd numerator denominator)] + {#numerator (n./ common numerator) + #denominator (n./ common denominator)})) + +(def: #export (q.* param input) + (-> Ratio Ratio Ratio) + (normalize [(n.* (get@ #numerator param) + (get@ #numerator input)) + (n.* (get@ #denominator param) + (get@ #denominator input))])) + +(def: #export (q./ param input) + (-> Ratio Ratio Ratio) + (normalize [(n.* (get@ #denominator param) + (get@ #numerator input)) + (n.* (get@ #numerator param) + (get@ #denominator input))])) + +(def: #export (q.+ param input) + (-> Ratio Ratio Ratio) + (normalize [(n.+ (n.* (get@ #denominator input) + (get@ #numerator param)) + (n.* (get@ #denominator param) + (get@ #numerator input))) + (n.* (get@ #denominator param) + (get@ #denominator input))])) + +(def: #export (q.- param input) + (-> Ratio Ratio Ratio) + (normalize [(n.- (n.* (get@ #denominator input) + (get@ #numerator param)) + (n.* (get@ #denominator param) + (get@ #numerator input))) + (n.* (get@ #denominator param) + (get@ #denominator input))])) + +(def: #export (q.% param input) + (-> Ratio Ratio Ratio) + (let [quot (n./ (n.* (get@ #denominator input) + (get@ #numerator param)) + (n.* (get@ #denominator param) + (get@ #numerator input)))] + (q.- (update@ #numerator (n.* quot) param) + input))) + +(def: #export (q.= param input) + (-> Ratio Ratio Bool) + (and (n.= (get@ #numerator param) + (get@ #numerator input)) + (n.= (get@ #denominator param) + (get@ #denominator input)))) + +(do-template [ ] + [(def: #export ( param input) + (-> Ratio Ratio Bool) + (and ( (n.* (get@ #denominator input) + (get@ #numerator param)) + (n.* (get@ #denominator param) + (get@ #numerator input)))))] + + [q.< n.<] + [q.<= n.<=] + [q.> n.>] + [q.>= n.>=] + ) + +(do-template [ ] + [(def: #export ( left right) + (-> Ratio Ratio Ratio) + (if ( left right) + right + left))] + + [q.min q.<] + [q.max q.>] + ) + +(struct: #export _ (Eq Ratio) + (def: = q.=)) + +(struct: #export _ (ord;Ord Ratio) + (def: eq Eq) + (def: < q.<) + (def: <= q.<=) + (def: > q.>) + (def: >= q.>=)) + +(struct: #export _ (Number Ratio) + (def: + q.+) + (def: - q.-) + (def: * q.*) + (def: / q./) + (def: % q.%) + (def: (negate (^slots [#numerator #denominator])) + {#numerator denominator + #denominator numerator}) + (def: abs id) + (def: (signum x) + {#numerator +1 + #denominator +1})) + +(def: separator Text ":") + +(def: part-encode + (-> Nat Text) + (|>. n/encode (text;split +1) (default (undefined)) product;right)) + +(def: part-decode + (-> Text (Error Nat)) + (|>. (format "+") n/decode)) + +(struct: #export _ (Codec Text Ratio) + (def: (encode (^slots [#numerator #denominator])) + ($_ Text/append (part-encode numerator) separator (part-encode denominator))) + + (def: (decode input) + (case (text;split-with separator input) + (#;Some [num denom]) + (do Monad + [numerator (part-decode num) + denominator (part-decode denom)] + (wrap (normalize {#numerator numerator + #denominator denominator}))) + + #;None + (#;Left (Text/append "Invalid syntax for ratio: " input))))) + +(syntax: #export (ratio numerator [?denominator (s;opt 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 (~ (default (' +1) + ?denominator))}))))) diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux deleted file mode 100644 index 87b1a7d18..000000000 --- a/stdlib/source/lux/math/complex.lux +++ /dev/null @@ -1,331 +0,0 @@ -(;module: {#;doc "Complex arithmetic."} - lux - (lux [math] - (control eq - [ord] - number - codec - monad) - (data [number "r/" Number Codec] - [text "Text/" Monoid] - text/format - error - maybe - (coll [list "List/" Monad])) - [compiler] - (macro [ast] - ["s" syntax #+ syntax: Syntax]))) - -## Based on org.apache.commons.math4.complex.Complex -## https://github.com/apache/commons-math/blob/master/src/main/java/org/apache/commons/math4/complex/Complex.java - -(type: #export Complex - {#real Real - #imaginary Real}) - -(syntax: #export (complex real [?imaginary (s;opt s;any)]) - {#;doc (doc "Complex literals." - (complex real imaginary) - "The imaginary part can be omitted if it's 0." - (complex real))} - (wrap (list (` {#;;real (~ real) - #;;imaginary (~ (default (' 0.0) - ?imaginary))})))) - -(def: #export i Complex (complex 0.0 1.0)) - -(def: #export one Complex (complex 1.0 0.0)) - -(def: #export zero Complex (complex 0.0 0.0)) - -(def: #export (not-a-number? complex) - (or (number;not-a-number? (get@ #real complex)) - (number;not-a-number? (get@ #imaginary complex)))) - -(def: #export (c.= param input) - (-> Complex Complex Bool) - (and (r.= (get@ #real param) - (get@ #real input)) - (r.= (get@ #imaginary param) - (get@ #imaginary input)))) - -(do-template [ ] - [(def: #export ( param input) - (-> Complex Complex Complex) - {#real ( (get@ #real param) - (get@ #real input)) - #imaginary ( (get@ #imaginary param) - (get@ #imaginary input))})] - - [c.+ r.+] - [c.- r.-] - ) - -(struct: #export _ (Eq Complex) - (def: = c.=)) - -(def: #export c.negate - (-> Complex Complex) - (|>. (update@ #real r/negate) - (update@ #imaginary r/negate))) - -(def: #export c.signum - (-> Complex Complex) - (|>. (update@ #real r/signum) - (update@ #imaginary r/signum))) - -(def: #export conjugate - (-> Complex Complex) - (update@ #imaginary r/negate)) - -(def: #export (c.*' param input) - (-> Real Complex Complex) - {#real (r.* param - (get@ #real input)) - #imaginary (r.* param - (get@ #imaginary input))}) - -(def: #export (c.* param input) - (-> Complex Complex Complex) - {#real (r.- (r.* (get@ #imaginary param) - (get@ #imaginary input)) - (r.* (get@ #real param) - (get@ #real input))) - #imaginary (r.+ (r.* (get@ #real param) - (get@ #imaginary input)) - (r.* (get@ #imaginary param) - (get@ #real input)))}) - -(def: #export (c./ param input) - (-> Complex Complex Complex) - (let [(^slots [#real #imaginary]) param] - (if (r.< (r/abs imaginary) - (r/abs real)) - (let [quot (r./ imaginary real) - denom (|> real (r.* quot) (r.+ imaginary))] - {#real (|> (get@ #real input) (r.* quot) (r.+ (get@ #imaginary input)) (r./ denom)) - #imaginary (|> (get@ #imaginary input) (r.* quot) (r.- (get@ #real input)) (r./ denom))}) - (let [quot (r./ real imaginary) - denom (|> imaginary (r.* quot) (r.+ real))] - {#real (|> (get@ #imaginary input) (r.* quot) (r.+ (get@ #real input)) (r./ denom)) - #imaginary (|> (get@ #imaginary input) (r.- (r.* quot (get@ #real input))) (r./ denom))})))) - -(def: #export (c./' param subject) - (-> Real Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (r./ param real) - #imaginary (r./ param imaginary)})) - -(def: #export (c.% param input) - (-> Complex Complex Complex) - (let [scaled (c./ param input) - quotient (|> scaled - (update@ #real math;floor) - (update@ #imaginary math;floor))] - (c.- (c.* quotient param) - input))) - -(def: #export (cos subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (r.* (math;cosh imaginary) - (math;cos real)) - #imaginary (r.* (math;sinh imaginary) - (r/negate (math;sin real)))})) - -(def: #export (cosh subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (r.* (math;cos imaginary) - (math;cosh real)) - #imaginary (r.* (math;sin imaginary) - (math;sinh real))})) - -(def: #export (sin subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (r.* (math;cosh imaginary) - (math;sin real)) - #imaginary (r.* (math;sinh imaginary) - (math;cos real))})) - -(def: #export (sinh subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (r.* (math;cos imaginary) - (math;sinh real)) - #imaginary (r.* (math;sin imaginary) - (math;cosh real))})) - -(def: #export (tan subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject - r2 (r.* 2.0 real) - i2 (r.* 2.0 imaginary) - d (r.+ (math;cos r2) (math;cosh i2))] - {#real (r./ d (math;sin r2)) - #imaginary (r./ d (math;sinh i2))})) - -(def: #export (tanh subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject - r2 (r.* 2.0 real) - i2 (r.* 2.0 imaginary) - d (r.+ (math;cosh r2) (math;cos i2))] - {#real (r./ d (math;sinh r2)) - #imaginary (r./ d (math;sin i2))})) - -(def: #export (c.abs subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - (complex (if (r.< (r/abs imaginary) - (r/abs real)) - (if (r.= 0.0 imaginary) - (r/abs real) - (let [q (r./ imaginary real)] - (r.* (math;root2 (r.+ 1.0 (r.* q q))) - (r/abs imaginary)))) - (if (r.= 0.0 real) - (r/abs imaginary) - (let [q (r./ real imaginary)] - (r.* (math;root2 (r.+ 1.0 (r.* q q))) - (r/abs real)))) - )))) - -(struct: #export _ (Number Complex) - (def: + c.+) - (def: - c.-) - (def: * c.*) - (def: / c./) - (def: % c.%) - (def: (negate x) - (|> x - (update@ #real r/negate) - (update@ #imaginary r/negate))) - (def: abs c.abs) - (def: (signum x) - (|> x - (update@ #real r/signum) - (update@ #imaginary r/signum)))) - -(def: #export (exp subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject - r-exp (math;exp real)] - {#real (r.* r-exp (math;cos imaginary)) - #imaginary (r.* r-exp (math;sin imaginary))})) - -(def: #export (log subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (|> subject c.abs (get@ #real) math;log) - #imaginary (math;atan2 real imaginary)})) - -(do-template [ ] - [(def: #export ( param input) - (-> Complex Complex) - (|> input log ( param) exp))] - - [pow Complex c.*] - [pow' Real c.*'] - ) - -(def: (copy-sign sign magnitude) - (-> Real Real Real) - (r.* (r/signum sign) magnitude)) - -(def: #export (root2 (^@ input (^slots [#real #imaginary]))) - (-> Complex Complex) - (let [t (|> input c.abs (get@ #real) (r.+ (r/abs real)) (r./ 2.0) math;root2)] - (if (r.>= 0.0 real) - {#real t - #imaginary (r./ (r.* 2.0 t) - imaginary)} - {#real (r./ (r.* 2.0 t) - (r/abs imaginary)) - #imaginary (r.* t (copy-sign imaginary 1.0))}))) - -(def: #export (root2-1z input) - (-> Complex Complex) - (|> (complex 1.0) (c.- (c.* input input)) root2)) - -(def: #export (reciprocal (^slots [#real #imaginary])) - (-> Complex Complex) - (if (r.< (r/abs imaginary) - (r/abs real)) - (let [q (r./ imaginary real) - scale (r./ (|> real (r.* q) (r.+ imaginary)) - 1.0)] - {#real (r.* q scale) - #imaginary (r/negate scale)}) - (let [q (r./ real imaginary) - scale (r./ (|> imaginary (r.* q) (r.+ real)) - 1.0)] - {#real scale - #imaginary (|> scale r/negate (r.* q))}))) - -(def: #export (acos input) - (-> Complex Complex) - (|> input - (c.+ (|> input root2-1z (c.* i))) - log - (c.* (c.negate i)))) - -(def: #export (asin input) - (-> Complex Complex) - (|> input - root2-1z - (c.+ (c.* i input)) - log - (c.* (c.negate i)))) - -(def: #export (atan input) - (-> Complex Complex) - (|> input - (c.+ i) - (c./ (c.- input i)) - log - (c.* (c./ (complex 2.0) i)))) - -(def: #export (argument (^slots [#real #imaginary])) - (-> Complex Real) - (math;atan2 real imaginary)) - -(def: #export (nth-roots nth input) - (-> Nat Complex (List Complex)) - (if (n.= +0 nth) - (list) - (let [r-nth (|> nth nat-to-int int-to-real) - nth-root-of-abs (|> input c.abs (get@ #real) (math;pow (r./ r-nth 1.0))) - nth-phi (|> input argument (r./ r-nth)) - slice (|> math;pi (r.* 2.0) (r./ r-nth))] - (|> (list;n.range +0 (n.dec nth)) - (List/map (lambda [nth'] - (let [inner (|> nth' nat-to-int int-to-real - (r.* slice) - (r.+ nth-phi)) - real (r.* nth-root-of-abs - (math;cos inner)) - imaginary (r.* nth-root-of-abs - (math;sin inner))] - {#real real - #imaginary imaginary}))))))) - -(struct: #export _ (Codec Text Complex) - (def: (encode (^slots [#real #imaginary])) - ($_ Text/append "(" (r/encode real) ", " (r/encode imaginary) ")")) - - (def: (decode input) - (case (do Monad - [input' (text;clip +1 (n.- +1 (text;size input)) input)] - (text;split-with "," input')) - #;None - (#;Left (Text/append "Wrong syntax for complex numbers: " input)) - - (#;Some [r' i']) - (do Monad - [r (r/decode (text;trim r')) - i (r/decode (text;trim i'))] - (wrap {#real r - #imaginary i})) - ))) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux new file mode 100644 index 000000000..e828cb715 --- /dev/null +++ b/stdlib/source/lux/math/random.lux @@ -0,0 +1,303 @@ +(;module: {#;doc "Pseudo-random number generation (PRNG) algorithms."} + [lux #- list] + (lux (control functor + applicative + monad + hash) + (data [bit] + [char] + [text "Text/" Monoid] + text/format + [product] + [number] + (number ["r" ratio] + ["c" complex]) + (coll [list "List/" Fold] + ["A" array] + ["D" dict] + ["Q" queue] + ["S" set] + ["ST" stack] + ["V" vector])) + )) + +## [Exports] +(type: #export #rec PRNG + {#;doc "An abstract way to represent any PRNG."} + (-> Unit [PRNG Nat])) + +(type: #export (Random a) + {#;doc "A producer of random values based on a PRNG."} + (-> PRNG [PRNG a])) + +(struct: #export _ (Functor Random) + (def: (map f fa) + (lambda [state] + (let [[state' a] (fa state)] + [state' (f a)])))) + +(struct: #export _ (Applicative Random) + (def: functor Functor) + + (def: (wrap a) + (lambda [state] + [state a])) + + (def: (apply ff fa) + (lambda [state] + (let [[state' f] (ff state) + [state'' a] (fa state')] + [state'' (f a)])))) + +(struct: #export _ (Monad Random) + (def: applicative Applicative) + + (def: (join ffa) + (lambda [state] + (let [[state' fa] (ffa state)] + (fa state'))))) + +(def: #export nat + (Random Nat) + (lambda [prng] + (let [[prng left] (prng []) + [prng right] (prng [])] + [prng (n.+ (bit;<< +32 left) + right)]))) + +(def: #export int + (Random Int) + (lambda [prng] + (let [[prng left] (prng []) + [prng right] (prng [])] + [prng (nat-to-int (n.+ (bit;<< +32 left) + right))]))) + +(def: #export bool + (Random Bool) + (lambda [prng] + (let [[prng output] (prng [])] + [prng (|> output (bit;& +1) (n.= +1))]))) + +(def: (bits n) + (-> Nat (Random Nat)) + (lambda [prng] + (let [[prng output] (prng [])] + [prng (bit;>>> (n.- n +64) output)]))) + +(def: #export real + (Random Real) + (do Monad + [left (bits +26) + right (bits +27)] + (wrap (|> right + (n.+ (bit;<< +27 left)) + nat-to-int + int-to-real + (r./ (|> +1 (bit;<< +53) nat-to-int int-to-real)))))) + +(def: #export deg + (Random Deg) + (:: Monad map real-to-deg real)) + +(def: #export char + (Random Char) + (do Monad + [base nat] + (wrap (char;char base)))) + +(def: #export (text' char-gen size) + (-> (Random Char) Nat (Random Text)) + (if (n.= +0 size) + (:: Monad wrap "") + (do Monad + [x char-gen + xs (text' char-gen (n.dec size))] + (wrap (Text/append (char;as-text x) xs))))) + +(def: #export (text size) + (-> Nat (Random Text)) + (text' char size)) + +(do-template [ ] + [(def: #export + (Random ) + (do Monad + [left + right ] + (wrap ( left right))))] + + [ratio r;Ratio r;ratio nat] + [complex c;Complex c;complex real] + ) + +(def: #export (seq left right) + {#;doc "Sequencing combinator."} + (All [a b] (-> (Random a) (Random b) (Random [a b]))) + (do Monad + [=left left + =right right] + (wrap [=left =right]))) + +(def: #export (alt left right) + {#;doc "Heterogeneous alternative combinator."} + (All [a b] (-> (Random a) (Random b) (Random (| a b)))) + (do Monad + [? bool] + (if ? + (do @ + [=left left] + (wrap (+0 =left))) + (do @ + [=right right] + (wrap (+1 =right)))))) + +(def: #export (either left right) + {#;doc "Homogeneous alternative combinator."} + (All [a] (-> (Random a) (Random a) (Random a))) + (do Monad + [? bool] + (if ? + left + right))) + +(def: #export (rec gen) + {#;doc "A combinator for producing recursive random generators."} + (All [a] (-> (-> (Random a) (Random a)) (Random a))) + (lambda [state] + (let [gen' (gen (rec gen))] + (gen' state)))) + +(def: #export (filter pred gen) + {#;doc "Retries the generator until the output satisfies a predicate."} + (All [a] (-> (-> a Bool) (Random a) (Random a))) + (do Monad + [sample gen] + (if (pred sample) + (wrap sample) + (filter pred gen)))) + +(def: #export (maybe value-gen) + (All [a] (-> (Random a) (Random (Maybe a)))) + (do Monad + [some? bool] + (if some? + (do @ + [value value-gen] + (wrap (#;Some value))) + (wrap #;None)))) + +(do-template [ ] + [(def: #export ( size value-gen) + (All [a] (-> Nat (Random a) (Random ( a)))) + (if (n.> +0 size) + (do Monad + [x value-gen + xs ( (n.dec size) value-gen)] + (wrap ( x xs))) + (:: Monad wrap )))] + + [list List (;list) #;Cons] + [vector V;Vector V;empty V;add] + ) + +(do-template [ ] + [(def: #export ( size value-gen) + (All [a] (-> Nat (Random a) (Random ( a)))) + (do Monad + [values (list size value-gen)] + (wrap (|> values ))))] + + [array A;Array A;from-list] + [queue Q;Queue Q;from-list] + [stack ST;Stack (List/fold ST;push ST;empty)] + ) + +(def: #export (set Hash size value-gen) + (All [a] (-> (Hash a) Nat (Random a) (Random (S;Set a)))) + (if (n.> +0 size) + (do Monad + [xs (set Hash (n.dec size) value-gen)] + (loop [_ []] + (do @ + [x value-gen + #let [xs+ (S;add x xs)]] + (if (n.= size (S;size xs+)) + (wrap xs+) + (recur []))))) + (:: Monad wrap (S;new Hash)))) + +(def: #export (dict Hash size key-gen value-gen) + (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (D;Dict k v)))) + (if (n.> +0 size) + (do Monad + [kv (dict Hash (n.dec size) key-gen value-gen)] + (loop [_ []] + (do @ + [k key-gen + v value-gen + #let [kv+ (D;put k v kv)]] + (if (n.= size (D;size kv+)) + (wrap kv+) + (recur []))))) + (:: Monad wrap (D;new Hash)))) + +(def: #export (run prng calc) + (All [a] (-> PRNG (Random a) [PRNG a])) + (calc prng)) + +## [PRNGs] +## PCG32 http://www.pcg-random.org/ +## Based on this Java implementation: https://github.com/alexeyr/pcg-java + +(def: pcg-32-magic-mult Nat +6364136223846793005) + +(def: #export (pcg-32 [inc seed]) + {#;doc "An implementation of the PCG32 algorithm. + + For more information, please see: http://www.pcg-random.org/"} + (-> [Nat Nat] PRNG) + (lambda [_] + (let [seed' (|> seed (n.* pcg-32-magic-mult) (n.+ inc)) + xor-shifted (|> seed (bit;>>> +18) (bit;^ seed) (bit;>>> +27)) + rot (|> seed (bit;>>> +59))] + [(pcg-32 [inc seed']) (bit;rotate-right rot xor-shifted)] + ))) + +## Xoroshiro128+ http://xoroshiro.di.unimi.it/ +(def: #export (xoroshiro-128+ [s0 s1]) + {#;doc "An implementation of the Xoroshiro128+ algorithm. + + For more information, please see: http://xoroshiro.di.unimi.it/"} + (-> [Nat Nat] PRNG) + (lambda [_] + (let [result (n.+ s0 s1) + s01 (bit;^ s0 s1) + s0' (|> (bit;rotate-left +55 s0) + (bit;^ s01) + (bit;^ (bit;<< +14 s01))) + s1' (bit;rotate-left +36 s01)] + [(xoroshiro-128+ [s0' s1']) result]) + )) + +## [Values] +(def: (swap from to vec) + (All [a] (-> Nat Nat (V;Vector a) (V;Vector a))) + (V;put to (default (undefined) + (V;nth from vec)) + vec)) + +(def: #export (shuffle seed vector) + {#;doc "Shuffle a vector randomly based on a seed value."} + (All [a] (-> Nat (V;Vector a) (V;Vector a))) + (let [_size (V;size vector) + _shuffle (foldM Monad + (lambda [idx vec] + (do Monad + [rand nat] + (wrap (swap idx (n.% _size rand) vec)))) + vector + (list;n.range +0 (n.dec _size)))] + (|> _shuffle + (run (pcg-32 [+123 seed])) + product;right))) diff --git a/stdlib/source/lux/math/ratio.lux b/stdlib/source/lux/math/ratio.lux deleted file mode 100644 index fb86b1fed..000000000 --- a/stdlib/source/lux/math/ratio.lux +++ /dev/null @@ -1,158 +0,0 @@ -(;module: {#;doc "Rational arithmetic."} - lux - (lux [math] - (control eq - [ord] - number - codec - monad) - (data [number "n/" Number Codec] - [text "Text/" Monoid] - text/format - error - [product]) - [compiler] - (macro [ast] - ["s" syntax #+ syntax: Syntax]))) - -(type: #export Ratio - {#numerator Nat - #denominator Nat}) - -(def: #hidden (normalize (^slots [#numerator #denominator])) - (-> Ratio Ratio) - (let [common (math;gcd numerator denominator)] - {#numerator (n./ common numerator) - #denominator (n./ common denominator)})) - -(def: #export (q.* param input) - (-> Ratio Ratio Ratio) - (normalize [(n.* (get@ #numerator param) - (get@ #numerator input)) - (n.* (get@ #denominator param) - (get@ #denominator input))])) - -(def: #export (q./ param input) - (-> Ratio Ratio Ratio) - (normalize [(n.* (get@ #denominator param) - (get@ #numerator input)) - (n.* (get@ #numerator param) - (get@ #denominator input))])) - -(def: #export (q.+ param input) - (-> Ratio Ratio Ratio) - (normalize [(n.+ (n.* (get@ #denominator input) - (get@ #numerator param)) - (n.* (get@ #denominator param) - (get@ #numerator input))) - (n.* (get@ #denominator param) - (get@ #denominator input))])) - -(def: #export (q.- param input) - (-> Ratio Ratio Ratio) - (normalize [(n.- (n.* (get@ #denominator input) - (get@ #numerator param)) - (n.* (get@ #denominator param) - (get@ #numerator input))) - (n.* (get@ #denominator param) - (get@ #denominator input))])) - -(def: #export (q.% param input) - (-> Ratio Ratio Ratio) - (let [quot (n./ (n.* (get@ #denominator input) - (get@ #numerator param)) - (n.* (get@ #denominator param) - (get@ #numerator input)))] - (q.- (update@ #numerator (n.* quot) param) - input))) - -(def: #export (q.= param input) - (-> Ratio Ratio Bool) - (and (n.= (get@ #numerator param) - (get@ #numerator input)) - (n.= (get@ #denominator param) - (get@ #denominator input)))) - -(do-template [ ] - [(def: #export ( param input) - (-> Ratio Ratio Bool) - (and ( (n.* (get@ #denominator input) - (get@ #numerator param)) - (n.* (get@ #denominator param) - (get@ #numerator input)))))] - - [q.< n.<] - [q.<= n.<=] - [q.> n.>] - [q.>= n.>=] - ) - -(do-template [ ] - [(def: #export ( left right) - (-> Ratio Ratio Ratio) - (if ( left right) - right - left))] - - [q.min q.<] - [q.max q.>] - ) - -(struct: #export _ (Eq Ratio) - (def: = q.=)) - -(struct: #export _ (ord;Ord Ratio) - (def: eq Eq) - (def: < q.<) - (def: <= q.<=) - (def: > q.>) - (def: >= q.>=)) - -(struct: #export _ (Number Ratio) - (def: + q.+) - (def: - q.-) - (def: * q.*) - (def: / q./) - (def: % q.%) - (def: (negate (^slots [#numerator #denominator])) - {#numerator denominator - #denominator numerator}) - (def: abs id) - (def: (signum x) - {#numerator +1 - #denominator +1})) - -(def: separator Text ":") - -(def: part-encode - (-> Nat Text) - (|>. n/encode (text;split +1) (default (undefined)) product;right)) - -(def: part-decode - (-> Text (Error Nat)) - (|>. (format "+") n/decode)) - -(struct: #export _ (Codec Text Ratio) - (def: (encode (^slots [#numerator #denominator])) - ($_ Text/append (part-encode numerator) separator (part-encode denominator))) - - (def: (decode input) - (case (text;split-with separator input) - (#;Some [num denom]) - (do Monad - [numerator (part-decode num) - denominator (part-decode denom)] - (wrap (normalize {#numerator numerator - #denominator denominator}))) - - #;None - (#;Left (Text/append "Invalid syntax for ratio: " input))))) - -(syntax: #export (ratio numerator [?denominator (s;opt 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 (~ (default (' +1) - ?denominator))}))))) diff --git a/stdlib/source/lux/random.lux b/stdlib/source/lux/random.lux deleted file mode 100644 index 4cbc2b57b..000000000 --- a/stdlib/source/lux/random.lux +++ /dev/null @@ -1,302 +0,0 @@ -(;module: {#;doc "Pseudo-random number generation (PRNG) algorithms."} - [lux #- list] - (lux (control functor - applicative - monad - hash) - (data [bit] - [char] - [text "Text/" Monoid] - text/format - [product] - [number] - (coll [list "List/" Fold] - ["A" array] - ["D" dict] - ["Q" queue] - ["S" set] - ["ST" stack] - ["V" vector])) - (math ["r" ratio] - ["c" complex]))) - -## [Exports] -(type: #export #rec PRNG - {#;doc "An abstract way to represent any PRNG."} - (-> Unit [PRNG Nat])) - -(type: #export (Random a) - {#;doc "A producer of random values based on a PRNG."} - (-> PRNG [PRNG a])) - -(struct: #export _ (Functor Random) - (def: (map f fa) - (lambda [state] - (let [[state' a] (fa state)] - [state' (f a)])))) - -(struct: #export _ (Applicative Random) - (def: functor Functor) - - (def: (wrap a) - (lambda [state] - [state a])) - - (def: (apply ff fa) - (lambda [state] - (let [[state' f] (ff state) - [state'' a] (fa state')] - [state'' (f a)])))) - -(struct: #export _ (Monad Random) - (def: applicative Applicative) - - (def: (join ffa) - (lambda [state] - (let [[state' fa] (ffa state)] - (fa state'))))) - -(def: #export nat - (Random Nat) - (lambda [prng] - (let [[prng left] (prng []) - [prng right] (prng [])] - [prng (n.+ (bit;<< +32 left) - right)]))) - -(def: #export int - (Random Int) - (lambda [prng] - (let [[prng left] (prng []) - [prng right] (prng [])] - [prng (nat-to-int (n.+ (bit;<< +32 left) - right))]))) - -(def: #export bool - (Random Bool) - (lambda [prng] - (let [[prng output] (prng [])] - [prng (|> output (bit;& +1) (n.= +1))]))) - -(def: (bits n) - (-> Nat (Random Nat)) - (lambda [prng] - (let [[prng output] (prng [])] - [prng (bit;>>> (n.- n +64) output)]))) - -(def: #export real - (Random Real) - (do Monad - [left (bits +26) - right (bits +27)] - (wrap (|> right - (n.+ (bit;<< +27 left)) - nat-to-int - int-to-real - (r./ (|> +1 (bit;<< +53) nat-to-int int-to-real)))))) - -(def: #export deg - (Random Deg) - (:: Monad map real-to-deg real)) - -(def: #export char - (Random Char) - (do Monad - [base nat] - (wrap (char;char base)))) - -(def: #export (text' char-gen size) - (-> (Random Char) Nat (Random Text)) - (if (n.= +0 size) - (:: Monad wrap "") - (do Monad - [x char-gen - xs (text' char-gen (n.dec size))] - (wrap (Text/append (char;as-text x) xs))))) - -(def: #export (text size) - (-> Nat (Random Text)) - (text' char size)) - -(do-template [ ] - [(def: #export - (Random ) - (do Monad - [left - right ] - (wrap ( left right))))] - - [ratio r;Ratio r;ratio nat] - [complex c;Complex c;complex real] - ) - -(def: #export (seq left right) - {#;doc "Sequencing combinator."} - (All [a b] (-> (Random a) (Random b) (Random [a b]))) - (do Monad - [=left left - =right right] - (wrap [=left =right]))) - -(def: #export (alt left right) - {#;doc "Heterogeneous alternative combinator."} - (All [a b] (-> (Random a) (Random b) (Random (| a b)))) - (do Monad - [? bool] - (if ? - (do @ - [=left left] - (wrap (+0 =left))) - (do @ - [=right right] - (wrap (+1 =right)))))) - -(def: #export (either left right) - {#;doc "Homogeneous alternative combinator."} - (All [a] (-> (Random a) (Random a) (Random a))) - (do Monad - [? bool] - (if ? - left - right))) - -(def: #export (rec gen) - {#;doc "A combinator for producing recursive random generators."} - (All [a] (-> (-> (Random a) (Random a)) (Random a))) - (lambda [state] - (let [gen' (gen (rec gen))] - (gen' state)))) - -(def: #export (filter pred gen) - {#;doc "Retries the generator until the output satisfies a predicate."} - (All [a] (-> (-> a Bool) (Random a) (Random a))) - (do Monad - [sample gen] - (if (pred sample) - (wrap sample) - (filter pred gen)))) - -(def: #export (maybe value-gen) - (All [a] (-> (Random a) (Random (Maybe a)))) - (do Monad - [some? bool] - (if some? - (do @ - [value value-gen] - (wrap (#;Some value))) - (wrap #;None)))) - -(do-template [ ] - [(def: #export ( size value-gen) - (All [a] (-> Nat (Random a) (Random ( a)))) - (if (n.> +0 size) - (do Monad - [x value-gen - xs ( (n.dec size) value-gen)] - (wrap ( x xs))) - (:: Monad wrap )))] - - [list List (;list) #;Cons] - [vector V;Vector V;empty V;add] - ) - -(do-template [ ] - [(def: #export ( size value-gen) - (All [a] (-> Nat (Random a) (Random ( a)))) - (do Monad - [values (list size value-gen)] - (wrap (|> values ))))] - - [array A;Array A;from-list] - [queue Q;Queue Q;from-list] - [stack ST;Stack (List/fold ST;push ST;empty)] - ) - -(def: #export (set Hash size value-gen) - (All [a] (-> (Hash a) Nat (Random a) (Random (S;Set a)))) - (if (n.> +0 size) - (do Monad - [xs (set Hash (n.dec size) value-gen)] - (loop [_ []] - (do @ - [x value-gen - #let [xs+ (S;add x xs)]] - (if (n.= size (S;size xs+)) - (wrap xs+) - (recur []))))) - (:: Monad wrap (S;new Hash)))) - -(def: #export (dict Hash size key-gen value-gen) - (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (D;Dict k v)))) - (if (n.> +0 size) - (do Monad - [kv (dict Hash (n.dec size) key-gen value-gen)] - (loop [_ []] - (do @ - [k key-gen - v value-gen - #let [kv+ (D;put k v kv)]] - (if (n.= size (D;size kv+)) - (wrap kv+) - (recur []))))) - (:: Monad wrap (D;new Hash)))) - -(def: #export (run prng calc) - (All [a] (-> PRNG (Random a) [PRNG a])) - (calc prng)) - -## [PRNGs] -## PCG32 http://www.pcg-random.org/ -## Based on this Java implementation: https://github.com/alexeyr/pcg-java - -(def: pcg-32-magic-mult Nat +6364136223846793005) - -(def: #export (pcg-32 [inc seed]) - {#;doc "An implementation of the PCG32 algorithm. - - For more information, please see: http://www.pcg-random.org/"} - (-> [Nat Nat] PRNG) - (lambda [_] - (let [seed' (|> seed (n.* pcg-32-magic-mult) (n.+ inc)) - xor-shifted (|> seed (bit;>>> +18) (bit;^ seed) (bit;>>> +27)) - rot (|> seed (bit;>>> +59))] - [(pcg-32 [inc seed']) (bit;rotate-right rot xor-shifted)] - ))) - -## Xoroshiro128+ http://xoroshiro.di.unimi.it/ -(def: #export (xoroshiro-128+ [s0 s1]) - {#;doc "An implementation of the Xoroshiro128+ algorithm. - - For more information, please see: http://xoroshiro.di.unimi.it/"} - (-> [Nat Nat] PRNG) - (lambda [_] - (let [result (n.+ s0 s1) - s01 (bit;^ s0 s1) - s0' (|> (bit;rotate-left +55 s0) - (bit;^ s01) - (bit;^ (bit;<< +14 s01))) - s1' (bit;rotate-left +36 s01)] - [(xoroshiro-128+ [s0' s1']) result]) - )) - -## [Values] -(def: (swap from to vec) - (All [a] (-> Nat Nat (V;Vector a) (V;Vector a))) - (V;put to (default (undefined) - (V;nth from vec)) - vec)) - -(def: #export (shuffle seed vector) - {#;doc "Shuffle a vector randomly based on a seed value."} - (All [a] (-> Nat (V;Vector a) (V;Vector a))) - (let [_size (V;size vector) - _shuffle (foldM Monad - (lambda [idx vec] - (do Monad - [rand nat] - (wrap (swap idx (n.% _size rand) vec)))) - vector - (list;n.range +0 (n.dec _size)))] - (|> _shuffle - (run (pcg-32 [+123 seed])) - product;right))) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index d953b7d65..94a77d8cf 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -13,7 +13,7 @@ text/format [error #- fail "Error/" Monad]) [io #- run] - ["R" random])) + ["R" math/random])) ## [Host] (def: now diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index 92ed5e2ca..225467526 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -4,7 +4,7 @@ (lux (control monad) [io] [math] - ["R" random] + ["R" math/random] (data [text "T/" Eq] text/format) [compiler] diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux index 39cb8e74a..e8dbf1f82 100644 --- a/stdlib/test/test/lux/cli.lux +++ b/stdlib/test/test/lux/cli.lux @@ -10,7 +10,7 @@ (coll [list])) (codata function) ["&" cli] - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/codata/coll/stream.lux b/stdlib/test/test/lux/codata/coll/stream.lux index 36f7227a9..4c69f9f7b 100644 --- a/stdlib/test/test/lux/codata/coll/stream.lux +++ b/stdlib/test/test/lux/codata/coll/stream.lux @@ -10,7 +10,7 @@ (codata function [cont] (coll ["&" stream])) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/codata/cont.lux b/stdlib/test/test/lux/codata/cont.lux index 2562da8f8..cef7661b0 100644 --- a/stdlib/test/test/lux/codata/cont.lux +++ b/stdlib/test/test/lux/codata/cont.lux @@ -8,7 +8,7 @@ [product]) (codata function ["&" cont]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/codata/thunk.lux b/stdlib/test/test/lux/codata/thunk.lux index 789805319..eb6a24701 100644 --- a/stdlib/test/test/lux/codata/thunk.lux +++ b/stdlib/test/test/lux/codata/thunk.lux @@ -4,7 +4,7 @@ (control monad) (codata ["&" thunk]) pipe - ["R" random]) + ["R" math/random]) lux/test) (test: "Thunks" diff --git a/stdlib/test/test/lux/concurrency/atom.lux b/stdlib/test/test/lux/concurrency/atom.lux index f59b9ce6d..9b6248ec8 100644 --- a/stdlib/test/test/lux/concurrency/atom.lux +++ b/stdlib/test/test/lux/concurrency/atom.lux @@ -6,7 +6,7 @@ (coll [list "" Functor]) text/format) (concurrency ["&" atom]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/concurrency/promise.lux b/stdlib/test/test/lux/concurrency/promise.lux index c5ba46d7d..d75d6d676 100644 --- a/stdlib/test/test/lux/concurrency/promise.lux +++ b/stdlib/test/test/lux/concurrency/promise.lux @@ -7,7 +7,7 @@ [error #- fail]) (concurrency ["&" promise]) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/concurrency/stm.lux b/stdlib/test/test/lux/concurrency/stm.lux index 10c6a5242..f9e46b91d 100644 --- a/stdlib/test/test/lux/concurrency/stm.lux +++ b/stdlib/test/test/lux/concurrency/stm.lux @@ -8,7 +8,7 @@ (concurrency ["&" stm] [promise]) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/bit.lux b/stdlib/test/test/lux/data/bit.lux index 72973a5e7..0c9f5ac3d 100644 --- a/stdlib/test/test/lux/data/bit.lux +++ b/stdlib/test/test/lux/data/bit.lux @@ -4,7 +4,7 @@ (control [monad]) (data ["&" bit] number) - ["R" random]) + ["R" math/random]) lux/test) (def: width Nat +64) diff --git a/stdlib/test/test/lux/data/bool.lux b/stdlib/test/test/lux/data/bool.lux index d9052db57..51e499779 100644 --- a/stdlib/test/test/lux/data/bool.lux +++ b/stdlib/test/test/lux/data/bool.lux @@ -3,7 +3,7 @@ (lux (control [monad]) [io] (data bool) - ["R" random]) + ["R" math/random]) lux/test) (test: "Boolean operations." diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux index 88a5d86ae..6b7175de7 100644 --- a/stdlib/test/test/lux/data/char.lux +++ b/stdlib/test/test/lux/data/char.lux @@ -5,7 +5,7 @@ (data char [text] text/format) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/array.lux b/stdlib/test/test/lux/data/coll/array.lux index e05afd1c3..b5003f703 100644 --- a/stdlib/test/test/lux/data/coll/array.lux +++ b/stdlib/test/test/lux/data/coll/array.lux @@ -5,7 +5,7 @@ (data (coll ["&" array] [list]) [number]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/dict.lux b/stdlib/test/test/lux/data/coll/dict.lux index 4378d4dab..ff36cc362 100644 --- a/stdlib/test/test/lux/data/coll/dict.lux +++ b/stdlib/test/test/lux/data/coll/dict.lux @@ -10,7 +10,7 @@ (coll ["&" dict] [list "List/" Fold Functor])) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/list.lux b/stdlib/test/test/lux/data/coll/list.lux index 823266319..e1705291a 100644 --- a/stdlib/test/test/lux/data/coll/list.lux +++ b/stdlib/test/test/lux/data/coll/list.lux @@ -7,7 +7,7 @@ [number] [bool] [product]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/queue.lux b/stdlib/test/test/lux/data/coll/queue.lux index 70444516c..fac5cef12 100644 --- a/stdlib/test/test/lux/data/coll/queue.lux +++ b/stdlib/test/test/lux/data/coll/queue.lux @@ -4,7 +4,7 @@ (control monad) (data (coll ["&" queue]) [number]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/set.lux b/stdlib/test/test/lux/data/coll/set.lux index 42c3959b8..2a4f05bb1 100644 --- a/stdlib/test/test/lux/data/coll/set.lux +++ b/stdlib/test/test/lux/data/coll/set.lux @@ -5,7 +5,7 @@ (data (coll ["&" set] [list "" Fold]) [number]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/stack.lux b/stdlib/test/test/lux/data/coll/stack.lux index ec6fb2b50..4c44cbf06 100644 --- a/stdlib/test/test/lux/data/coll/stack.lux +++ b/stdlib/test/test/lux/data/coll/stack.lux @@ -5,7 +5,7 @@ (data (coll ["&" stack] [list "" Fold]) [number]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/tree/rose.lux b/stdlib/test/test/lux/data/coll/tree/rose.lux index 018164b8b..ef43fae44 100644 --- a/stdlib/test/test/lux/data/coll/tree/rose.lux +++ b/stdlib/test/test/lux/data/coll/tree/rose.lux @@ -5,7 +5,7 @@ (data (coll (tree ["&" rose]) [list "List/" Monad]) [number]) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/tree/zipper.lux b/stdlib/test/test/lux/data/coll/tree/zipper.lux index 5a8a3aee3..888701bbe 100644 --- a/stdlib/test/test/lux/data/coll/tree/zipper.lux +++ b/stdlib/test/test/lux/data/coll/tree/zipper.lux @@ -9,7 +9,7 @@ text/format [number]) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/coll/vector.lux b/stdlib/test/test/lux/data/coll/vector.lux index 9b3edf078..c82493df0 100644 --- a/stdlib/test/test/lux/data/coll/vector.lux +++ b/stdlib/test/test/lux/data/coll/vector.lux @@ -8,7 +8,7 @@ text/format [number]) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/error/exception.lux b/stdlib/test/test/lux/data/error/exception.lux index b2c417f75..96108e448 100644 --- a/stdlib/test/test/lux/data/error/exception.lux +++ b/stdlib/test/test/lux/data/error/exception.lux @@ -8,7 +8,7 @@ text/format [number]) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 7233e44e3..ad70d5c0e 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -20,7 +20,7 @@ (macro [ast] [syntax #+ syntax:] [poly #+ derived:]) - ["R" random] + ["R" math/random] pipe test) ) diff --git a/stdlib/test/test/lux/data/ident.lux b/stdlib/test/test/lux/data/ident.lux index a47a7ed0f..f88693003 100644 --- a/stdlib/test/test/lux/data/ident.lux +++ b/stdlib/test/test/lux/data/ident.lux @@ -5,7 +5,7 @@ (data ["&" ident] [text "Text/" Eq] text/format) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux index 6f296a628..8424c82a3 100644 --- a/stdlib/test/test/lux/data/number.lux +++ b/stdlib/test/test/lux/data/number.lux @@ -5,7 +5,7 @@ (data number [text "Text/" Monoid Eq] text/format) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/data/number/complex.lux b/stdlib/test/test/lux/data/number/complex.lux new file mode 100644 index 000000000..f5c89d5ee --- /dev/null +++ b/stdlib/test/test/lux/data/number/complex.lux @@ -0,0 +1,200 @@ +(;module: + lux + (lux [io] + (control monad) + (data [text "Text/" Monoid] + text/format + [bool "b/" Eq] + [number "r/" Number] + ["&" number/complex] + (coll [list "List/" Fold Functor]) + [product]) + (codata function) + [math] + ["R" math/random] + pipe) + lux/test) + +## Based on org.apache.commons.math4.complex.Complex +## https://github.com/apache/commons-math/blob/master/src/test/java/org/apache/commons/math4/complex/ComplexTest.java + +(def: margin-of-error Real 1.0e-10) + +(def: (within? margin standard value) + (-> Real &;Complex &;Complex Bool) + (let [real-dist (r/abs (r.- (get@ #&;real standard) + (get@ #&;real value))) + imgn-dist (r/abs (r.- (get@ #&;imaginary standard) + (get@ #&;imaginary value)))] + (and (r.< margin real-dist) + (r.< margin imgn-dist)))) + +(def: gen-dim + (R;Random Real) + (do R;Monad + [factor (|> R;nat (:: @ map (|>. (n.% +1000) (n.max +1)))) + measure (|> R;real (R;filter (r.> 0.0)))] + (wrap (r.* (|> factor nat-to-int int-to-real) + measure)))) + +(def: gen-complex + (R;Random &;Complex) + (do R;Monad + [real gen-dim + imaginary gen-dim] + (wrap (&;complex real imaginary)))) + +(test: "Construction" + [real gen-dim + imaginary gen-dim] + ($_ seq + (assert "Can build and tear apart complex numbers" + (let [r+i (&;complex real imaginary)] + (and (r.= real (get@ #&;real r+i)) + (r.= imaginary (get@ #&;imaginary r+i))))) + + (assert "If either the real part or the imaginary part is NaN, the composite is NaN." + (and (&;not-a-number? (&;complex number;not-a-number imaginary)) + (&;not-a-number? (&;complex real number;not-a-number)))) + )) + +(test: "Absolute value" + [real gen-dim + imaginary gen-dim] + ($_ seq + (assert "Absolute value of complex >= absolute value of any of the parts." + (let [r+i (&;complex real imaginary) + abs (get@ #&;real (&;c.abs r+i))] + (and (r.>= (r/abs real) abs) + (r.>= (r/abs imaginary) abs)))) + + (assert "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value." + (and (number;not-a-number? (get@ #&;real (&;c.abs (&;complex number;not-a-number imaginary)))) + (number;not-a-number? (get@ #&;real (&;c.abs (&;complex real number;not-a-number)))))) + + (assert "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value." + (and (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;positive-infinity imaginary)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;positive-infinity)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;negative-infinity imaginary)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;negative-infinity)))))) + )) + +(test: "Addidion, substraction, multiplication and division" + [x gen-complex + y gen-complex + factor gen-dim] + ($_ seq + (assert "Adding 2 complex numbers is the same as adding their parts." + (let [z (&;c.+ y x)] + (and (&;c.= z + (&;complex (r.+ (get@ #&;real y) + (get@ #&;real x)) + (r.+ (get@ #&;imaginary y) + (get@ #&;imaginary x))))))) + + (assert "Subtracting 2 complex numbers is the same as adding their parts." + (let [z (&;c.- y x)] + (and (&;c.= z + (&;complex (r.- (get@ #&;real y) + (get@ #&;real x)) + (r.- (get@ #&;imaginary y) + (get@ #&;imaginary x))))))) + + (assert "Subtraction is the inverse of addition." + (and (|> x (&;c.+ y) (&;c.- y) (within? margin-of-error x)) + (|> x (&;c.- y) (&;c.+ y) (within? margin-of-error x)))) + + (assert "Division is the inverse of multiplication." + (|> x (&;c.* y) (&;c./ y) (within? margin-of-error x))) + + (assert "Scalar division is the inverse of scalar multiplication." + (|> x (&;c.*' factor) (&;c./' factor) (within? margin-of-error x))) + + (assert "If you subtract the remainder, all divisions must be exact." + (let [rem (&;c.% y x) + quotient (|> x (&;c.- rem) (&;c./ y)) + floored (|> quotient + (update@ #&;real math;floor) + (update@ #&;imaginary math;floor)) + (^open "&/") &;Codec] + (within? 0.000000000001 + x + (|> quotient (&;c.* y) (&;c.+ rem))))) + )) + +(test: "Conjugate, reciprocal, signum, negation" + [x gen-complex] + ($_ seq + (assert "Conjugate has same real part as original, and opposite of imaginary part." + (let [cx (&;conjugate x)] + (and (r.= (get@ #&;real x) + (get@ #&;real cx)) + (r.= (r/negate (get@ #&;imaginary x)) + (get@ #&;imaginary cx))))) + + (assert "The reciprocal functions is its own inverse." + (|> x &;reciprocal &;reciprocal (within? margin-of-error x))) + + (assert "x*(x^-1) = 1" + (|> x (&;c.* (&;reciprocal x)) (within? margin-of-error &;one))) + + (assert "Absolute value of signum is always root2(2), 1 or 0." + (let [signum-abs (|> x &;c.signum &;c.abs (get@ #&;real))] + (or (r.= 0.0 signum-abs) + (r.= 1.0 signum-abs) + (r.= (math;root2 2.0) signum-abs)))) + + (assert "Negation is its own inverse." + (let [there (&;c.negate x) + back-again (&;c.negate there)] + (and (not (&;c.= there x)) + (&;c.= back-again x)))) + + (assert "Negation doesn't change the absolute value." + (r.= (get@ #&;real (&;c.abs x)) + (get@ #&;real (&;c.abs (&;c.negate x))))) + )) + +## ## Don't know how to test complex trigonometry properly. +## (test: "Trigonometry" +## [x gen-complex] +## ($_ seq +## (assert "Arc-sine is the inverse of sine." +## (|> x &;sin &;asin (within? margin-of-error x))) + +## (assert "Arc-cosine is the inverse of cosine." +## (|> x &;cos &;acos (within? margin-of-error x))) + +## (assert "Arc-tangent is the inverse of tangent." +## (|> x &;tan &;atan (within? margin-of-error x)))) +## ) + +(test: "Power 2 and exponential/logarithm" + [x gen-complex] + ($_ seq + (assert "Square root is inverse of power 2.0" + (|> x (&;pow' 2.0) &;root2 (within? margin-of-error x))) + + (assert "Logarithm is inverse of exponentiation." + (|> x &;log &;exp (within? margin-of-error x))) + )) + +(test: "Complex roots" + [sample gen-complex + degree (|> R;nat (:: @ map (|>. (n.max +1) (n.% +5))))] + (assert "Can calculate the N roots for any complex number." + (|> sample + (&;nth-roots degree) + (List/map (&;pow' (|> degree nat-to-int int-to-real))) + (list;every? (within? margin-of-error sample))))) + +(test: "Codec" + [sample gen-complex + #let [(^open "c/") &;Codec]] + (assert "Can encode/decode complex numbers." + (|> sample c/encode c/decode + (case> (#;Right output) + (&;c.= sample output) + + _ + false)))) diff --git a/stdlib/test/test/lux/data/number/ratio.lux b/stdlib/test/test/lux/data/number/ratio.lux new file mode 100644 index 000000000..a082050f8 --- /dev/null +++ b/stdlib/test/test/lux/data/number/ratio.lux @@ -0,0 +1,107 @@ +(;module: + lux + (lux [io] + (control monad) + (data [text "Text/" Monoid] + text/format + [bool "b/" Eq] + [number "r/" Number] + ["&" number/ratio "&/" Number] + (coll [list "List/" Fold Functor]) + [product]) + (codata function) + ["R" math/random] + pipe) + lux/test) + +(def: gen-part + (R;Random Nat) + (|> R;nat (:: R;Monad map (|>. (n.% +1000) (n.max +1))))) + +(def: gen-ratio + (R;Random &;Ratio) + (do R;Monad + [numerator gen-part + denominator (|> gen-part + (R;filter (|>. (n.= +0) not)) + (R;filter (. not (n.= numerator))))] + (wrap (&;ratio numerator denominator)))) + +(test: "Normalization" + [denom1 gen-part + denom2 gen-part + sample gen-ratio] + ($_ seq + (assert "All zeroes are the same." + (&;q.= (&;ratio +0 denom1) + (&;ratio +0 denom2))) + + (assert "All ratios are built normalized." + (|> sample &;normalize (&;q.= sample))) + )) + +(test: "Arithmetic" + [x gen-ratio + y gen-ratio + #let [min (&;q.min x y) + max (&;q.max x y)]] + ($_ seq + (assert "Addition and subtraction are opposites." + (and (|> max (&;q.- min) (&;q.+ min) (&;q.= max)) + (|> max (&;q.+ min) (&;q.- min) (&;q.= max)))) + + (assert "Multiplication and division are opposites." + (and (|> max (&;q./ min) (&;q.* min) (&;q.= max)) + (|> max (&;q.* min) (&;q./ min) (&;q.= max)))) + + (assert "Modulus by a larger ratio doesn't change the value." + (|> min (&;q.% max) (&;q.= min))) + + (assert "Modulus by a smaller ratio results in a value smaller than the limit." + (|> max (&;q.% min) (&;q.< min))) + + (assert "Can get the remainder of a division." + (let [remainder (&;q.% min max) + multiple (&;q.- remainder max) + factor (&;q./ min multiple)] + (and (|> factor (get@ #&;denominator) (n.= +1)) + (|> factor (&;q.* min) (&;q.+ remainder) (&;q.= max))))) + )) + +(test: "Negation, absolute value and signum" + [sample gen-ratio] + ($_ seq + (assert "Negation is it's own inverse." + (let [there (&/negate sample) + back-again (&/negate there)] + (and (not (&;q.= there sample)) + (&;q.= back-again sample)))) + + (assert "All ratios are already at their absolute value." + (|> sample &/abs (&;q.= sample))) + + (assert "Signum is the identity." + (|> sample (&;q.* (&/signum sample)) (&;q.= sample))) + )) + +(test: "Order" + [x gen-ratio + y gen-ratio] + ($_ seq + (assert "Can compare ratios." + (and (or (&;q.<= y x) + (&;q.> y x)) + (or (&;q.>= y x) + (&;q.< y x)))) + )) + +(test: "Codec" + [sample gen-ratio + #let [(^open "&/") &;Codec]] + (assert "Can encode/decode ratios." + (|> sample &/encode &/decode + (case> (#;Right output) + (&;q.= sample output) + + _ + false)))) diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index 883ff0b2b..72e633847 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -8,7 +8,7 @@ [number] (coll [list])) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/effect.lux b/stdlib/test/test/lux/effect.lux index 62c46ecb1..38ca21ce1 100644 --- a/stdlib/test/test/lux/effect.lux +++ b/stdlib/test/test/lux/effect.lux @@ -6,7 +6,7 @@ (data [text] text/format) [macro] - ["R" random] + ["R" math/random] pipe effect) lux/test) diff --git a/stdlib/test/test/lux/host.js.lux b/stdlib/test/test/lux/host.js.lux index 4c2b55485..7d79b2b87 100644 --- a/stdlib/test/test/lux/host.js.lux +++ b/stdlib/test/test/lux/host.js.lux @@ -4,7 +4,7 @@ (control monad) (data text/format) ["&" host] - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/host.jvm.lux b/stdlib/test/test/lux/host.jvm.lux index 54e6cf4b9..ff875ec2a 100644 --- a/stdlib/test/test/lux/host.jvm.lux +++ b/stdlib/test/test/lux/host.jvm.lux @@ -8,7 +8,7 @@ [text "Text/" Eq]) (codata function) ["&" host #+ jvm-import class: interface: object] - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/lexer.lux b/stdlib/test/test/lux/lexer.lux index 5ce15a25b..0bfd8dec7 100644 --- a/stdlib/test/test/lux/lexer.lux +++ b/stdlib/test/test/lux/lexer.lux @@ -7,7 +7,7 @@ text/format [char "C/" Eq] (coll [list])) - ["R" random] + ["R" math/random] pipe ["&" lexer]) lux/test) diff --git a/stdlib/test/test/lux/lexer/regex.lux b/stdlib/test/test/lux/lexer/regex.lux index 5b1cce0dd..c5c21df2a 100644 --- a/stdlib/test/test/lux/lexer/regex.lux +++ b/stdlib/test/test/lux/lexer/regex.lux @@ -9,7 +9,7 @@ [compiler] (macro [ast] ["s" syntax #+ syntax:]) - ["R" random] + ["R" math/random] pipe [lexer] (lexer ["&" regex])) diff --git a/stdlib/test/test/lux/macro/ast.lux b/stdlib/test/test/lux/macro/ast.lux index e8ff5e1ef..58efc1b83 100644 --- a/stdlib/test/test/lux/macro/ast.lux +++ b/stdlib/test/test/lux/macro/ast.lux @@ -6,7 +6,7 @@ (data [text "T/" Eq] text/format [number]) - ["R" random] + ["R" math/random] pipe (macro ["&" ast])) lux/test) diff --git a/stdlib/test/test/lux/macro/poly/eq.lux b/stdlib/test/test/lux/macro/poly/eq.lux index f3821f880..c2f9c0ac1 100644 --- a/stdlib/test/test/lux/macro/poly/eq.lux +++ b/stdlib/test/test/lux/macro/poly/eq.lux @@ -8,7 +8,7 @@ [number "i/" Number] [char] [text]) - ["R" random] + ["R" math/random] pipe [macro] (macro [poly #+ derived:] diff --git a/stdlib/test/test/lux/macro/poly/functor.lux b/stdlib/test/test/lux/macro/poly/functor.lux index 5f525d692..b98d75c7a 100644 --- a/stdlib/test/test/lux/macro/poly/functor.lux +++ b/stdlib/test/test/lux/macro/poly/functor.lux @@ -9,7 +9,7 @@ [number "i/" Number] [char] [text]) - ["R" random] + ["R" math/random] pipe [macro] (macro [poly #+ derived:] diff --git a/stdlib/test/test/lux/macro/poly/text-encoder.lux b/stdlib/test/test/lux/macro/poly/text-encoder.lux index a79af3cff..ec312e62b 100644 --- a/stdlib/test/test/lux/macro/poly/text-encoder.lux +++ b/stdlib/test/test/lux/macro/poly/text-encoder.lux @@ -8,7 +8,7 @@ [number "i/" Number] [char] [text]) - ["R" random] + ["R" math/random] pipe [macro] (macro [poly #+ derived:] diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux index fe5b48993..329e16a0f 100644 --- a/stdlib/test/test/lux/macro/syntax.lux +++ b/stdlib/test/test/lux/macro/syntax.lux @@ -11,7 +11,7 @@ [ident] [error #- fail]) (codata function) - ["R" random] + ["R" math/random] pipe [compiler] (macro [ast] diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux index 769a6f889..b1c9b100e 100644 --- a/stdlib/test/test/lux/math.lux +++ b/stdlib/test/test/lux/math.lux @@ -9,7 +9,7 @@ (coll [list "List/" Fold Functor]) [product]) (codata function) - ["R" random] + ["R" math/random] pipe ["&" math]) lux/test) diff --git a/stdlib/test/test/lux/math/complex.lux b/stdlib/test/test/lux/math/complex.lux deleted file mode 100644 index f965f9214..000000000 --- a/stdlib/test/test/lux/math/complex.lux +++ /dev/null @@ -1,200 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data [text "Text/" Monoid] - text/format - [bool "b/" Eq] - [number "r/" Number] - (coll [list "List/" Fold Functor]) - [product]) - (codata function) - [math] - ["R" random] - pipe - ["&" math/complex]) - lux/test) - -## Based on org.apache.commons.math4.complex.Complex -## https://github.com/apache/commons-math/blob/master/src/test/java/org/apache/commons/math4/complex/ComplexTest.java - -(def: margin-of-error Real 1.0e-10) - -(def: (within? margin standard value) - (-> Real &;Complex &;Complex Bool) - (let [real-dist (r/abs (r.- (get@ #&;real standard) - (get@ #&;real value))) - imgn-dist (r/abs (r.- (get@ #&;imaginary standard) - (get@ #&;imaginary value)))] - (and (r.< margin real-dist) - (r.< margin imgn-dist)))) - -(def: gen-dim - (R;Random Real) - (do R;Monad - [factor (|> R;nat (:: @ map (|>. (n.% +1000) (n.max +1)))) - measure (|> R;real (R;filter (r.> 0.0)))] - (wrap (r.* (|> factor nat-to-int int-to-real) - measure)))) - -(def: gen-complex - (R;Random &;Complex) - (do R;Monad - [real gen-dim - imaginary gen-dim] - (wrap (&;complex real imaginary)))) - -(test: "Construction" - [real gen-dim - imaginary gen-dim] - ($_ seq - (assert "Can build and tear apart complex numbers" - (let [r+i (&;complex real imaginary)] - (and (r.= real (get@ #&;real r+i)) - (r.= imaginary (get@ #&;imaginary r+i))))) - - (assert "If either the real part or the imaginary part is NaN, the composite is NaN." - (and (&;not-a-number? (&;complex number;not-a-number imaginary)) - (&;not-a-number? (&;complex real number;not-a-number)))) - )) - -(test: "Absolute value" - [real gen-dim - imaginary gen-dim] - ($_ seq - (assert "Absolute value of complex >= absolute value of any of the parts." - (let [r+i (&;complex real imaginary) - abs (get@ #&;real (&;c.abs r+i))] - (and (r.>= (r/abs real) abs) - (r.>= (r/abs imaginary) abs)))) - - (assert "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value." - (and (number;not-a-number? (get@ #&;real (&;c.abs (&;complex number;not-a-number imaginary)))) - (number;not-a-number? (get@ #&;real (&;c.abs (&;complex real number;not-a-number)))))) - - (assert "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value." - (and (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;positive-infinity imaginary)))) - (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;positive-infinity)))) - (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;negative-infinity imaginary)))) - (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;negative-infinity)))))) - )) - -(test: "Addidion, substraction, multiplication and division" - [x gen-complex - y gen-complex - factor gen-dim] - ($_ seq - (assert "Adding 2 complex numbers is the same as adding their parts." - (let [z (&;c.+ y x)] - (and (&;c.= z - (&;complex (r.+ (get@ #&;real y) - (get@ #&;real x)) - (r.+ (get@ #&;imaginary y) - (get@ #&;imaginary x))))))) - - (assert "Subtracting 2 complex numbers is the same as adding their parts." - (let [z (&;c.- y x)] - (and (&;c.= z - (&;complex (r.- (get@ #&;real y) - (get@ #&;real x)) - (r.- (get@ #&;imaginary y) - (get@ #&;imaginary x))))))) - - (assert "Subtraction is the inverse of addition." - (and (|> x (&;c.+ y) (&;c.- y) (within? margin-of-error x)) - (|> x (&;c.- y) (&;c.+ y) (within? margin-of-error x)))) - - (assert "Division is the inverse of multiplication." - (|> x (&;c.* y) (&;c./ y) (within? margin-of-error x))) - - (assert "Scalar division is the inverse of scalar multiplication." - (|> x (&;c.*' factor) (&;c./' factor) (within? margin-of-error x))) - - (assert "If you subtract the remainder, all divisions must be exact." - (let [rem (&;c.% y x) - quotient (|> x (&;c.- rem) (&;c./ y)) - floored (|> quotient - (update@ #&;real math;floor) - (update@ #&;imaginary math;floor)) - (^open "&/") &;Codec] - (within? 0.000000000001 - x - (|> quotient (&;c.* y) (&;c.+ rem))))) - )) - -(test: "Conjugate, reciprocal, signum, negation" - [x gen-complex] - ($_ seq - (assert "Conjugate has same real part as original, and opposite of imaginary part." - (let [cx (&;conjugate x)] - (and (r.= (get@ #&;real x) - (get@ #&;real cx)) - (r.= (r/negate (get@ #&;imaginary x)) - (get@ #&;imaginary cx))))) - - (assert "The reciprocal functions is its own inverse." - (|> x &;reciprocal &;reciprocal (within? margin-of-error x))) - - (assert "x*(x^-1) = 1" - (|> x (&;c.* (&;reciprocal x)) (within? margin-of-error &;one))) - - (assert "Absolute value of signum is always root2(2), 1 or 0." - (let [signum-abs (|> x &;c.signum &;c.abs (get@ #&;real))] - (or (r.= 0.0 signum-abs) - (r.= 1.0 signum-abs) - (r.= (math;root2 2.0) signum-abs)))) - - (assert "Negation is its own inverse." - (let [there (&;c.negate x) - back-again (&;c.negate there)] - (and (not (&;c.= there x)) - (&;c.= back-again x)))) - - (assert "Negation doesn't change the absolute value." - (r.= (get@ #&;real (&;c.abs x)) - (get@ #&;real (&;c.abs (&;c.negate x))))) - )) - -## ## Don't know how to test complex trigonometry properly. -## (test: "Trigonometry" -## [x gen-complex] -## ($_ seq -## (assert "Arc-sine is the inverse of sine." -## (|> x &;sin &;asin (within? margin-of-error x))) - -## (assert "Arc-cosine is the inverse of cosine." -## (|> x &;cos &;acos (within? margin-of-error x))) - -## (assert "Arc-tangent is the inverse of tangent." -## (|> x &;tan &;atan (within? margin-of-error x)))) -## ) - -(test: "Power 2 and exponential/logarithm" - [x gen-complex] - ($_ seq - (assert "Square root is inverse of power 2.0" - (|> x (&;pow' 2.0) &;root2 (within? margin-of-error x))) - - (assert "Logarithm is inverse of exponentiation." - (|> x &;log &;exp (within? margin-of-error x))) - )) - -(test: "Complex roots" - [sample gen-complex - degree (|> R;nat (:: @ map (|>. (n.max +1) (n.% +5))))] - (assert "Can calculate the N roots for any complex number." - (|> sample - (&;nth-roots degree) - (List/map (&;pow' (|> degree nat-to-int int-to-real))) - (list;every? (within? margin-of-error sample))))) - -(test: "Codec" - [sample gen-complex - #let [(^open "c/") &;Codec]] - (assert "Can encode/decode complex numbers." - (|> sample c/encode c/decode - (case> (#;Right output) - (&;c.= sample output) - - _ - false)))) diff --git a/stdlib/test/test/lux/math/logic/continuous.lux b/stdlib/test/test/lux/math/logic/continuous.lux index 2c13e123e..ab907d6bd 100644 --- a/stdlib/test/test/lux/math/logic/continuous.lux +++ b/stdlib/test/test/lux/math/logic/continuous.lux @@ -3,7 +3,7 @@ (lux [io] (control monad) (codata function) - ["R" random] + ["R" math/random] pipe ["&" math/logic/continuous]) lux/test) diff --git a/stdlib/test/test/lux/math/logic/fuzzy.lux b/stdlib/test/test/lux/math/logic/fuzzy.lux index 5b25ecf44..45c54bb44 100644 --- a/stdlib/test/test/lux/math/logic/fuzzy.lux +++ b/stdlib/test/test/lux/math/logic/fuzzy.lux @@ -8,7 +8,7 @@ [bool "B/" Eq] [number] text/format) - ["R" random] + ["R" math/random] pipe (math/logic ["&" fuzzy] continuous)) @@ -94,7 +94,6 @@ ) (test: "Gaussian" - #seed +1485654865687 [deviation R;real center R;real #let [gaussian (&;gaussian deviation center)]] diff --git a/stdlib/test/test/lux/math/ratio.lux b/stdlib/test/test/lux/math/ratio.lux deleted file mode 100644 index 8af9127a1..000000000 --- a/stdlib/test/test/lux/math/ratio.lux +++ /dev/null @@ -1,107 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data [text "Text/" Monoid] - text/format - [bool "b/" Eq] - [number "r/" Number] - (coll [list "List/" Fold Functor]) - [product]) - (codata function) - ["R" random] - pipe - ["&" math/ratio "&/" Number]) - lux/test) - -(def: gen-part - (R;Random Nat) - (|> R;nat (:: R;Monad map (|>. (n.% +1000) (n.max +1))))) - -(def: gen-ratio - (R;Random &;Ratio) - (do R;Monad - [numerator gen-part - denominator (|> gen-part - (R;filter (|>. (n.= +0) not)) - (R;filter (. not (n.= numerator))))] - (wrap (&;ratio numerator denominator)))) - -(test: "Normalization" - [denom1 gen-part - denom2 gen-part - sample gen-ratio] - ($_ seq - (assert "All zeroes are the same." - (&;q.= (&;ratio +0 denom1) - (&;ratio +0 denom2))) - - (assert "All ratios are built normalized." - (|> sample &;normalize (&;q.= sample))) - )) - -(test: "Arithmetic" - [x gen-ratio - y gen-ratio - #let [min (&;q.min x y) - max (&;q.max x y)]] - ($_ seq - (assert "Addition and subtraction are opposites." - (and (|> max (&;q.- min) (&;q.+ min) (&;q.= max)) - (|> max (&;q.+ min) (&;q.- min) (&;q.= max)))) - - (assert "Multiplication and division are opposites." - (and (|> max (&;q./ min) (&;q.* min) (&;q.= max)) - (|> max (&;q.* min) (&;q./ min) (&;q.= max)))) - - (assert "Modulus by a larger ratio doesn't change the value." - (|> min (&;q.% max) (&;q.= min))) - - (assert "Modulus by a smaller ratio results in a value smaller than the limit." - (|> max (&;q.% min) (&;q.< min))) - - (assert "Can get the remainder of a division." - (let [remainder (&;q.% min max) - multiple (&;q.- remainder max) - factor (&;q./ min multiple)] - (and (|> factor (get@ #&;denominator) (n.= +1)) - (|> factor (&;q.* min) (&;q.+ remainder) (&;q.= max))))) - )) - -(test: "Negation, absolute value and signum" - [sample gen-ratio] - ($_ seq - (assert "Negation is it's own inverse." - (let [there (&/negate sample) - back-again (&/negate there)] - (and (not (&;q.= there sample)) - (&;q.= back-again sample)))) - - (assert "All ratios are already at their absolute value." - (|> sample &/abs (&;q.= sample))) - - (assert "Signum is the identity." - (|> sample (&;q.* (&/signum sample)) (&;q.= sample))) - )) - -(test: "Order" - [x gen-ratio - y gen-ratio] - ($_ seq - (assert "Can compare ratios." - (and (or (&;q.<= y x) - (&;q.> y x)) - (or (&;q.>= y x) - (&;q.< y x)))) - )) - -(test: "Codec" - [sample gen-ratio - #let [(^open "&/") &;Codec]] - (assert "Can encode/decode ratios." - (|> sample &/encode &/decode - (case> (#;Right output) - (&;q.= sample output) - - _ - false)))) diff --git a/stdlib/test/test/lux/math/simple.lux b/stdlib/test/test/lux/math/simple.lux index ddd914bdf..7a70ec1a6 100644 --- a/stdlib/test/test/lux/math/simple.lux +++ b/stdlib/test/test/lux/math/simple.lux @@ -9,7 +9,7 @@ (coll [list "List/" Fold Functor]) [product]) (codata function) - ["R" random] + ["R" math/random] pipe ["&" math/simple]) lux/test) diff --git a/stdlib/test/test/lux/pipe.lux b/stdlib/test/test/lux/pipe.lux index cf53335d3..383043ebb 100644 --- a/stdlib/test/test/lux/pipe.lux +++ b/stdlib/test/test/lux/pipe.lux @@ -8,7 +8,7 @@ identity [text "T/" Eq]) (codata function) - ["R" random] + ["R" math/random] pipe) lux/test) diff --git a/stdlib/test/test/lux/type.lux b/stdlib/test/test/lux/type.lux index 6d1f677c7..e9401c738 100644 --- a/stdlib/test/test/lux/type.lux +++ b/stdlib/test/test/lux/type.lux @@ -7,7 +7,7 @@ [number] maybe (coll [list])) - ["R" random] + ["R" math/random] pipe ["&" type]) lux/test) diff --git a/stdlib/test/test/lux/type/auto.lux b/stdlib/test/test/lux/type/auto.lux index dc28b8797..536e3b851 100644 --- a/stdlib/test/test/lux/type/auto.lux +++ b/stdlib/test/test/lux/type/auto.lux @@ -10,7 +10,7 @@ [bool "B/" Eq] maybe (coll [list])) - ["R" random] + ["R" math/random] pipe [type] type/auto) diff --git a/stdlib/test/test/lux/type/check.lux b/stdlib/test/test/lux/type/check.lux index 1e8f4c648..47904c41b 100644 --- a/stdlib/test/test/lux/type/check.lux +++ b/stdlib/test/test/lux/type/check.lux @@ -7,7 +7,7 @@ [number] maybe (coll [list])) - ["R" random] + ["R" math/random] pipe [type] ["&" type/check]) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index e3d0e15c3..ce01da97e 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -32,6 +32,8 @@ [log] [maybe] [number] + (number ["_;" ratio] + ["_;" complex]) [product] [sum] [text] @@ -49,9 +51,7 @@ (text [format]) ) ["_;" math] - (math ["_;" ratio] - ["_;" complex] - ## ["_;" random] + (math ## ["_;" random] ["_;" simple] (logic ["_;" continuous] ["_;" fuzzy])) -- cgit v1.2.3