From 748c868680683df1949f62aac274040ac5bf43da Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Jul 2018 23:40:48 -0400 Subject: Now implementing math functionality in stdlib instead of the compiler. --- .../default/phase/extension/analysis/common.lux | 23 ----- .../translation/scheme/extension/common.jvm.lux | 27 ----- stdlib/source/lux/data/number.lux | 25 ++--- stdlib/source/lux/math.lux | 115 +++------------------ stdlib/source/lux/math/infix.lux | 89 ++++++++++++++++ .../default/phase/analysis/procedure/common.lux | 31 ------ stdlib/test/test/lux/math.lux | 15 +-- 7 files changed, 123 insertions(+), 202 deletions(-) create mode 100644 stdlib/source/lux/math/infix.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux index d4e94a36f..437a54bbc 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux @@ -240,28 +240,6 @@ (bundle.install "size" (unary (type (Ex [a] (Array a))) Nat)) ))) -(def: bundle::math - Bundle - (<| (bundle.prefix "math") - (|> bundle.empty - (bundle.install "cos" (unary Frac Frac)) - (bundle.install "sin" (unary Frac Frac)) - (bundle.install "tan" (unary Frac Frac)) - (bundle.install "acos" (unary Frac Frac)) - (bundle.install "asin" (unary Frac Frac)) - (bundle.install "atan" (unary Frac Frac)) - (bundle.install "cosh" (unary Frac Frac)) - (bundle.install "sinh" (unary Frac Frac)) - (bundle.install "tanh" (unary Frac Frac)) - (bundle.install "exp" (unary Frac Frac)) - (bundle.install "log" (unary Frac Frac)) - (bundle.install "ceil" (unary Frac Frac)) - (bundle.install "floor" (unary Frac Frac)) - (bundle.install "round" (unary Frac Frac)) - (bundle.install "atan2" (binary Frac Frac Frac)) - (bundle.install "pow" (binary Frac Frac Frac)) - ))) - (def: atom::new Handler (function (_ extension-name analyse args) @@ -362,7 +340,6 @@ (dict.merge bundle::frac) (dict.merge bundle::text) (dict.merge bundle::array) - (dict.merge bundle::math) (dict.merge bundle::atom) (dict.merge bundle::box) (dict.merge bundle::process) diff --git a/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux index 9952a754d..a508dfabd 100644 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux @@ -250,32 +250,6 @@ (bundle.install "char" (binary text::char)) (bundle.install "clip" (trinary text::clip))))) -## [[Math]] -(def: (math::pow [subject param]) - Binary - (_.expt/2 param subject)) - -(def: math-func - (-> Text Unary) - (|>> _.global _.apply/1)) - -(def: bundle::math - Bundle - (<| (bundle.prefix "math") - (|> bundle.empty - (bundle.install "cos" (unary (math-func "cos"))) - (bundle.install "sin" (unary (math-func "sin"))) - (bundle.install "tan" (unary (math-func "tan"))) - (bundle.install "acos" (unary (math-func "acos"))) - (bundle.install "asin" (unary (math-func "asin"))) - (bundle.install "atan" (unary (math-func "atan"))) - (bundle.install "exp" (unary (math-func "exp"))) - (bundle.install "log" (unary (math-func "log"))) - (bundle.install "ceil" (unary (math-func "ceiling"))) - (bundle.install "floor" (unary (math-func "floor"))) - (bundle.install "pow" (binary math::pow)) - ))) - ## [[IO]] (def: (io::log input) Unary @@ -352,7 +326,6 @@ (dict.merge bundle::frac) (dict.merge bundle::text) (dict.merge bundle::array) - (dict.merge bundle::math) (dict.merge bundle::io) (dict.merge bundle::atom) (dict.merge bundle::box) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 13ffe71da..583a03b1f 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -12,7 +12,8 @@ [data ["." error (#+ Error)] ["." maybe] - ["." text]]] + ["." text]] + ["." math]] [/ ["." i64]]) @@ -142,8 +143,8 @@ Frac (f// +0.0 ))] - [not-a-number +0.0 "Not a number."] - [positive-infinity +1.0 "Positive infinity."] + [not-a-number +0.0 "Not a number."] + [positive-infinity +1.0 "Positive infinity."] [negative-infinity -1.0 "Negative infinity."] ) @@ -923,8 +924,8 @@ (def: (log2 input) (-> Frac Frac) - (f// ("lux math log" +2.0) - ("lux math log" input))) + (f// (math.log +2.0) + (math.log input))) (def: double-bias Nat 1023) @@ -953,13 +954,13 @@ ## else (let [sign (:: Number signum input) input (:: Number abs input) - exponent ("lux math floor" (log2 input)) + exponent (math.floor (log2 input)) exponent-mask (|> 1 (i64.left-shift exponent-size) dec) mantissa (|> input ## Normalize - (f// ("lux math pow" +2.0 exponent)) + (f// (math.pow exponent +2.0)) ## Make it int-equivalent - (f/* ("lux math pow" +2.0 +52.0))) + (f/* (math.pow +52.0 +2.0))) sign-bit (if (f/= -1.0 sign) 1 0) exponent-bits (|> exponent frac-to-int .nat (n/+ double-bias) (i64.and exponent-mask)) mantissa-bits (|> mantissa frac-to-int .nat)] @@ -1000,10 +1001,10 @@ ## else (let [normalized (|> M (i64.set mantissa-size) .int int-to-frac - (f// ("lux math pow" +2.0 +52.0))) - power (|> E (n/- double-bias) - .int int-to-frac - ("lux math pow" +2.0)) + (f// (math.pow +52.0 +2.0))) + power (math.pow (|> E (n/- double-bias) + .int int-to-frac) + +2.0) shifted (f/* power normalized)] (if (n/= 0 S) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index cdaf54461..d4650426f 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -1,16 +1,5 @@ (.module: {#.doc "Common mathematical constants and functions."} - [lux #* - [control - monad - ["p" parser ("parser/." Functor)]] - [data - ["." product] - ["." number] - [collection - [list ("list/." Fold)]]] - ["." macro - ["s" syntax (#+ syntax: Syntax)] - ["." code]]]) + [lux #*]) ## [Values] (do-template [ ] @@ -29,19 +18,19 @@ (-> Frac Frac) ( input))] - [cos "lux math cos"] - [sin "lux math sin"] - [tan "lux math tan"] + [cos "jvm invokestatic:java.lang.Math:cos:double"] + [sin "jvm invokestatic:java.lang.Math:sin:double"] + [tan "jvm invokestatic:java.lang.Math:tan:double"] - [acos "lux math acos"] - [asin "lux math asin"] - [atan "lux math atan"] + [acos "jvm invokestatic:java.lang.Math:acos:double"] + [asin "jvm invokestatic:java.lang.Math:asin:double"] + [atan "jvm invokestatic:java.lang.Math:atan:double"] - [exp "lux math exp"] - [log "lux math log"] + [exp "jvm invokestatic:java.lang.Math:exp:double"] + [log "jvm invokestatic:java.lang.Math:log:double"] - [ceil "lux math ceil"] - [floor "lux math floor"] + [ceil "jvm invokestatic:java.lang.Math:ceil:double"] + [floor "jvm invokestatic:java.lang.Math:floor:double"] ) (def: #export (round input) @@ -59,7 +48,7 @@ (def: #export (pow param subject) (-> Frac Frac Frac) - ("lux math pow" subject param)) + ("jvm invokestatic:java.lang.Math:pow:double,double" subject param)) (def: #export (atan2 param subject) (-> Frac Frac Frac) @@ -79,7 +68,7 @@ (|> pi (f// -2.0)) ## (f/= +0.0 subject) - number.not-a-number))) + (f// +0.0 +0.0)))) (def: #export (log' base input) (-> Frac Frac Frac) @@ -180,81 +169,3 @@ [asech f/-] [acsch f/+] ) - -## [Syntax] -(type: #rec Infix - (#Const Code) - (#Call (List Code)) - (#Unary Code Infix) - (#Binary Infix Code Infix)) - -(def: infix^ - (Syntax Infix) - (<| p.rec (function (_ infix^)) - ($_ p.or - ($_ p.either - (parser/map code.bit s.bit) - (parser/map code.nat s.nat) - (parser/map code.int s.int) - (parser/map code.rev s.rev) - (parser/map code.frac s.frac) - (parser/map code.text s.text) - (parser/map code.identifier s.identifier) - (parser/map code.tag s.tag)) - (s.form (p.many s.any)) - (s.tuple (p.and s.any infix^)) - (s.tuple ($_ p.either - (do p.Monad - [_ (s.this (' #and)) - init-subject infix^ - init-op s.any - init-param infix^ - steps (p.some (p.and s.any infix^))] - (wrap (product.right (list/fold (function (_ [op param] [subject [_subject _op _param]]) - [param [(#Binary _subject _op _param) - (` and) - (#Binary subject op param)]]) - [init-param [init-subject init-op init-param]] - steps)))) - (do p.Monad - [init-subject infix^ - init-op s.any - init-param infix^ - steps (p.some (p.and s.any infix^))] - (wrap (list/fold (function (_ [op param] [_subject _op _param]) - [(#Binary _subject _op _param) op param]) - [init-subject init-op init-param] - steps))) - )) - ))) - -(def: (infix-to-prefix infix) - (-> Infix Code) - (case infix - (#Const value) - value - - (#Call parts) - (code.form parts) - - (#Unary op subject) - (` ((~ op) (~ (infix-to-prefix subject)))) - - (#Binary left op right) - (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left)))) - )) - -(syntax: #export (infix {expr infix^}) - {#.doc (doc "Infix math syntax." - (infix [x i/* +10]) - (infix [[x i/+ y] i/* [x i/- y]]) - (infix [sin [x i/+ y]]) - (infix [[x n/< y] and [y n/< z]]) - (infix [#and x n/< y n/< z]) - (infix [(n/* 3 9) gcd 450]) - - "The rules for infix syntax are simple." - "If you want your binary function to work well with it." - "Then take the argument to the right (y) as your first argument," - "and take the argument to the left (x) as your second argument.")} - (wrap (list (infix-to-prefix expr)))) diff --git a/stdlib/source/lux/math/infix.lux b/stdlib/source/lux/math/infix.lux new file mode 100644 index 000000000..145b8f579 --- /dev/null +++ b/stdlib/source/lux/math/infix.lux @@ -0,0 +1,89 @@ +(.module: {#.doc "Common mathematical constants and functions."} + [lux #* + [control + monad + ["p" parser ("parser/." Functor)]] + [data + ["." product] + [collection + [list ("list/." Fold)]]] + [macro + ["s" syntax (#+ syntax: Syntax)] + ["." code]]]) + +(type: #rec Infix + (#Const Code) + (#Call (List Code)) + (#Unary Code Infix) + (#Binary Infix Code Infix)) + +(def: infix^ + (Syntax Infix) + (<| p.rec (function (_ infix^)) + ($_ p.or + ($_ p.either + (parser/map code.bit s.bit) + (parser/map code.nat s.nat) + (parser/map code.int s.int) + (parser/map code.rev s.rev) + (parser/map code.frac s.frac) + (parser/map code.text s.text) + (parser/map code.identifier s.identifier) + (parser/map code.tag s.tag)) + (s.form (p.many s.any)) + (s.tuple (p.and s.any infix^)) + (s.tuple ($_ p.either + (do p.Monad + [_ (s.this (' #and)) + init-subject infix^ + init-op s.any + init-param infix^ + steps (p.some (p.and s.any infix^))] + (wrap (product.right (list/fold (function (_ [op param] [subject [_subject _op _param]]) + [param [(#Binary _subject _op _param) + (` and) + (#Binary subject op param)]]) + [init-param [init-subject init-op init-param]] + steps)))) + (do p.Monad + [init-subject infix^ + init-op s.any + init-param infix^ + steps (p.some (p.and s.any infix^))] + (wrap (list/fold (function (_ [op param] [_subject _op _param]) + [(#Binary _subject _op _param) op param]) + [init-subject init-op init-param] + steps))) + )) + ))) + +(def: (infix-to-prefix infix) + (-> Infix Code) + (case infix + (#Const value) + value + + (#Call parts) + (code.form parts) + + (#Unary op subject) + (` ((~ op) (~ (infix-to-prefix subject)))) + + (#Binary left op right) + (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left)))) + )) + +(syntax: #export (infix {expr infix^}) + {#.doc (doc "Infix math syntax." + (infix [x i/* +10]) + (infix [[x i/+ y] i/* [x i/- y]]) + (infix [sin [x i/+ y]]) + (infix [[x n/< y] and [y n/< z]]) + (infix [#and x n/< y n/< z]) + (infix [(n/* 3 9) gcd 450]) + + "The rules for infix syntax are simple." + "If you want your binary function to work well with it." + "Then take the argument to the right (y) as your first argument," + "and take the argument to the left (x) as your second argument.")} + (wrap (list (infix-to-prefix expr)))) diff --git a/stdlib/test/test/lux/compiler/default/phase/analysis/procedure/common.lux b/stdlib/test/test/lux/compiler/default/phase/analysis/procedure/common.lux index 5fc04278b..8d3e8b8fa 100644 --- a/stdlib/test/test/lux/compiler/default/phase/analysis/procedure/common.lux +++ b/stdlib/test/test/lux/compiler/default/phase/analysis/procedure/common.lux @@ -207,37 +207,6 @@ (` ("lux array size" (~ g!array))))) )))) -(context: "Math procedures" - (<| (times 100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac))] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC) Frac))] - - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"])) - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC paramC) Frac))] - - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"]))))))) - (context: "Atom procedures" (<| (times 100) (do @ diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux index 4cdb8eed5..059f19c4c 100644 --- a/stdlib/test/test/lux/math.lux +++ b/stdlib/test/test/lux/math.lux @@ -6,6 +6,7 @@ [bit ("bit/." Equivalence)] [number ("frac/." Number)]] ["&" math + infix ["r" random]]] lux/test) @@ -98,27 +99,27 @@ ($_ seq (test "Constant values don't change." (n/= x - (&.infix x))) + (infix x))) (test "Can call binary functions." (n/= (&.n/gcd y x) - (&.infix [x &.n/gcd y]))) + (infix [x &.n/gcd y]))) (test "Can call unary functions." (f/= (&.sin theta) - (&.infix [&.sin theta]))) + (infix [&.sin theta]))) (test "Can use regular syntax in the middle of infix code." (n/= (&.n/gcd 450 (n/* 3 9)) - (&.infix [(n/* 3 9) &.n/gcd 450]))) + (infix [(n/* 3 9) &.n/gcd 450]))) (test "Can use non-numerical functions/macros as operators." (bit/= (and (n/< y x) (n/< z y)) - (&.infix [[x n/< y] and [y n/< z]]))) + (infix [[x n/< y] and [y n/< z]]))) (test "Can combine bit operations in special ways via special keywords." (and (bit/= (and (n/< y x) (n/< z y)) - (&.infix [#and x n/< y n/< z])) + (infix [#and x n/< y n/< z])) (bit/= (and (n/< y x) (n/> z y)) - (&.infix [#and x n/< y n/> z])))) + (infix [#and x n/< y n/> z])))) )))) -- cgit v1.2.3