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/format/lux/data/text.lux | 21 ++- 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 +- .../test/lux/data/collection/tree/zipper.lux | 3 +- stdlib/source/test/lux/data/color.lux | 97 +++-------- stdlib/source/test/lux/data/color/named.lux | 13 +- stdlib/source/test/lux/data/color/rgb.lux | 49 +++++- stdlib/source/test/lux/data/text.lux | 5 +- stdlib/source/test/lux/math.lux | 12 +- .../test/lux/math/arithmetic/fixed_point.lux | 119 +++++++++++++ stdlib/source/test/lux/math/arithmetic/infix.lux | 57 +++++++ stdlib/source/test/lux/math/arithmetic/modular.lux | 129 ++++++++++++++ stdlib/source/test/lux/math/infix.lux | 57 ------- stdlib/source/test/lux/math/modular.lux | 127 -------------- stdlib/source/test/lux/world/money.lux | 42 ++++- stdlib/source/test/lux/world/money/currency.lux | 4 +- stdlib/source/test/lux/world/net/http/response.lux | 2 +- 27 files changed, 1037 insertions(+), 627 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 create mode 100644 stdlib/source/test/lux/math/arithmetic/fixed_point.lux create mode 100644 stdlib/source/test/lux/math/arithmetic/infix.lux create mode 100644 stdlib/source/test/lux/math/arithmetic/modular.lux delete mode 100644 stdlib/source/test/lux/math/infix.lux delete mode 100644 stdlib/source/test/lux/math/modular.lux diff --git a/stdlib/source/format/lux/data/text.lux b/stdlib/source/format/lux/data/text.lux index 532edba75..43117912e 100644 --- a/stdlib/source/format/lux/data/text.lux +++ b/stdlib/source/format/lux/data/text.lux @@ -16,13 +16,14 @@ [collection ["[0]" list (.use "[1]#[0]" monad)]]] [math - ["[0]" modular] [number ["[0]" nat] ["[0]" int] ["[0]" rev] ["[0]" frac] - ["[0]" ratio]]] + ["[0]" ratio]] + [arithmetic + ["[0]" modular]]] [meta ["[0]" location] ["[0]" symbol] @@ -40,8 +41,9 @@ ["[0]" day] ["[0]" month]]]]]) -(.type .public (Format a) - (-> a Text)) +(.type .public (Format of) + (-> of + Text)) (def .public functor (contravariant.Functor Format) @@ -113,18 +115,23 @@ ) (def .public (mod modular) - (All (_ m) (Format (modular.Mod m))) + (All (_ %) + (Format (modular.Mod %))) (let [codec (modular.codec (modular.modulus modular))] (of codec encoded modular))) (def .public (list formatter) - (All (_ a) (-> (Format a) (Format (List a)))) + (All (_ of) + (-> (Format of) + (Format (List of)))) (|>> (list#each (|>> formatter (format " "))) text.together (text.enclosed ["(list" ")"]))) (def .public (maybe format) - (All (_ a) (-> (Format a) (Format (Maybe a)))) + (All (_ of) + (-> (Format of) + (Format (Maybe of)))) (function (_ value) (when value {.#None} 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 diff --git a/stdlib/source/test/lux/data/collection/tree/zipper.lux b/stdlib/source/test/lux/data/collection/tree/zipper.lux index fe764d955..4325a30ef 100644 --- a/stdlib/source/test/lux/data/collection/tree/zipper.lux +++ b/stdlib/source/test/lux/data/collection/tree/zipper.lux @@ -155,7 +155,8 @@ (def .public test Test (<| (_.covering /._) - (_.for [/.Zipper]) + (_.for [/.Zipper + /.#family /.#node]) (do [! random.monad] [[size sample] (//.tree random.nat) expected random.nat diff --git a/stdlib/source/test/lux/data/color.lux b/stdlib/source/test/lux/data/color.lux index c72ee2c1f..ee2eb70b2 100644 --- a/stdlib/source/test/lux/data/color.lux +++ b/stdlib/source/test/lux/data/color.lux @@ -48,12 +48,6 @@ (-> Frac Frac) (f.pow +0.5)) -(def (distance/1 from to) - (-> Frac Frac Frac) - (square_root - (square - (f.- from to)))) - (def (distance/3 from to) (-> /.Color /.Color Frac) (let [from (/.rgb from) @@ -78,52 +72,31 @@ [luminance hsl.luminance] ) -(def (encoding expected) - (-> /.Color Test) - (all _.and - (_.coverage [/.rgb /.of_rgb] - (|> expected /.rgb /.of_rgb - (of /.equivalence = expected))) - )) - -(def transformation - Test - (do random.monad - [colorful (|> ..random - (random.only (function (_ color) (and (|> (distance/3 color /.black) (f.>= +100.0)) - (|> (distance/3 color /.white) (f.>= +100.0)))))) - mediocre (|> ..random - (random.only (|>> saturation - ((function (_ saturation) - (and (f.>= +0.25 saturation) - (f.<= +0.75 saturation))))))) - ratio (|> random.safe_frac (random.only (f.>= +0.5)))] - (all _.and - (_.coverage [/.darker /.brighter] - (and (f.<= (distance/3 colorful /.black) - (distance/3 (/.darker ratio colorful) /.black)) - (f.<= (distance/3 colorful /.white) - (distance/3 (/.brighter ratio colorful) /.white)))) - (_.coverage [/.interpolated] - (and (f.<= (distance/3 colorful /.black) - (distance/3 (/.interpolated ratio /.black colorful) /.black)) - (f.<= (distance/3 colorful /.white) - (distance/3 (/.interpolated ratio /.white colorful) /.white)))) - (_.coverage [/.saturated] - (f.> (saturation mediocre) - (saturation (/.saturated ratio mediocre)))) - (_.coverage [/.un_saturated] - (f.< (saturation mediocre) - (saturation (/.un_saturated ratio mediocre)))) - (_.coverage [/.gray_scale] - (let [gray'ed (/.gray_scale mediocre)] - (and (f.= +0.0 - (saturation gray'ed)) - (|> (luminance gray'ed) - (f.- (luminance mediocre)) - f.abs - (f.<= ..rgb_error_margin))))) - ))) +... (def transformation +... Test +... (do random.monad +... [mediocre (|> ..random +... (random.only (|>> saturation +... ((function (_ saturation) +... (and (f.>= +0.25 saturation) +... (f.<= +0.75 saturation))))))) +... ratio (|> random.safe_frac (random.only (f.>= +0.5)))] +... (all _.and +... (_.coverage [/.saturated] +... (f.> (saturation mediocre) +... (saturation (/.saturated ratio mediocre)))) +... (_.coverage [/.un_saturated] +... (f.< (saturation mediocre) +... (saturation (/.un_saturated ratio mediocre)))) +... (_.coverage [/.gray_scale] +... (let [gray'ed (/.gray_scale mediocre)] +... (and (f.= +0.0 +... (saturation gray'ed)) +... (|> (luminance gray'ed) +... (f.- (luminance mediocre)) +... f.abs +... (f.<= ..rgb_error_margin))))) +... ))) ... (def palette ... Test @@ -181,25 +154,7 @@ (do [! random.monad] [expected ..random] (all _.and - (_.for [/.equivalence] - ($equivalence.spec /.equivalence ..random)) - (_.for [/.hash] - ($hash.spec /.hash ..random)) - (_.for [/.addition] - ($monoid.spec /.equivalence /.addition ..random)) - (_.for [/.subtraction] - ($monoid.spec /.equivalence /.addition ..random)) - - (..encoding expected) - (_.coverage [/.complement] - (let [~expected (/.complement expected) - (open "/#[0]") /.equivalence] - (and (not (/#= expected ~expected)) - (/#= expected (/.complement ~expected))))) - (_.coverage [/.black /.white] - (and (of /.equivalence = /.white (/.complement /.black)) - (of /.equivalence = /.black (/.complement /.white)))) - ..transformation + ... ..transformation ... ..palette /rgb.test diff --git a/stdlib/source/test/lux/data/color/named.lux b/stdlib/source/test/lux/data/color/named.lux index cb1201c74..4af869cb4 100644 --- a/stdlib/source/test/lux/data/color/named.lux +++ b/stdlib/source/test/lux/data/color/named.lux @@ -20,7 +20,8 @@ ["_" property (.only Test)]]]] [\\library ["[0]" / (.only) - ["/[1]" //]]]) + [// + ["[0]" rgb (.only RGB)]]]]) (with_expansions [ (these [letter/a [/.alice_blue @@ -206,7 +207,7 @@ )] (def all_colors (list.together (`` (list (,, (with_template [ ] - [((is (-> Any (List //.Color)) + [((is (-> Any (List RGB)) (function (_ _) (`` (list (,, (template.spliced )))))) 123)] @@ -214,10 +215,10 @@ )))))) (def unique_colors - (set.of_list //.hash ..all_colors)) + (set.of_list rgb.hash ..all_colors)) (def .public random - (Random //.Color) + (Random RGB) (do [! random.monad] [choice (of ! each (n.% (set.size ..unique_colors)) random.nat)] @@ -244,8 +245,8 @@ )) (_.coverage [/.aqua] - (of //.equivalence = /.cyan /.aqua)) + (of rgb.equivalence = /.cyan /.aqua)) (_.coverage [/.fuchsia] - (of //.equivalence = /.magenta /.fuchsia)) + (of rgb.equivalence = /.magenta /.fuchsia)) )))) ) diff --git a/stdlib/source/test/lux/data/color/rgb.lux b/stdlib/source/test/lux/data/color/rgb.lux index 5c81582eb..19094bfe2 100644 --- a/stdlib/source/test/lux/data/color/rgb.lux +++ b/stdlib/source/test/lux/data/color/rgb.lux @@ -13,7 +13,9 @@ [math ["[0]" random (.only Random) (.use "[1]#[0]" functor)] [number - ["n" nat]]] + ["n" nat] + ["i" int] + ["f" frac]]] [test ["_" property (.only Test)]]]] [\\library @@ -32,6 +34,31 @@ blue ..value] (in (/.rgb red green blue)))) +(def scale + (-> Nat + Frac) + (|>> .int + i.frac)) + +(def square + (-> Frac + Frac) + (f.pow +2.0)) + +(def square_root + (-> Frac + Frac) + (f.pow +0.5)) + +(def (distance/3 from to) + (-> /.RGB /.RGB + Frac) + (square_root + (all f.+ + (|> (scale (/.red to)) (f.- (scale (/.red from))) square) + (|> (scale (/.green to)) (f.- (scale (/.green from))) square) + (|> (scale (/.blue to)) (f.- (scale (/.blue from))) square)))) + (def .public test Test (<| (_.covering /._) @@ -41,7 +68,14 @@ expected_red ..value expected_green ..value - expected_blue ..value]) + expected_blue ..value + + colorful (random.only (function (_ it) + (and (|> it (distance/3 /.black) (f.>= +100.0)) + (|> it (distance/3 /.white) (f.>= +100.0)))) + ..random) + ratio (random.only (f.>= +0.5) + random.safe_frac)]) (all _.and (_.for [/.Value] (all _.and @@ -93,5 +127,16 @@ (_.coverage [/.black /.white] (and (of /.equivalence = /.white (/.complement /.black)) (of /.equivalence = /.black (/.complement /.white)))) + + (_.coverage [/.interpolated] + (and (f.<= (distance/3 /.black colorful) + (distance/3 /.black (/.interpolated /.black ratio colorful))) + (f.<= (distance/3 /.white colorful) + (distance/3 /.white (/.interpolated /.white ratio colorful))))) + (_.coverage [/.darker /.brighter] + (and (f.<= (distance/3 /.black colorful) + (distance/3 /.black (/.darker ratio colorful))) + (f.<= (distance/3 /.white colorful) + (distance/3 /.white (/.brighter ratio colorful))))) )) ))) diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux index dd867436b..6dadb8aa6 100644 --- a/stdlib/source/test/lux/data/text.lux +++ b/stdlib/source/test/lux/data/text.lux @@ -35,13 +35,14 @@ [math ["[0]" random (.only Random) (.use "[1]#[0]" monad)] ["[0]" modulus] - ["[0]" modular] [number ["[0]" nat] ["[0]" int] ["[0]" rev] ["[0]" frac] - ["[0]" ratio]]] + ["[0]" ratio]] + [arithmetic + ["[0]" modular]]] [meta ["[0]" location] ["[0]" symbol] diff --git a/stdlib/source/test/lux/math.lux b/stdlib/source/test/lux/math.lux index 6cee94642..c3cd49270 100644 --- a/stdlib/source/test/lux/math.lux +++ b/stdlib/source/test/lux/math.lux @@ -22,16 +22,17 @@ [\\library ["[0]" /]] ["[0]" / - ["[1][0]" infix] ["[1][0]" modulus] - ["[1][0]" modular] ["[1][0]" number] ["[1][0]" random] ["[1][0]" logic ["[1]/[0]" continuous] ["[1]/[0]" fuzzy]] ["[1][0]" arithmetic - ["[1]/[0]" saturation]]]) + ["[1]/[0]" infix] + ["[1]/[0]" modular] + ["[1]/[0]" saturation] + ["[1]/[0]" fixed_point]]]) (def ratio/0 Ratio @@ -140,12 +141,13 @@ [ratio.>= parameter/ subject/]]] )) - /infix.test /modulus.test - /modular.test /number.test /random.test /logic/continuous.test /logic/fuzzy.test + /arithmetic/infix.test + /arithmetic/modular.test /arithmetic/saturation.test + /arithmetic/fixed_point.test )))) diff --git a/stdlib/source/test/lux/math/arithmetic/fixed_point.lux b/stdlib/source/test/lux/math/arithmetic/fixed_point.lux new file mode 100644 index 000000000..bff8264f2 --- /dev/null +++ b/stdlib/source/test/lux/math/arithmetic/fixed_point.lux @@ -0,0 +1,119 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)] + [\\specification + ["[0]S" equivalence] + ["[0]S" order]]] + [control + ["[0]" try (.use "[1]#[0]" functor)] + ["[0]" exception]] + [data + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.only) + ["%" \\format]]] + [math + ["[0]" random (.only Random)] + [number + ["n" nat]] + ["[0]" arithmetic + ["[1]S" \\specification]]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" /]]) + +(def .public (random @) + (All (_ @) + (-> (/.Point @) + (Random (/.Fixed @)))) + (do random.monad + [units random.int + sub_units random.rev] + (in (/.fixed @ units sub_units)))) + +(def .public test + Test + (<| (_.covering /._) + (do [! random.monad] + [candidate_point random.nat + expected_point (of ! each (n.% (++ /.maximum)) random.nat) + .let [@ (try.trusted (/.point expected_point))] + expected (..random @) + parameter (..random @) + subject (..random @)]) + (all _.and + (<| (_.for [/.Point]) + (all _.and + (_.coverage [/.point /.location] + (|> (/.point expected_point) + (try#each (|>> /.location + (same? expected_point))) + (try.else false))) + (_.coverage [/.maximum /.point_exceeds_maximum] + (when (/.point candidate_point) + {try.#Success it} + (n.<= /.maximum candidate_point) + + {try.#Failure error} + (and (n.> /.maximum candidate_point) + (exception.match? /.point_exceeds_maximum error)))) + )) + (<| (_.for [/.Fixed]) + (all _.and + (_.for [/.equivalence /.=] + (equivalenceS.spec (/.equivalence @) (..random @))) + (_.for [/.order /.<] + (orderS.spec (/.order @) (..random @))) + (_.for [/.arithmetic] + (arithmeticS.spec (/.equivalence @) (/.arithmetic @) (..random @))) + + (_.coverage [/.fixed /.units /.sub_units] + (/.= @ + expected + (/.fixed @ (/.units @ expected) (/.sub_units @ expected)))) + (_.coverage [/.of_int /.of_rev] + (/.= @ + expected + (/.+ @ + (/.of_int @ (/.units @ expected)) + (/.of_rev @ (/.sub_units @ expected))))) + + (_.coverage [/.>] + (bit#= (/.> @ parameter subject) + (/.< @ subject parameter))) + (_.coverage [/.<= /.>=] + (bit#= (/.<= @ parameter subject) + (/.>= @ subject parameter))) + + (_.coverage [/.-] + (and (/.= @ + (/.of_int @ +0) + (/.- @ expected expected)) + (/.= @ + (/.of_rev @ .0) + (/.- @ expected expected)))) + (_.coverage [/.+] + (|> subject + (/.+ @ parameter) + (/.- @ parameter) + (/.= @ subject))) + (_.coverage [/./] + (/.= @ + (/.of_int @ +1) + (/./ @ expected expected))) + (_.coverage [/.* /.%] + (let [rem (/.% @ parameter subject) + div (|> subject (/.- @ rem) (/./ @ parameter))] + (/.= @ subject + (|> div (/.* @ parameter) (/.+ @ rem))))) + + (_.coverage [/.format] + (let [it (/.format @ expected)] + (and (text.contains? (%.int (/.units @ expected)) + it) + (text.contains? (%.rev (/.sub_units @ expected)) + it)))) + )) + ))) diff --git a/stdlib/source/test/lux/math/arithmetic/infix.lux b/stdlib/source/test/lux/math/arithmetic/infix.lux new file mode 100644 index 000000000..5f4143556 --- /dev/null +++ b/stdlib/source/test/lux/math/arithmetic/infix.lux @@ -0,0 +1,57 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [data + ["[0]" bit (.use "[1]#[0]" equivalence)]] + [math + ["[0]" random] + [number + ["n" nat] + ["f" frac]]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" /]]) + +(def .public test + Test + (<| (_.covering /._) + (do random.monad + [subject random.nat + parameter random.nat + extra random.nat + angle random.safe_frac + factor random.nat] + (_.coverage [/.infix] + (let [constant_values! + (n.= subject + (/.infix subject)) + + unary_functions! + (f.= (f.sin angle) + (/.infix [f.sin angle])) + + binary_functions! + (n.= (n.gcd parameter subject) + (/.infix [subject n.gcd parameter])) + + multiple_binary_functions! + (n.= (n.* factor (n.gcd parameter subject)) + (/.infix [subject n.gcd parameter n.* factor])) + + function_call! + (n.= (n.gcd extra (n.* parameter subject)) + (/.infix [(n.* parameter subject) n.gcd extra])) + + non_numeric! + (bit#= (and (n.< parameter subject) (n.< extra parameter)) + (/.infix [[subject n.< parameter] and [parameter n.< extra]]))] + (and constant_values! + unary_functions! + binary_functions! + multiple_binary_functions! + function_call! + non_numeric! + )))))) diff --git a/stdlib/source/test/lux/math/arithmetic/modular.lux b/stdlib/source/test/lux/math/arithmetic/modular.lux new file mode 100644 index 000000000..4d05bacbe --- /dev/null +++ b/stdlib/source/test/lux/math/arithmetic/modular.lux @@ -0,0 +1,129 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)] + [\\specification + ["$[0]" equivalence] + ["$[0]" order] + ["$[0]" monoid] + ["$[0]" codec]]] + [control + ["[0]" try] + ["[0]" exception] + [function + ["[0]" predicate]]] + [data + ["[0]" product] + ["[0]" bit (.use "[1]#[0]" equivalence)]] + [math + ["[0]" random (.only Random)] + [number + ["i" int]]] + [meta + ["[0]" type (.use "[1]#[0]" equivalence)]] + [test + ["_" property (.only Test)]]]] + [/// + ["//T" modulus]] + [\\library + ["[0]" / (.only) + [/// + ["//" modulus]]]]) + +(def .public (random modulus) + (All (_ %) + (-> (//.Modulus %) + (Random (/.Mod %)))) + (of random.monad each + (/.modular modulus) + random.int)) + +(def .public test + Test + (<| (_.covering /._) + (_.for [/.Mod]) + (do random.monad + [param::% (//T.random +1,000,000) + param (..random param::%) + + subject::% (random.only (predicate.and (|>> //.divisor (i.> +2)) + (|>> (//.= param::%) not)) + (//T.random +1,000,000)) + subject (..random subject::%) + another (..random subject::%)] + (`` (all _.and + (_.for [/.equivalence /.=] + ($equivalence.spec /.equivalence (..random subject::%))) + (_.for [/.order /.<] + ($order.spec /.order (..random subject::%))) + (,, (with_template [ ] + [(_.for [ ] + ($monoid.spec /.equivalence ( subject::%) (..random subject::%)))] + + [/.+ /.addition] + [/.* /.multiplication] + )) + (_.for [/.codec] + ($codec.spec /.equivalence (/.codec subject::%) (..random subject::%))) + + (_.coverage [/.incorrect_modulus] + (when (|> param + (of (/.codec param::%) encoded) + (of (/.codec subject::%) decoded)) + {try.#Failure error} + (exception.match? /.incorrect_modulus error) + + {try.#Success _} + false)) + (_.coverage [/.modulus] + (and (type#= (type_of (/.modulus subject)) + (type_of (/.modulus subject))) + (not (type#= (type_of (/.modulus subject)) + (type_of (/.modulus param)))))) + (_.coverage [/.modular /.value] + (/.= subject + (/.modular (/.modulus subject) (/.value subject)))) + (_.coverage [/.>] + (bit#= (/.> another subject) + (/.< subject another))) + (_.coverage [/.<= /.>=] + (bit#= (/.<= another subject) + (/.>= subject another))) + (_.coverage [/.-] + (let [zero (/.modular (/.modulus subject) +0)] + (and (/.= zero + (/.- subject subject)) + (/.= subject + (/.- zero subject))))) + (_.coverage [/.inverse] + (let [one (/.modular (/.modulus subject) +1) + co_prime? (i.co_prime? (//.divisor (/.modulus subject)) + (/.value subject))] + (when (/.inverse subject) + {.#Some subject^-1} + (and co_prime? + (|> subject + (/.* subject^-1) + (/.= one))) + + {.#None} + (not co_prime?)))) + (_.coverage [/.adapter] + (<| (try.else false) + (do try.monad + [copy::% (//.modulus (//.divisor subject::%)) + adapt (/.adapter subject::% copy::%)] + (in (|> subject + /.value + (/.modular copy::%) + adapt + (/.= subject)))))) + (_.coverage [/.moduli_are_not_equal] + (when (/.adapter subject::% param::%) + {try.#Failure error} + (exception.match? /.moduli_are_not_equal error) + + {try.#Success _} + false)) + ))))) diff --git a/stdlib/source/test/lux/math/infix.lux b/stdlib/source/test/lux/math/infix.lux deleted file mode 100644 index 5f4143556..000000000 --- a/stdlib/source/test/lux/math/infix.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.require - [library - [lux (.except) - [abstract - [monad (.only do)]] - [data - ["[0]" bit (.use "[1]#[0]" equivalence)]] - [math - ["[0]" random] - [number - ["n" nat] - ["f" frac]]] - [test - ["_" property (.only Test)]]]] - [\\library - ["[0]" /]]) - -(def .public test - Test - (<| (_.covering /._) - (do random.monad - [subject random.nat - parameter random.nat - extra random.nat - angle random.safe_frac - factor random.nat] - (_.coverage [/.infix] - (let [constant_values! - (n.= subject - (/.infix subject)) - - unary_functions! - (f.= (f.sin angle) - (/.infix [f.sin angle])) - - binary_functions! - (n.= (n.gcd parameter subject) - (/.infix [subject n.gcd parameter])) - - multiple_binary_functions! - (n.= (n.* factor (n.gcd parameter subject)) - (/.infix [subject n.gcd parameter n.* factor])) - - function_call! - (n.= (n.gcd extra (n.* parameter subject)) - (/.infix [(n.* parameter subject) n.gcd extra])) - - non_numeric! - (bit#= (and (n.< parameter subject) (n.< extra parameter)) - (/.infix [[subject n.< parameter] and [parameter n.< extra]]))] - (and constant_values! - unary_functions! - binary_functions! - multiple_binary_functions! - function_call! - non_numeric! - )))))) diff --git a/stdlib/source/test/lux/math/modular.lux b/stdlib/source/test/lux/math/modular.lux deleted file mode 100644 index 686977544..000000000 --- a/stdlib/source/test/lux/math/modular.lux +++ /dev/null @@ -1,127 +0,0 @@ -(.require - [library - [lux (.except) - [abstract - [monad (.only do)] - [\\specification - ["$[0]" equivalence] - ["$[0]" order] - ["$[0]" monoid] - ["$[0]" codec]]] - [control - ["[0]" try] - ["[0]" exception] - [function - ["[0]" predicate]]] - [data - ["[0]" product] - ["[0]" bit (.use "[1]#[0]" equivalence)]] - [math - ["[0]" random (.only Random)] - [number - ["i" int]]] - [meta - ["[0]" type (.use "[1]#[0]" equivalence)]] - [test - ["_" property (.only Test)]]]] - ["$[0]" // - ["[1]" modulus]] - [\\library - ["[0]" / (.only) - ["/[1]" // - ["[1]" modulus]]]]) - -(def .public (random modulus) - (All (_ %) (-> (//.Modulus %) (Random (/.Mod %)))) - (of random.monad each - (/.modular modulus) - random.int)) - -(def .public test - Test - (<| (_.covering /._) - (_.for [/.Mod]) - (do random.monad - [param::% ($//.random +1,000,000) - param (..random param::%) - - subject::% (random.only (predicate.and (|>> //.divisor (i.> +2)) - (|>> (//.= param::%) not)) - ($//.random +1,000,000)) - subject (..random subject::%) - another (..random subject::%)] - (`` (all _.and - (_.for [/.equivalence /.=] - ($equivalence.spec /.equivalence (..random subject::%))) - (_.for [/.order /.<] - ($order.spec /.order (..random subject::%))) - (,, (with_template [ ] - [(_.for [ ] - ($monoid.spec /.equivalence ( subject::%) (..random subject::%)))] - - [/.+ /.addition] - [/.* /.multiplication] - )) - (_.for [/.codec] - ($codec.spec /.equivalence (/.codec subject::%) (..random subject::%))) - - (_.coverage [/.incorrect_modulus] - (when (|> param - (of (/.codec param::%) encoded) - (of (/.codec subject::%) decoded)) - {try.#Failure error} - (exception.match? /.incorrect_modulus error) - - {try.#Success _} - false)) - (_.coverage [/.modulus] - (and (type#= (type_of (/.modulus subject)) - (type_of (/.modulus subject))) - (not (type#= (type_of (/.modulus subject)) - (type_of (/.modulus param)))))) - (_.coverage [/.modular /.value] - (/.= subject - (/.modular (/.modulus subject) (/.value subject)))) - (_.coverage [/.>] - (bit#= (/.> another subject) - (/.< subject another))) - (_.coverage [/.<= /.>=] - (bit#= (/.<= another subject) - (/.>= subject another))) - (_.coverage [/.-] - (let [zero (/.modular (/.modulus subject) +0)] - (and (/.= zero - (/.- subject subject)) - (/.= subject - (/.- zero subject))))) - (_.coverage [/.inverse] - (let [one (/.modular (/.modulus subject) +1) - co_prime? (i.co_prime? (//.divisor (/.modulus subject)) - (/.value subject))] - (when (/.inverse subject) - {.#Some subject^-1} - (and co_prime? - (|> subject - (/.* subject^-1) - (/.= one))) - - {.#None} - (not co_prime?)))) - (_.coverage [/.adapter] - (<| (try.else false) - (do try.monad - [copy::% (//.modulus (//.divisor subject::%)) - adapt (/.adapter subject::% copy::%)] - (in (|> subject - /.value - (/.modular copy::%) - adapt - (/.= subject)))))) - (_.coverage [/.moduli_are_not_equal] - (when (/.adapter subject::% param::%) - {try.#Failure error} - (exception.match? /.moduli_are_not_equal error) - - {try.#Success _} - false)) - ))))) diff --git a/stdlib/source/test/lux/world/money.lux b/stdlib/source/test/lux/world/money.lux index 4ebd46bf2..4cddc38ee 100644 --- a/stdlib/source/test/lux/world/money.lux +++ b/stdlib/source/test/lux/world/money.lux @@ -4,10 +4,12 @@ [abstract [monad (.only do)] [\\specification - ["[0]S" equivalence]]] + ["[0]S" equivalence] + ["[0]S" order]]] [control ["[0]" maybe (.use "[1]#[0]" functor)]] [data + ["[0]" bit (.use "[1]#[0]" equivalence)] ["[0]" text (.only) ["%" \\format]]] [math @@ -41,8 +43,10 @@ expected_subject random.nat]) (_.for [/.Money]) (all _.and - (_.for [/.equivalence] + (_.for [/.equivalence /.=] (equivalenceS.spec /.equivalence ..random)) + (_.for [/.order /.<] + (orderS.spec /.order ..random)) (_.coverage [/.money /.currency /.amount] (let [it (/.money expected_currency expected_amount)] @@ -60,6 +64,40 @@ (/.- parameter) (maybe#each (of /.equivalence = subject)) (maybe.else false))))) + (_.coverage [/.min] + (let [expected_parameter (/.money expected_currency expected_parameter) + expected_subject (/.money expected_currency expected_subject)] + (and (/.<= expected_parameter + (/.min expected_parameter expected_subject)) + (/.<= expected_subject + (/.min expected_parameter expected_subject))))) + (_.coverage [/.max] + (let [expected_parameter (/.money expected_currency expected_parameter) + expected_subject (/.money expected_currency expected_subject)] + (and (/.>= expected_parameter + (/.max expected_parameter expected_subject)) + (/.>= expected_subject + (/.max expected_parameter expected_subject))))) + (let [expected_parameter (/.money expected_currency expected_parameter) + expected_subject (/.money expected_currency expected_subject)] + (all _.and + (_.coverage [/.>] + (bit#= (/.> expected_parameter expected_subject) + (/.< expected_subject expected_parameter))) + (_.coverage [/.<= /.>=] + (bit#= (/.<= expected_parameter expected_subject) + (/.>= expected_subject expected_parameter))) + )) + (_.coverage [/.units /.sub_units] + (let [expected (/.money expected_currency expected_amount) + actual (/.money expected_currency (n.+ (/.units expected) + (/.sub_units expected)))] + (/.= expected actual))) + (_.coverage [/.of_units /.of_sub_units] + (let [expected (/.money expected_currency expected_amount) + actual (/.+ (/.of_units expected_currency (/.units expected)) + (/.of_sub_units expected_currency (/.sub_units expected)))] + (/.= expected actual))) (do ! [it ..random] (_.coverage [/.format] diff --git a/stdlib/source/test/lux/world/money/currency.lux b/stdlib/source/test/lux/world/money/currency.lux index 927ffd8f3..eeb59e9fc 100644 --- a/stdlib/source/test/lux/world/money/currency.lux +++ b/stdlib/source/test/lux/world/money/currency.lux @@ -240,8 +240,8 @@ (set.of_list n.hash))] (n.= (list.size options) (set.size uniques)))) - (_.coverage [/.subdivisions] - (list.every? (|>> /.subdivisions (n.> 0)) + (_.coverage [/.sub_divisions] + (list.every? (|>> /.sub_divisions (n.> 0)) options)) ))) (<| (_.for [/.currency /.type]) diff --git a/stdlib/source/test/lux/world/net/http/response.lux b/stdlib/source/test/lux/world/net/http/response.lux index d25d3ce7f..bd3ee75aa 100644 --- a/stdlib/source/test/lux/world/net/http/response.lux +++ b/stdlib/source/test/lux/world/net/http/response.lux @@ -11,7 +11,7 @@ ["[0]" product] ["[0]" binary (.use "[1]#[0]" equivalence)] ["[0]" color - [named + [rgb ["[1]T" \\test]]] ["[0]" text (.use "[1]#[0]" equivalence) [encoding -- cgit v1.2.3