From eef4422b1f16be2b8c651461f2c006dc4c11f314 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 11 Dec 2022 16:07:39 -0400 Subject: Added support for fixed-point arithmetic. --- stdlib/source/library/lux/data/color.lux | 102 ++---------- stdlib/source/library/lux/data/color/named.lux | 13 +- stdlib/source/library/lux/data/color/rgb.lux | 40 +++++ stdlib/source/library/lux/ffi.lux | 2 +- .../library/lux/math/arithmetic/fixed_point.lux | 185 +++++++++++++++++++++ .../source/library/lux/math/arithmetic/infix.lux | 76 +++++++++ .../source/library/lux/math/arithmetic/modular.lux | 174 +++++++++++++++++++ stdlib/source/library/lux/math/infix.lux | 76 --------- stdlib/source/library/lux/math/modular.lux | 155 ----------------- stdlib/source/library/lux/web/css/value.lux | 13 +- stdlib/source/library/lux/world/money.lux | 83 +++++++-- stdlib/source/library/lux/world/money/currency.lux | 8 +- 12 files changed, 583 insertions(+), 344 deletions(-) create mode 100644 stdlib/source/library/lux/math/arithmetic/fixed_point.lux create mode 100644 stdlib/source/library/lux/math/arithmetic/infix.lux create mode 100644 stdlib/source/library/lux/math/arithmetic/modular.lux delete mode 100644 stdlib/source/library/lux/math/infix.lux delete mode 100644 stdlib/source/library/lux/math/modular.lux (limited to 'stdlib/source/library') diff --git a/stdlib/source/library/lux/data/color.lux b/stdlib/source/library/lux/data/color.lux index a886acb79..2bfa5e5af 100644 --- a/stdlib/source/library/lux/data/color.lux +++ b/stdlib/source/library/lux/data/color.lux @@ -33,85 +33,19 @@ (def .public rgb (-> Color RGB) (|>> nominal.representation)) - - (def .public equivalence - (Equivalence Color) - (of equivalence.functor each ..rgb rgb.equivalence)) - - (def .public hash - (Hash Color) - (of hash.functor each ..rgb rgb.hash)) - - (with_template [ ] - [(def .public - Color - (nominal.abstraction ))] - - [black rgb.black] - [white rgb.white] - ) - - (with_template [ ] - [(def .public - (Monoid Color) - (implementation - (def identity - (nominal.abstraction - (of identity))) - - (def (composite left right) - (nominal.abstraction - (of composite - (nominal.representation left) - (nominal.representation right))))))] - - [addition rgb.addition] - [subtraction rgb.subtraction] - ) - - (def .public complement - (-> Color Color) - (|>> nominal.representation - rgb.complement - nominal.abstraction)) ) -(def (normal ratio) - (-> Frac Frac) - (cond (f.> +1.0 ratio) - (f.% +1.0 ratio) +(def (ratio it) + (-> Frac + Frac) + (cond (f.> +1.0 it) + (f.% +1.0 it) - (f.< +0.0 ratio) - (|> ratio (f.% +1.0) (f.+ +1.0)) + (f.< +0.0 it) + (|> it (f.% +1.0) (f.+ +1.0)) ... else - ratio)) - -(def .public (interpolated ratio end start) - (-> Frac Color Color Color) - (let [dS (..normal ratio) - dE (|> +1.0 (f.- dS)) - interpolated' (is (-> Nat Nat Nat) - (function (_ end start) - (|> (|> start .int int.frac (f.* dS)) - (f.+ (|> end .int int.frac (f.* dE))) - f.int - .nat))) - start (rgb start) - end (rgb end)] - (|> (rgb.rgb (interpolated' (rgb.red end) (rgb.red start)) - (interpolated' (rgb.green end) (rgb.green start)) - (interpolated' (rgb.blue end) (rgb.blue start))) - of_rgb))) - -(with_template [ ] - [(def .public ( ratio color) - (-> Frac Color Color) - (..interpolated ratio color))] - - [darker ..black] - [brighter ..white] - ) + it)) (with_template [ ] [(def .public ( ratio it) @@ -120,7 +54,7 @@ (|> (hsl.hsl (hsl.hue it) (|> it hsl.saturation - (f.* (|> +1.0 ( (..normal ratio)))) + (f.* (|> +1.0 ( (..ratio ratio)))) (f.min +1.0)) (hsl.luminance it)) hsl.rgb @@ -147,12 +81,12 @@ saturation (hsl.saturation hsl) luminance (hsl.luminance hsl)] [color - (|> (hsl.hsl (|> hue (f.+ <1>) ..normal) + (|> (hsl.hsl (|> hue (f.+ <1>) ..ratio) saturation luminance) hsl.rgb of_rgb) - (|> (hsl.hsl (|> hue (f.+ <2>) ..normal) + (|> (hsl.hsl (|> hue (f.+ <2>) ..ratio) saturation luminance) hsl.rgb @@ -177,9 +111,9 @@ hsl.rgb ..of_rgb)))] [color - (|> hue (f.+ <1>) ..normal of_hue) - (|> hue (f.+ <2>) ..normal of_hue) - (|> hue (f.+ <3>) ..normal of_hue)])))] + (|> hue (f.+ <1>) ..ratio of_hue) + (|> hue (f.+ <2>) ..ratio of_hue) + (|> hue (f.+ <3>) ..ratio of_hue)])))] [square (|> +1.0 (f./ +4.0)) (|> +2.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))] [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))] @@ -197,9 +131,9 @@ hue (hsl.hue it) saturation (hsl.saturation it) luminance (hsl.luminance it) - spread (..normal spread)] + spread (..ratio spread)] (list#each (function (_ idx) - (|> (hsl.hsl (|> idx ++ .int int.frac (f.* spread) (f.+ hue) ..normal) + (|> (hsl.hsl (|> idx ++ .int int.frac (f.* spread) (f.+ hue) ..ratio) saturation luminance) hsl.rgb @@ -212,12 +146,12 @@ hue (hsb.hue it) saturation (hsb.saturation it) brightness (hsb.brightness it) - spread (..normal spread)] + spread (..ratio spread)] (|> (list.indices variations) (list#each (|>> ++ .int int.frac (f.* spread) (f.+ brightness) - ..normal + ..ratio (hsb.hsb hue saturation) hsb.rgb ..of_rgb))))) diff --git a/stdlib/source/library/lux/data/color/named.lux b/stdlib/source/library/lux/data/color/named.lux index 90c603977..a669b5940 100644 --- a/stdlib/source/library/lux/data/color/named.lux +++ b/stdlib/source/library/lux/data/color/named.lux @@ -3,17 +3,16 @@ [lux (.except) [math [number (.only hex)]]]] - ["[0]" // (.only Color) - ["[0]" rgb]]) + [// + ["//" rgb (.only RGB)]]) ... https://developer.mozilla.org/en-US/docs/Web/CSS/color_value (with_template [ ] [(`` (def .public - Color - (|> (rgb.rgb (hex ) - (hex ) - (hex )) - //.of_rgb)))] + RGB + (//.rgb (hex ) + (hex ) + (hex ))))] ["F0" "F8" "FF" alice_blue] ["FA" "EB" "D7" antique_white] diff --git a/stdlib/source/library/lux/data/color/rgb.lux b/stdlib/source/library/lux/data/color/rgb.lux index 9f812baa9..deb97365f 100644 --- a/stdlib/source/library/lux/data/color/rgb.lux +++ b/stdlib/source/library/lux/data/color/rgb.lux @@ -14,6 +14,8 @@ [math [number ["n" nat] + ["i" int] + ["f" frac] ["[0]" i64]]] [meta [type @@ -145,3 +147,41 @@ [subtraction ..white n.min ..complement |>] ) ) + +(def (ratio it) + (-> Frac + Frac) + (cond (f.> +1.0 it) + (f.% +1.0 it) + + (f.< +0.0 it) + (|> it (f.% +1.0) (f.+ +1.0)) + + ... else + it)) + +(def .public (interpolated end ratio start) + (-> RGB Frac RGB + RGB) + (let [dS (..ratio ratio) + dE (|> +1.0 (f.- dS)) + interpolated' (is (-> Nat Nat + Nat) + (function (_ end start) + (|> (|> start .int i.frac (f.* dS)) + (f.+ (|> end .int i.frac (f.* dE))) + f.int + .nat)))] + (..rgb (interpolated' (..red end) (..red start)) + (interpolated' (..green end) (..green start)) + (interpolated' (..blue end) (..blue start))))) + +(with_template [ ] + [(def .public + (-> Frac RGB + RGB) + (..interpolated ))] + + [darker ..black] + [brighter ..white] + ) diff --git a/stdlib/source/library/lux/ffi.lux b/stdlib/source/library/lux/ffi.lux index 70f47e5bf..0ad5a846f 100644 --- a/stdlib/source/library/lux/ffi.lux +++ b/stdlib/source/library/lux/ffi.lux @@ -679,7 +679,7 @@ (, (..imported class_name)))))))))] (` (def (, g!it) (syntax ((, g!it) [(, g!it) (<>.maybe .any)]) - (.at meta.monad (,' in) + (.of meta.monad (,' in) (.list (`' (.exec (,* import!) ((,' ,) (when (, g!it) diff --git a/stdlib/source/library/lux/math/arithmetic/fixed_point.lux b/stdlib/source/library/lux/math/arithmetic/fixed_point.lux new file mode 100644 index 000000000..717d4261e --- /dev/null +++ b/stdlib/source/library/lux/math/arithmetic/fixed_point.lux @@ -0,0 +1,185 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [order (.only Order)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception (.only Exception)] + [function + ["[0]" inline]]] + [data + [text + ["%" \\format]]] + [math + [number + ["n" nat] + ["i" int] + ["[0]" i64]]] + [meta + [type + ["[0]" nominal]]]]] + [// (.only Arithmetic)]) + +(def .public maximum + Nat + (-- i64.width)) + +(nominal.def .public (Point @) + Nat + + (exception.def .public (point_exceeds_maximum it) + (Exception Nat) + (exception.report + (list ["Candidate" (%.nat it)] + ["Maximum" (%.nat maximum)]))) + + (def .public (point it) + (Ex (_ @) + (-> Nat + (Try (Point @)))) + (if (n.> maximum it) + (exception.except ..point_exceeds_maximum [it]) + {try.#Success (nominal.abstraction it)})) + + (def .public location + (All (_ @) + (-> (Point @) + Nat)) + (|>> nominal.representation)) + + (nominal.def .public (Fixed @) + Int + + (def sign + (-> Int + (I64 Any)) + (i64.and (i64.bit ..maximum))) + + (def of_units + (inline.inlined (_ @ it) + (All (_ @) + (-> (Point @) Int + (I64 Any))) + (|> it + .i64 + (i64.left_shifted (nominal.representation Point @)) + (i64.or (sign it))))) + + (def of_sub_units + (inline.inlined (_ @ it) + (All (_ @) + (-> (Point @) Rev + (I64 Any))) + (|> it + .i64 + (i.right_shifted (n.- (nominal.representation Point @) i64.width))))) + + (def .public (fixed @ units sub_units) + (All (_ @) + (-> (Point @) Int Rev + (Fixed @))) + (nominal.abstraction + (.int (i64.or (of_units @ units) + (of_sub_units @ sub_units))))) + + (with_template [ ] + [(def .public ( @ it) + (All (_ @) + (-> (Point @) + (Fixed @))) + (nominal.abstraction + (.int ( @ it))))] + + [of_int Int of_units] + [of_rev Rev of_sub_units] + ) + + (def .public (units @) + (All (_ @) + (-> (Point @) (Fixed @) + Int)) + (|>> nominal.representation + (i.right_shifted (nominal.representation Point @)))) + + (def .public (sub_units @) + (All (_ @) + (-> (Point @) (Fixed @) + Rev)) + (|>> nominal.representation + (i64.and (i64.mask (nominal.representation Point @))) + .rev)) + + (with_template [ ] + [(def .public ( _ parameter subject) + (All (_ @) + (-> (Point @) (Fixed @) (Fixed @) + )) + ( + ( (nominal.representation parameter) + (nominal.representation subject))))] + + [(Fixed @) nominal.abstraction + i.+] + [(Fixed @) nominal.abstraction - i.-] + [(Fixed @) nominal.abstraction % i.%] + + [Bit |> = i.=] + [Bit |> < i.<] + [Bit |> <= i.<=] + [Bit |> > i.>] + [Bit |> >= i.>=] + ) + + (with_template [ ] + [(def .public ( @ parameter subject) + (All (_ @) + (-> (Point @) (Fixed @) (Fixed @) + (Fixed @))) + (fixed @ + ( (units @ parameter) + (units @ subject)) + (.rev ( (.nat (sub_units @ parameter)) + (.nat (sub_units @ subject))))))] + + [* i.* n.*] + [/ i./ n./] + ) + ) + ) + +(def .public (equivalence @) + (All (_ @) + (-> (Point @) + (Equivalence (Fixed @)))) + (implementation + (def = (..= @)) + )) + +(def .public (order @) + (All (_ @) + (-> (Point @) + (Order (Fixed @)))) + (implementation + (def equivalence (..equivalence @)) + (def < (..< @)) + )) + +(def .public (arithmetic @) + (All (_ @) + (-> (Point @) + (Arithmetic (Fixed @)))) + (implementation + (def + (..+ @)) + (def - (..- @)) + (def * (..* @)) + (def / (../ @)) + (def % (..% @)) + )) + +(def .public (format @ it) + (All (_ @) + (-> (Point @) + (%.Format (Fixed @)))) + (%.format (%.int (..units @ it)) + (%.rev (..sub_units @ it)))) diff --git a/stdlib/source/library/lux/math/arithmetic/infix.lux b/stdlib/source/library/lux/math/arithmetic/infix.lux new file mode 100644 index 000000000..871f9c7f4 --- /dev/null +++ b/stdlib/source/library/lux/math/arithmetic/infix.lux @@ -0,0 +1,76 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["<>" parser (.use "[1]#[0]" functor)]] + [data + ["[0]" product] + [collection + ["[0]" list (.use "[1]#[0]" mix)]]] + [math + [number + ["n" nat] + ["i" int]]] + [meta + ["[0]" code (.only) + ["<[1]>" \\parser (.only Parser)]] + [macro + [syntax (.only syntax)]]]]]) + +(type Infix + (Rec Infix + (Variant + {#Const Code} + {#Call (List Code)} + {#Unary Code Infix} + {#Binary Infix Code Infix}))) + +(def literal + (Parser Code) + (all <>.either + (<>#each code.bit .bit) + (<>#each code.nat .nat) + (<>#each code.int .int) + (<>#each code.rev .rev) + (<>#each code.frac .frac) + (<>#each code.text .text) + (<>#each code.symbol .symbol))) + +(def expression + (Parser Infix) + (<| <>.rec (function (_ expression)) + (all <>.or + ..literal + (.form (<>.many .any)) + (.tuple (<>.and .any expression)) + (.tuple (do <>.monad + [init_subject expression + init_op .any + init_param expression + steps (<>.some (<>.and .any expression))] + (in (list#mix (function (_ [op param] [_subject _op _param]) + [{#Binary _subject _op _param} op param]) + [init_subject init_op init_param] + steps)))) + ))) + +(def (prefix infix) + (-> Infix Code) + (when infix + {#Const value} + value + + {#Call parts} + (code.form parts) + + {#Unary op subject} + (` ((, op) (, (prefix subject)))) + + {#Binary left op right} + (` ((, op) (, (prefix right)) (, (prefix left)))))) + +(def .public infix + (syntax (_ [expr ..expression]) + (in (list (..prefix expr))))) diff --git a/stdlib/source/library/lux/math/arithmetic/modular.lux b/stdlib/source/library/lux/math/arithmetic/modular.lux new file mode 100644 index 000000000..12c3fb0bf --- /dev/null +++ b/stdlib/source/library/lux/math/arithmetic/modular.lux @@ -0,0 +1,174 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [order (.only Order)] + [monoid (.only Monoid)] + [codec (.only Codec)] + [monad (.only do)]] + [control + ["<>" parser] + ["[0]" try (.only Try)] + ["[0]" exception (.only Exception)]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" monoid) + ["<[1]>" \\parser (.only Parser)]]] + [math + [number + ["i" int (.use "[1]#[0]" decimal)]]] + [meta + ["[0]" code (.only) + ["<[1]>" \\parser]] + [type + ["[0]" nominal (.except def)]]]]] + [/// + ["/" modulus (.only Modulus)]]) + +(nominal.def .public (Mod m) + (Record + [#modulus (Modulus m) + #value Int]) + + (def .public (modular modulus value) + (All (_ %) + (-> (Modulus %) Int + (Mod %))) + (abstraction [#modulus modulus + #value (i.mod (/.divisor modulus) value)])) + + (with_template [ ] + [(def .public + (All (_ %) + (-> (Mod %) + )) + (|>> representation ))] + + [modulus (Modulus %) product.left] + [value Int product.right] + ) + + (exception.def .public (incorrect_modulus [modulus parsed]) + (All (_ %) + (Exception [(Modulus %) Int])) + (exception.report + (list ["Expected" (i#encoded (/.divisor modulus))] + ["Actual" (i#encoded parsed)]))) + + (def separator + " mod ") + + (def intL + (Parser Int) + (<>.codec i.decimal + (.and (.one_of "-+") (.many .decimal)))) + + (def .public (codec expected) + (All (_ %) + (-> (Modulus %) + (Codec Text (Mod %)))) + (implementation + (def (encoded modular) + (let [[_ value] (representation modular)] + (all text#composite + (i#encoded value) + ..separator + (i#encoded (/.divisor expected))))) + + (def decoded + (.result + (do <>.monad + [[value _ actual] (all <>.and intL (.this ..separator) intL) + _ (<>.assertion (exception.error ..incorrect_modulus [expected actual]) + (i.= (/.divisor expected) actual))] + (in (..modular expected value))))))) + + (with_template [ ] + [(def .public ( reference subject) + (All (_ %) + (-> (Mod %) (Mod %) + Bit)) + (let [[_ reference] (representation reference) + [_ subject] (representation subject)] + ( reference subject)))] + + [= i.=] + [< i.<] + [<= i.<=] + [> i.>] + [>= i.>=] + ) + + (def .public equivalence + (All (_ %) + (Equivalence (Mod %))) + (implementation + (def = ..=))) + + (def .public order + (All (_ %) + (Order (Mod %))) + (implementation + (def equivalence ..equivalence) + (def < ..<))) + + (with_template [ ] + [(def .public ( param subject) + (All (_ %) + (-> (Mod %) (Mod %) + (Mod %))) + (let [[modulus param] (representation param) + [_ subject] (representation subject)] + (abstraction [#modulus modulus + #value (|> subject + ( param) + (i.mod (/.divisor modulus)))])))] + + [+ i.+] + [- i.-] + [* i.*] + ) + + (with_template [ ] + [(def .public ( modulus) + (All (_ %) + (-> (Modulus %) + (Monoid (Mod %)))) + (implementation + (def identity + (..modular modulus )) + (def composite + )))] + + [..+ +0 addition] + [..* +1 multiplication] + ) + + (def .public (inverse modular) + (All (_ %) + (-> (Mod %) + (Maybe (Mod %)))) + (let [[modulus value] (representation modular) + [[vk mk] gcd] (i.extended_gcd value (/.divisor modulus))] + (when gcd + +1 {.#Some (..modular modulus vk)} + _ {.#None}))) + ) + +(exception.def .public (moduli_are_not_equal [reference subject]) + (All (_ r% s%) + (Exception [(Modulus r%) (Modulus s%)])) + (exception.report + (list ["Reference" (i#encoded (/.divisor reference))] + ["Subject" (i#encoded (/.divisor subject))]))) + +(def .public (adapter reference subject) + (All (_ r% s%) + (-> (Modulus r%) (Modulus s%) + (Try (-> (Mod s%) + (Mod r%))))) + (if (/.= reference subject) + {try.#Success (|>> ..value + (..modular reference))} + (exception.except ..moduli_are_not_equal [reference subject]))) diff --git a/stdlib/source/library/lux/math/infix.lux b/stdlib/source/library/lux/math/infix.lux deleted file mode 100644 index 871f9c7f4..000000000 --- a/stdlib/source/library/lux/math/infix.lux +++ /dev/null @@ -1,76 +0,0 @@ -(.require - [library - [lux (.except) - [abstract - [monad (.only do)]] - [control - ["<>" parser (.use "[1]#[0]" functor)]] - [data - ["[0]" product] - [collection - ["[0]" list (.use "[1]#[0]" mix)]]] - [math - [number - ["n" nat] - ["i" int]]] - [meta - ["[0]" code (.only) - ["<[1]>" \\parser (.only Parser)]] - [macro - [syntax (.only syntax)]]]]]) - -(type Infix - (Rec Infix - (Variant - {#Const Code} - {#Call (List Code)} - {#Unary Code Infix} - {#Binary Infix Code Infix}))) - -(def literal - (Parser Code) - (all <>.either - (<>#each code.bit .bit) - (<>#each code.nat .nat) - (<>#each code.int .int) - (<>#each code.rev .rev) - (<>#each code.frac .frac) - (<>#each code.text .text) - (<>#each code.symbol .symbol))) - -(def expression - (Parser Infix) - (<| <>.rec (function (_ expression)) - (all <>.or - ..literal - (.form (<>.many .any)) - (.tuple (<>.and .any expression)) - (.tuple (do <>.monad - [init_subject expression - init_op .any - init_param expression - steps (<>.some (<>.and .any expression))] - (in (list#mix (function (_ [op param] [_subject _op _param]) - [{#Binary _subject _op _param} op param]) - [init_subject init_op init_param] - steps)))) - ))) - -(def (prefix infix) - (-> Infix Code) - (when infix - {#Const value} - value - - {#Call parts} - (code.form parts) - - {#Unary op subject} - (` ((, op) (, (prefix subject)))) - - {#Binary left op right} - (` ((, op) (, (prefix right)) (, (prefix left)))))) - -(def .public infix - (syntax (_ [expr ..expression]) - (in (list (..prefix expr))))) diff --git a/stdlib/source/library/lux/math/modular.lux b/stdlib/source/library/lux/math/modular.lux deleted file mode 100644 index e037e5c8c..000000000 --- a/stdlib/source/library/lux/math/modular.lux +++ /dev/null @@ -1,155 +0,0 @@ -(.require - [library - [lux (.except) - [abstract - [equivalence (.only Equivalence)] - [order (.only Order)] - [monoid (.only Monoid)] - [codec (.only Codec)] - [monad (.only do)]] - [control - ["<>" parser] - ["[0]" try (.only Try)] - ["[0]" exception (.only Exception)]] - [data - ["[0]" product] - ["[0]" text (.use "[1]#[0]" monoid) - ["<[1]>" \\parser (.only Parser)]]] - [math - [number - ["i" int (.use "[1]#[0]" decimal)]]] - [meta - ["[0]" code (.only) - ["<[1]>" \\parser]] - [type - ["[0]" nominal (.except def)]]]]] - ["[0]" // - ["[1]" modulus (.only Modulus)]]) - -(nominal.def .public (Mod m) - (Record - [#modulus (Modulus m) - #value Int]) - - (def .public (modular modulus value) - (All (_ %) (-> (Modulus %) Int (Mod %))) - (abstraction [#modulus modulus - #value (i.mod (//.divisor modulus) value)])) - - (with_template [ ] - [(def .public - (All (_ %) (-> (Mod %) )) - (|>> representation ))] - - [modulus (Modulus %) product.left] - [value Int product.right] - ) - - (exception.def .public (incorrect_modulus [modulus parsed]) - (All (_ %) (Exception [(Modulus %) Int])) - (exception.report - (list ["Expected" (i#encoded (//.divisor modulus))] - ["Actual" (i#encoded parsed)]))) - - (def separator - " mod ") - - (def intL - (Parser Int) - (<>.codec i.decimal - (.and (.one_of "-+") (.many .decimal)))) - - (def .public (codec expected) - (All (_ %) (-> (Modulus %) (Codec Text (Mod %)))) - (implementation - (def (encoded modular) - (let [[_ value] (representation modular)] - (all text#composite - (i#encoded value) - ..separator - (i#encoded (//.divisor expected))))) - - (def decoded - (.result - (do <>.monad - [[value _ actual] (all <>.and intL (.this ..separator) intL) - _ (<>.assertion (exception.error ..incorrect_modulus [expected actual]) - (i.= (//.divisor expected) actual))] - (in (..modular expected value))))))) - - (with_template [ ] - [(def .public ( reference subject) - (All (_ %) (-> (Mod %) (Mod %) Bit)) - (let [[_ reference] (representation reference) - [_ subject] (representation subject)] - ( reference subject)))] - - [= i.=] - [< i.<] - [<= i.<=] - [> i.>] - [>= i.>=] - ) - - (def .public equivalence - (All (_ %) (Equivalence (Mod %))) - (implementation - (def = ..=))) - - (def .public order - (All (_ %) (Order (Mod %))) - (implementation - (def equivalence ..equivalence) - (def < ..<))) - - (with_template [ ] - [(def .public ( param subject) - (All (_ %) (-> (Mod %) (Mod %) (Mod %))) - (let [[modulus param] (representation param) - [_ subject] (representation subject)] - (abstraction [#modulus modulus - #value (|> subject - ( param) - (i.mod (//.divisor modulus)))])))] - - [+ i.+] - [- i.-] - [* i.*] - ) - - (with_template [ ] - [(def .public ( modulus) - (All (_ %) (-> (Modulus %) (Monoid (Mod %)))) - (implementation - (def identity - (..modular modulus )) - (def composite - )))] - - [..+ +0 addition] - [..* +1 multiplication] - ) - - (def .public (inverse modular) - (All (_ %) (-> (Mod %) (Maybe (Mod %)))) - (let [[modulus value] (representation modular) - [[vk mk] gcd] (i.extended_gcd value (//.divisor modulus))] - (when gcd - +1 {.#Some (..modular modulus vk)} - _ {.#None}))) - ) - -(exception.def .public (moduli_are_not_equal [reference subject]) - (All (_ r% s%) (Exception [(Modulus r%) (Modulus s%)])) - (exception.report - (list ["Reference" (i#encoded (//.divisor reference))] - ["Subject" (i#encoded (//.divisor subject))]))) - -(def .public (adapter reference subject) - (All (_ r% s%) - (-> (Modulus r%) (Modulus s%) - (Try (-> (Mod s%) (Mod r%))))) - (if (//.= reference subject) - {try.#Success (|>> ..value - (..modular reference))} - (exception.except ..moduli_are_not_equal [reference subject]))) diff --git a/stdlib/source/library/lux/web/css/value.lux b/stdlib/source/library/lux/web/css/value.lux index 37c8580a0..c23a1fda0 100644 --- a/stdlib/source/library/lux/web/css/value.lux +++ b/stdlib/source/library/lux/web/css/value.lux @@ -5,9 +5,9 @@ ["[0]" maybe]] [data ["[0]" product] - ["[0]" color (.only) + [color [pigment (.only Pigment)] - ["[0]" rgb]] + ["[0]" rgb (.only RGB)]] ["[0]" text (.only) ["%" \\format (.only Format format)]] [collection @@ -830,12 +830,11 @@ (|>> abstraction)) (def .public (rgb color) - (-> color.Color + (-> RGB (Value Color)) - (let [color (color.rgb color)] - (..apply "rgb" (list (%.nat (rgb.red color)) - (%.nat (rgb.green color)) - (%.nat (rgb.blue color)))))) + (..apply "rgb" (list (%.nat (rgb.red color)) + (%.nat (rgb.green color)) + (%.nat (rgb.blue color))))) (def .public (rgba pigment) (-> Pigment diff --git a/stdlib/source/library/lux/world/money.lux b/stdlib/source/library/lux/world/money.lux index 80c5f5d09..cd0724459 100644 --- a/stdlib/source/library/lux/world/money.lux +++ b/stdlib/source/library/lux/world/money.lux @@ -2,7 +2,8 @@ [library [lux (.except) [abstract - ["[0]" equivalence (.only Equivalence)]] + [equivalence (.only Equivalence)] + ["[0]" order (.only Order)]] [data ["[0]" product] ["[0]" text (.only) @@ -30,6 +31,16 @@ [#currency currency #amount amount])) + (def .public (of_units currency it) + (All (_ currency) + (-> (/.Currency currency) Nat + (Money currency))) + (money currency + (n.* (/.sub_divisions currency) + it))) + + (def .public of_sub_units money) + (with_template [ ] [(def .public (All (_ currency) @@ -42,15 +53,41 @@ [amount #amount Nat] ) + (def .public order + (All (_ currency) + (Order (Money currency))) + (of order.functor each + ..amount + n.order)) + + (def .public < + (All (_ currency) + (-> (Money currency) (Money currency) + Bit)) + (of ..order <)) + + (with_template [ ] + [(def .public + (All (_ currency) + (-> (Money currency) (Money currency) + Bit)) + ( order))] + + [<= order.<=] + [> order.>] + [>= order.>=] + ) + (def .public equivalence - (All (_ of) - (Equivalence (Money of))) - (of equivalence.functor each - (|>> nominal.representation) - (all product.equivalence - /.equivalence - n.equivalence - ))) + (All (_ currency) + (Equivalence (Money currency))) + (of ..order equivalence)) + + (def .public = + (All (_ currency) + (-> (Money currency) (Money currency) + Bit)) + (of ..equivalence =)) (def .public (+ parameter subject) (All (_ currency) @@ -79,10 +116,36 @@ (All (_ currency) (%.Format (Money currency))) (let [[currency amount] (nominal.representation it) - [macro micro] (n./% (/.subdivisions currency) amount)] + [macro micro] (n./% (/.sub_divisions currency) amount)] (%.format (%.nat macro) (when micro 0 "" _ (%.format "." (%.nat micro))) " " (/.alphabetic_code currency)))) ) + +(with_template [ ] + [(def .public ( left right) + (All (_ currency) + (-> (Money currency) (Money currency) + (Money currency))) + (if ( (..amount left) + (..amount right)) + right + left))] + + [n.< min] + [n.> max] + ) + +(with_template [<*> ] + [(def .public ( it) + (All (_ currency) + (-> (Money currency) + Nat)) + (<*> (/.sub_divisions (..currency it)) + (..amount it)))] + + [n./ units] + [n.% sub_units] + ) diff --git a/stdlib/source/library/lux/world/money/currency.lux b/stdlib/source/library/lux/world/money/currency.lux index 7cefbb664..04292fa48 100644 --- a/stdlib/source/library/lux/world/money/currency.lux +++ b/stdlib/source/library/lux/world/money/currency.lux @@ -26,16 +26,16 @@ (Record [#alphabetic_code Text #numeric_code Nat - #subdivisions Nat]) + #sub_divisions Nat]) - (def .public (currency [alphabetic_code numeric_code subdivisions]) + (def .public (currency [alphabetic_code numeric_code sub_divisions]) (Ex (_ of) (-> [Text Nat Nat] (Currency of))) (nominal.abstraction [#alphabetic_code alphabetic_code #numeric_code numeric_code - #subdivisions subdivisions])) + #sub_divisions sub_divisions])) (with_template [ ] [(def .public @@ -47,7 +47,7 @@ [alphabetic_code #alphabetic_code Text] [numeric_code #numeric_code Nat] - [subdivisions #subdivisions Nat] + [sub_divisions #sub_divisions Nat] ) (def .public equivalence -- cgit v1.2.3