diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/library/lux/data/color.lux | 135 | ||||
| -rw-r--r-- | stdlib/source/library/lux/data/color/hsb.lux | 152 | ||||
| -rw-r--r-- | stdlib/source/library/lux/data/color/hsl.lux | 39 | ||||
| -rw-r--r-- | stdlib/source/library/lux/math/number/i16.lux | 30 | ||||
| -rw-r--r-- | stdlib/source/library/lux/math/number/i32.lux | 34 | ||||
| -rw-r--r-- | stdlib/source/library/lux/math/number/i8.lux | 30 | ||||
| -rw-r--r-- | stdlib/source/library/lux/meta/type/quotient.lux | 86 | ||||
| -rw-r--r-- | stdlib/source/library/lux/meta/type/refinement.lux | 101 | ||||
| -rw-r--r-- | stdlib/source/library/lux/test/benchmark.lux | 54 | ||||
| -rw-r--r-- | stdlib/source/library/lux/world/money/currency.lux | 37 | ||||
| -rw-r--r-- | stdlib/source/library/lux/world/time/duration.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/color/hsb.lux | 88 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/color/hsl.lux | 55 | ||||
| -rw-r--r-- | stdlib/source/test/lux/math/number/complex.lux | 3 | ||||
| -rw-r--r-- | stdlib/source/test/lux/test.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/test/lux/test/benchmark.lux | 68 |
16 files changed, 619 insertions, 301 deletions
diff --git a/stdlib/source/library/lux/data/color.lux b/stdlib/source/library/lux/data/color.lux index 23388a61c..fc79bb0db 100644 --- a/stdlib/source/library/lux/data/color.lux +++ b/stdlib/source/library/lux/data/color.lux @@ -22,24 +22,8 @@ ["[0]" nominal]]]]] [/ ["[0]" rgb (.only RGB)] - ["[0]" hsl]]) - -(def top - (-- rgb.limit)) - -(def rgb_factor - (|> top .int int.frac)) - -(def down - (-> Nat Frac) - (|>> .int int.frac (f./ rgb_factor))) - -(def up - (-> Frac Nat) - (|>> (f.* rgb_factor) f.int .nat)) - -(type .public HSB - [Frac Frac Frac]) + ["[0]" hsl] + ["[0]" hsb]]) (nominal.def .public Color RGB @@ -94,57 +78,6 @@ nominal.abstraction)) ) -(def .public (hsb color) - (-> Color HSB) - (let [[red green blue] (rgb color) - red (..down (rgb.number red)) - green (..down (rgb.number green)) - blue (..down (rgb.number blue)) - max (all f.max red green blue) - min (all f.min red green blue) - brightness max - diff (|> max (f.- min)) - saturation (if (f.= +0.0 max) - +0.0 - (|> diff (f./ max)))] - (if (f.= max min) - ... Achromatic - [+0.0 saturation brightness] - ... Chromatic - (let [hue (cond (f.= red max) - (|> green (f.- blue) (f./ diff) - (f.+ (if (f.< blue green) +6.0 +0.0))) - - (f.= green max) - (|> blue (f.- red) (f./ diff) - (f.+ +2.0)) - - ... (f.= blue max) - (|> red (f.- green) (f./ diff) - (f.+ +4.0)))] - [(|> hue (f./ +6.0)) - saturation - brightness])))) - -(def .public (of_hsb [hue saturation brightness]) - (-> HSB Color) - (let [hue (|> hue (f.* +6.0)) - i (f.floor hue) - f (|> hue (f.- i)) - p (|> +1.0 (f.- saturation) (f.* brightness)) - q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness)) - t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness)) - v brightness - mod (|> i (f.% +6.0) f.int .nat) - red (when mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined)) - green (when mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined)) - blue (when mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))] - (|> (rgb.rgb (..up red) - (..up green) - (..up blue)) - try.trusted - of_rgb))) - (def (normal ratio) (-> Frac Frac) (cond (f.> +1.0 ratio) @@ -184,16 +117,15 @@ ) (with_template [<op> <name>] - [(def .public (<name> ratio color) + [(def .public (<name> ratio it) (-> Frac Color Color) - (let [color (hsl.of_rgb (rgb color))] - (|> (hsl.hsl (hsl.hue color) - (|> color + (let [it (hsl.of_rgb (rgb it))] + (|> (hsl.hsl (hsl.hue it) + (|> it hsl.saturation (f.* (|> +1.0 (<op> (..normal ratio)))) (f.min +1.0)) - (hsl.luminance color)) - try.trusted + (hsl.luminance it)) hsl.rgb of_rgb)))] @@ -207,7 +139,6 @@ (|> (hsl.hsl +0.0 +0.0 (hsl.luminance color)) - try.trusted hsl.rgb of_rgb))) @@ -222,13 +153,11 @@ (|> (hsl.hsl (|> hue (f.+ <1>) ..normal) saturation luminance) - try.trusted hsl.rgb of_rgb) (|> (hsl.hsl (|> hue (f.+ <2>) ..normal) saturation luminance) - try.trusted hsl.rgb of_rgb)])))] @@ -240,17 +169,20 @@ (with_template [<name> <1> <2> <3>] [(`` (def .public (<name> color) (-> Color [Color Color Color Color]) - (let [[hue saturation luminance] (hsb color)] + (let [it (hsl.of_rgb (..rgb color)) + hue (hsl.hue it) + saturation (hsl.saturation it) + luminance (hsl.luminance it) + of_hue (is (-> hsl.Value + Color) + (function (_ hue) + (|> (hsl.hsl hue saturation luminance) + hsl.rgb + ..of_rgb)))] [color - (of_hsb [(|> hue (f.+ <1>) ..normal) - saturation - luminance]) - (of_hsb [(|> hue (f.+ <2>) ..normal) - saturation - luminance]) - (of_hsb [(|> hue (f.+ <3>) ..normal) - saturation - luminance])])))] + (|> hue (f.+ <1>) ..normal of_hue) + (|> hue (f.+ <2>) ..normal of_hue) + (|> hue (f.+ <3>) ..normal 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))] @@ -262,27 +194,36 @@ (type .public Palette (-> Spread Nat Color (List Color))) -(def .public (analogous spread variations color) +(def .public (analogous spread variations it) Palette - (let [[hue saturation brightness] (hsb color) + (let [it (hsl.of_rgb (..rgb it)) + hue (hsl.hue it) + saturation (hsl.saturation it) + luminance (hsl.luminance it) spread (..normal spread)] (list#each (function (_ idx) - (of_hsb [(|> idx ++ .int int.frac (f.* spread) (f.+ hue) ..normal) - saturation - brightness])) + (|> (hsl.hsl (|> idx ++ .int int.frac (f.* spread) (f.+ hue) ..normal) + saturation + luminance) + hsl.rgb + ..of_rgb)) (list.indices variations)))) -(def .public (monochromatic spread variations color) +(def .public (monochromatic spread variations it) Palette - (let [[hue saturation brightness] (hsb color) + (let [it (hsb.of_rgb (..rgb it)) + hue (hsb.hue it) + saturation (hsb.saturation it) + brightness (hsb.brightness it) spread (..normal spread)] (|> (list.indices variations) (list#each (|>> ++ .int int.frac (f.* spread) (f.+ brightness) ..normal - [hue saturation] - of_hsb))))) + (hsb.hsb hue saturation) + hsb.rgb + ..of_rgb))))) (type .public Alpha Rev) diff --git a/stdlib/source/library/lux/data/color/hsb.lux b/stdlib/source/library/lux/data/color/hsb.lux new file mode 100644 index 000000000..9f07a50eb --- /dev/null +++ b/stdlib/source/library/lux/data/color/hsb.lux @@ -0,0 +1,152 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [control + ["[0]" try] + [function + [predicate (.only Predicate)]]] + [math + [number + ["f" frac] + ["[0]" int]]] + [meta + [type + ["[0]" nominal]]]]] + [// + ["[0]" rgb (.only RGB)]]) + +(type .public Value + Frac) + +(with_template [<value> <name>] + [(def .public <name> + Value + <value>)] + + [+0.0 least] + [+1.0 most] + ) + +(def .public (value? it) + (Predicate Frac) + (not (or (f.< ..least it) + (f.> ..most it)))) + +(def .public value + (-> Frac + Value) + (|>> (f.max ..least) + (f.min ..most))) + +(nominal.def .public HSB + (Record + [#hue Value + #saturation Value + #brightness Value]) + + (def .public equivalence + (Equivalence HSB) + (implementation + (def (= left right) + (`` (and (,, (with_template [<slot>] + [(f.= (the <slot> (nominal.representation left)) + (the <slot> (nominal.representation right)))] + + [#hue] + [#saturation] + [#brightness] + ))))))) + + (with_template [<name> <slot>] + [(def .public <name> + (-> HSB + Value) + (|>> nominal.representation + (the <slot>)))] + + [hue #hue] + [saturation #saturation] + [brightness #brightness] + ) + + (def .public (hsb hue saturation brightness) + (-> Frac Frac Frac + HSB) + (nominal.abstraction + [#hue (..value hue) + #saturation (..value saturation) + #brightness (..value brightness)])) + + (def top + (-- rgb.limit)) + + (def rgb_factor + (|> top .int int.frac)) + + (def down + (-> Nat + Frac) + (|>> .int int.frac (f./ rgb_factor))) + + (def up + (-> Frac + Nat) + (|>> (f.* rgb_factor) f.int .nat)) + + (def .public (of_rgb it) + (-> RGB + HSB) + (let [red (..down (rgb.number (the rgb.#red it))) + green (..down (rgb.number (the rgb.#green it))) + blue (..down (rgb.number (the rgb.#blue it))) + + max (all f.max red green blue) + min (all f.min red green blue) + + brightness max + diff (|> max (f.- min)) + saturation (if (f.= +0.0 max) + +0.0 + (|> diff (f./ max)))] + (nominal.abstraction + [#hue (if (f.= max min) + ... Achromatic + +0.0 + ... Chromatic + (cond (f.= max red) + (|> green (f.- blue) (f./ diff) + (f.+ (if (f.< blue green) +6.0 +0.0))) + + (f.= max green) + (|> blue (f.- red) (f./ diff) + (f.+ +2.0)) + + ... (f.= max blue) + (|> red (f.- green) (f./ diff) + (f.+ +4.0)))) + #saturation saturation + #brightness brightness]))) + + (def .public (rgb it) + (-> HSB + RGB) + (let [[hue saturation brightness] (nominal.representation it) + hue (|> hue (f.* +6.0)) + i (f.floor hue) + f (|> hue (f.- i)) + p (|> +1.0 (f.- saturation) (f.* brightness)) + q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness)) + t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness)) + v brightness + mod (|> i (f.% +6.0) f.int .nat) + + red (when mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined)) + green (when mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined)) + blue (when mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))] + (try.trusted + (rgb.rgb (..up red) + (..up green) + (..up blue))))) + ) diff --git a/stdlib/source/library/lux/data/color/hsl.lux b/stdlib/source/library/lux/data/color/hsl.lux index dd2155f2f..4a4c13097 100644 --- a/stdlib/source/library/lux/data/color/hsl.lux +++ b/stdlib/source/library/lux/data/color/hsl.lux @@ -5,8 +5,9 @@ [equivalence (.only Equivalence)] [monad (.only do)]] [control - ["[0]" try (.only Try)] - ["[0]" exception (.only Exception)]] + ["[0]" try] + [function + [predicate (.only Predicate)]]] [data [text ["%" \\format]]] @@ -48,20 +49,16 @@ [+1.0 most] ) -(exception.def .public (invalid value) - (Exception Frac) - (exception.report - (list ["Value" (%.frac value)] - ["Minimum" (%.frac ..least)] - ["Maximum" (%.frac ..most)]))) +(def .public (value? it) + (Predicate Frac) + (not (or (f.< ..least it) + (f.> ..most it)))) -(def .public (value it) +(def .public value (-> Frac - (Try Value)) - (if (or (f.< ..least it) - (f.> ..most it)) - (exception.except ..invalid [it]) - {try.#Success it})) + Value) + (|>> (f.max ..least) + (f.min ..most))) (nominal.def .public HSL (Record @@ -96,15 +93,11 @@ (def .public (hsl hue saturation luminance) (-> Frac Frac Frac - (Try HSL)) - (do try.monad - [hue (..value hue) - saturation (..value saturation) - luminance (..value luminance)] - (in (nominal.abstraction - [#hue hue - #saturation saturation - #luminance luminance])))) + HSL) + (nominal.abstraction + [#hue (..value hue) + #saturation (..value saturation) + #luminance (..value luminance)])) (def .public (of_rgb it) (-> RGB diff --git a/stdlib/source/library/lux/math/number/i16.lux b/stdlib/source/library/lux/math/number/i16.lux index 53c71f68f..04ee87a9e 100644 --- a/stdlib/source/library/lux/math/number/i16.lux +++ b/stdlib/source/library/lux/math/number/i16.lux @@ -4,29 +4,25 @@ [abstract [equivalence (.only Equivalence)]] [control - ["[0]" maybe]] + ["?" parser] + ["[0]" maybe] + ["[0]" try]] [meta - [type (.only by_example)]]]] + ["[0]" static] + ["[0]" type (.only) + ["?[1]" \\parser]]]]] [// - ["[0]" i64 (.only Sub)]]) + ["[0]" i64]]) (def sub (maybe.trusted (i64.sub 16))) -(def .public I16 - Type - ... TODO: Switch to the cleaner approach ASAP. - (when (type_of ..sub) - {.#Apply :size: :sub:} - (type_literal (I64 :size:)) - - _ - (undefined)) - ... (by_example [size] - ... (is (Sub size) - ... ..sub) - ... (I64 size)) - ) +(`` (type .public I16 + (I64 (,, (|> (type_of ..sub) + (?type.result (?type.applied (?.after (?type.exactly i64.Sub) + ?type.any))) + try.trusted + (static.literal type.code)))))) (def .public equivalence (Equivalence I16) (at ..sub sub_equivalence)) (def .public width Nat (at ..sub bits)) diff --git a/stdlib/source/library/lux/math/number/i32.lux b/stdlib/source/library/lux/math/number/i32.lux index af4d6d592..e2bce4938 100644 --- a/stdlib/source/library/lux/math/number/i32.lux +++ b/stdlib/source/library/lux/math/number/i32.lux @@ -4,31 +4,25 @@ [abstract [equivalence (.only Equivalence)]] [control - ["[0]" maybe]] + ["?" parser] + ["[0]" maybe] + ["[0]" try]] [meta - [type (.only by_example)]]]] + ["[0]" static] + ["[0]" type (.only) + ["?[1]" \\parser]]]]] [// - ["[0]" i64 (.only Sub)]]) + ["[0]" i64]]) (def sub - ... TODO: Stop needing this coercion. - (as (Sub (I64 (Nominal "#I32"))) - (maybe.trusted (i64.sub 32)))) + (maybe.trusted (i64.sub 32))) -(def .public I32 - Type - ... TODO: Switch to the cleaner approach ASAP. - (when (type_of ..sub) - {.#Apply :size: :sub:} - (type_literal (I64 :size:)) - - _ - (undefined)) - ... (by_example [size] - ... (is (Sub size) - ... ..sub) - ... (I64 size)) - ) +(`` (type .public I32 + (I64 (,, (|> (type_of ..sub) + (?type.result (?type.applied (?.after (?type.exactly i64.Sub) + ?type.any))) + try.trusted + (static.literal type.code)))))) (def .public equivalence (Equivalence I32) (at ..sub sub_equivalence)) (def .public width Nat (at ..sub bits)) diff --git a/stdlib/source/library/lux/math/number/i8.lux b/stdlib/source/library/lux/math/number/i8.lux index d4ac05aaf..5a36246c6 100644 --- a/stdlib/source/library/lux/math/number/i8.lux +++ b/stdlib/source/library/lux/math/number/i8.lux @@ -4,29 +4,25 @@ [abstract [equivalence (.only Equivalence)]] [control - ["[0]" maybe]] + ["?" parser] + ["[0]" maybe] + ["[0]" try]] [meta - [type (.only by_example)]]]] + ["[0]" static] + ["[0]" type (.only) + ["?[1]" \\parser]]]]] [// - ["[0]" i64 (.only Sub)]]) + ["[0]" i64]]) (def sub (maybe.trusted (i64.sub 8))) -(def .public I8 - Type - ... TODO: Switch to the cleaner approach ASAP. - (when (type_of ..sub) - {.#Apply :size: :sub:} - (type_literal (I64 :size:)) - - _ - (undefined)) - ... (by_example [size] - ... (is (Sub size) - ... ..sub) - ... (I64 size)) - ) +(`` (type .public I8 + (I64 (,, (|> (type_of ..sub) + (?type.result (?type.applied (?.after (?type.exactly i64.Sub) + ?type.any))) + try.trusted + (static.literal type.code)))))) (def .public equivalence (Equivalence I8) (at ..sub sub_equivalence)) (def .public width Nat (at ..sub bits)) diff --git a/stdlib/source/library/lux/meta/type/quotient.lux b/stdlib/source/library/lux/meta/type/quotient.lux index ab043d3ff..57b3ec811 100644 --- a/stdlib/source/library/lux/meta/type/quotient.lux +++ b/stdlib/source/library/lux/meta/type/quotient.lux @@ -2,69 +2,79 @@ [library [lux (.except type) [abstract - [equivalence (only Equivalence)]] - [meta + [equivalence (.only Equivalence)] + [monad (.only do)]] + [control + ["?" parser]] + ["[0]" meta (.only) ["[0]" code ["<[1]>" \\parser]] - [macro (.only with_symbols) + ["[0]" macro (.only) [syntax (.only syntax)]]]]] ["[0]" // (.only) + ["?[1]" \\parser] ["[0]" nominal (.except def)]]) -(nominal.def .public (Class t c %) - (-> t c) +(nominal.def .public (Class super sub %) + (-> super + sub) (def .public class - (All (_ t c) + (All (_ super sub) (Ex (_ %) - (-> (-> t c) (Class t c %)))) + (-> (-> super sub) + (Class super sub %)))) (|>> abstraction)) - (nominal.def .public (Quotient t c %) + (nominal.def .public (Quotient super sub %) (Record - [#value t - #label c]) + [#value super + #label sub]) (def .public (quotient class value) - (All (_ t c %) - (-> (Class t c %) t - (Quotient t c %))) + (All (_ super sub %) + (-> (Class super sub %) super + (Quotient super sub %))) (abstraction [#value value #label ((representation Class class) value)])) - (with_template [<name> <output> <slot>] + (with_template [<name> <slot> <output>] [(def .public <name> - (All (_ t c %) (-> (Quotient t c %) <output>)) - (|>> representation (the <slot>)))] + (All (_ super sub %) + (-> (Quotient super sub %) + <output>)) + (|>> representation + (the <slot>)))] - [value t #value] - [label c #label] + [value #value super] + [label #label sub] ) ) ) (def .public type - (syntax (_ [class <code>.any]) - ... TODO: Switch to the cleaner approach ASAP. - (with_symbols [g!t g!c g!% g!_ g!:quotient:] - (in (list (` (let [ ... (, g!_) (.is (.Ex ((, g!_) (, g!t) (, g!c) (, g!%)) - ... (..Class (, g!t) (, g!c) (, g!%))) - ... (, class)) - ] - (.when (.type_of (, class)) - {.#Apply (, g!%) {.#Apply (, g!c) {.#Apply (, g!t) (, g!:quotient:)}}} - (.type_literal (..Quotient (, g!t) (, g!c) (, g!%))) - - (, g!_) - (.undefined)))) - ... (` (//.by_example [(, g!t) (, g!c) (, g!%)] - ... (is (..Class (, g!t) (, g!c) (, g!%)) - ... (, class)) - ... (..Quotient (, g!t) (, g!c) (, g!%)))) - ))))) + (syntax (_ [it <code>.any]) + (macro.with_symbols ['_ 'super 'sub '%] + (do meta.monad + [it (meta.eval Type (` (.type_of ((is (All ((, '_) (, 'super) (, 'sub) (, '%)) + (-> (..Class (, 'super) (, 'sub) (, '%)) + (..Class (, 'super) (, 'sub) (, '%)))) + (|>>)) + (, it))))) + [super sub %] (|> (as Type it) + (?//.result (?//.applied (?.after (?//.exactly ..Class) + (all ?.and ?//.any ?//.any ?//.any)))) + meta.of_try)] + (in (list (` (.type_literal (..Quotient (, (//.code super)) + (, (//.code sub)) + (, (//.code %))))))))))) (def .public (equivalence super) - (All (_ t c %) (-> (Equivalence c) (Equivalence (..Quotient t c %)))) + (All (_ super sub %) + (-> (Equivalence sub) + (Equivalence (..Quotient super sub %)))) (implementation (def (= reference sample) - (at super = (..label reference) (..label sample))))) + (at super = + (..label reference) + (..label sample))))) diff --git a/stdlib/source/library/lux/meta/type/refinement.lux b/stdlib/source/library/lux/meta/type/refinement.lux index f1778d1b1..f886f175c 100644 --- a/stdlib/source/library/lux/meta/type/refinement.lux +++ b/stdlib/source/library/lux/meta/type/refinement.lux @@ -1,48 +1,58 @@ (.require [library [lux (.except only type) + [abstract + [monad (.only do)]] [control + ["?" parser] [function [predicate (.only Predicate)]]] - [meta + ["[0]" meta (.only) ["[0]" code ["<[1]>" \\parser]] ["[0]" macro (.only) [syntax (.only syntax)]]]]] ["[0]" // (.only) + ["?[1]" \\parser] ["[0]" nominal (.except def)]]) -(nominal.def .public (Refined t %) +(nominal.def .public (Refined super %) (Record - [#value t - #predicate (Predicate t)]) + [#value super + #predicate (Predicate super)]) - (.type .public (Refiner t %) - (-> t (Maybe (Refined t %)))) + (.type .public (Refiner super %) + (-> super + (Maybe (Refined super %)))) (def .public (refiner predicate) - (All (_ t) + (All (_ super) (Ex (_ %) - (-> (Predicate t) (Refiner t %)))) + (-> (Predicate super) + (Refiner super %)))) (function (_ value) (if (predicate value) {.#Some (abstraction [#value value #predicate predicate])} {.#None}))) - (with_template [<name> <output> <slot>] + (with_template [<name> <slot> <output>] [(def .public <name> - (All (_ t %) (-> (Refined t %) <output>)) - (|>> representation (the <slot>)))] + (All (_ super %) + (-> (Refined super %) + <output>)) + (|>> representation + (the <slot>)))] - [value t #value] - [predicate (Predicate t) #predicate] + [value #value super] + [predicate #predicate (Predicate super)] ) (def .public (lifted transform) - (All (_ t %) - (-> (-> t t) - (-> (Refined t %) (Maybe (Refined t %))))) + (All (_ super %) + (-> (-> super super) + (-> (Refined super %) + (Maybe (Refined super %))))) (function (_ refined) (let [(open "_[0]") (representation refined) value' (transform _#value)] @@ -53,27 +63,27 @@ ) (def .public (only refiner values) - (All (_ t %) - (-> (Refiner t %) (List t) (List (Refined t %)))) + (All (_ super %) + (-> (Refiner super %) (List super) + (List (Refined super %)))) (when values - {.#End} - {.#End} - {.#Item head tail} (when (refiner head) {.#Some refined} {.#Item refined (only refiner tail)} {.#None} - (only refiner tail)))) + (only refiner tail)) -(def .public (partition refiner values) - (All (_ t %) - (-> (Refiner t %) (List t) [(List (Refined t %)) (List t)])) - (when values {.#End} - [{.#End} {.#End}] + {.#End})) +(def .public (partition refiner values) + (All (_ super %) + (-> (Refiner super %) (List super) + [(List (Refined super %)) + (List super)])) + (when values {.#Item head tail} (let [[yes no] (partition refiner tail)] (when (refiner head) @@ -83,24 +93,23 @@ {.#None} [yes - {.#Item head no}])))) + {.#Item head no}])) -(def .public type - (syntax (_ [refiner <code>.any]) - ... TODO: Switch to the cleaner approach ASAP. - (macro.with_symbols [g!t g!% g!_ g!:refiner:] - (in (list (` (let [ ... (, g!_) (.is (.Ex ((, g!_) (, g!t) (, g!%)) - ... (..Refined (, g!t) (, g!%))) - ... (, refiner)) - ] - (.when (.type_of (, refiner)) - {.#Apply (, g!%) {.#Apply (, g!t) (, g!:refiner:)}} - (.type_literal (..Refined (, g!t) (, g!%))) + {.#End} + [{.#End} {.#End}])) - (, g!_) - (.undefined)))) - ... (` (//.by_example [(, g!t) (, g!%)] - ... (is (..Refiner (, g!t) (, g!%)) - ... (, refiner)) - ... (..Refined (, g!t) (, g!%)))) - ))))) +(def .public type + (syntax (_ [it <code>.any]) + (macro.with_symbols ['_ 'super '%] + (do meta.monad + [it (meta.eval Type (` (.type_of ((is (All ((, '_) (, 'super) (, '%)) + (-> (..Refiner (, 'super) (, '%)) + (..Refiner (, 'super) (, '%)))) + (|>>)) + (, it))))) + [super %] (|> (as Type it) + (?//.result (?//.applied (?.after (?//.exactly ..Refiner) + (all ?.and ?//.any ?//.any)))) + meta.of_try)] + (in (list (` (.type_literal (..Refined (, (//.code super)) + (, (//.code %))))))))))) diff --git a/stdlib/source/library/lux/test/benchmark.lux b/stdlib/source/library/lux/test/benchmark.lux new file mode 100644 index 000000000..427e62822 --- /dev/null +++ b/stdlib/source/library/lux/test/benchmark.lux @@ -0,0 +1,54 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)] + ["[0]" order]] + [control + ["[0]" io (.only IO) (.use "[1]#[0]" monad)]] + [data + [collection + ["[0]" list (.use "[1]#[0]" mix)]]] + [world + [time + ["[0]" instant] + ["[0]" duration (.only Duration)]]]]]) + +(def .public (time subject) + (-> (IO Any) + (IO Duration)) + (do io.monad + [before instant.now + _ subject + after instant.now] + (in (instant.span before after)))) + +(type .public Benchmark + (Record + [#times Nat + #minimum Duration + #maximum Duration + #average Duration])) + +(def empty + Benchmark + [#times 0 + #minimum duration.empty + #maximum duration.empty + #average duration.empty]) + +(def .public (test times subject) + (-> Nat (IO Any) + (IO Benchmark)) + (when times + 0 (io#in ..empty) + _ (do [! io.monad] + [durations (|> subject + (list.repeated times) + (monad.each ! ..time))] + (in [#times times + #minimum (list#mix (order.min duration.order) duration.empty durations) + #maximum (list#mix (order.max duration.order) duration.empty durations) + #average (|> durations + (list#mix duration.composite duration.empty) + (duration.down times))])))) diff --git a/stdlib/source/library/lux/world/money/currency.lux b/stdlib/source/library/lux/world/money/currency.lux index fdb3ef16b..9b4abccda 100644 --- a/stdlib/source/library/lux/world/money/currency.lux +++ b/stdlib/source/library/lux/world/money/currency.lux @@ -3,15 +3,23 @@ [library [lux (.except type all try) [abstract - ["[0]" equivalence (.only Equivalence)]] + ["[0]" equivalence (.only Equivalence)] + [monad (.only do)]] + [control + ["?" parser]] [data ["[0]" product] ["[0]" text]] [math [number ["n" nat]]] - [meta - [type + ["[0]" meta (.only) + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["[0]" code + ["?[1]" \\parser]] + ["[0]" type (.only) + ["?[1]" \\parser] ["[0]" nominal]]]]]) (nominal.def .public (Currency of) @@ -54,16 +62,19 @@ ) (def .public type - (template (_ <currency>) - ... TODO: Switch to the cleaner approach ASAP. - [(when (type_of <currency>) - {.#Apply it currency?} - (if (same? Currency currency?) - it - (undefined)) - - _ - (undefined))])) + (syntax (_ [it ?code.any]) + (macro.with_symbols ['_ 'of] + (do meta.monad + [it (meta.eval Type (` (.type_of ((is (All ((, '_) (, 'of)) + (-> (..Currency (, 'of)) + (..Currency (, 'of)))) + (|>>)) + (, it))))) + of (|> (as Type it) + (?type.result (?type.applied (?.after (?type.exactly ..Currency) + ?type.any))) + meta.of_try)] + (in (list (type.code of))))))) (def (power parameter subject) (-> Nat Nat diff --git a/stdlib/source/library/lux/world/time/duration.lux b/stdlib/source/library/lux/world/time/duration.lux index 627348295..fec1db917 100644 --- a/stdlib/source/library/lux/world/time/duration.lux +++ b/stdlib/source/library/lux/world/time/duration.lux @@ -86,13 +86,16 @@ ) (def .public empty + Duration (..of_millis +0)) (def .public milli_second + Duration (..of_millis +1)) (with_template [<name> <scale> <base>] [(def .public <name> + Duration (..up <scale> <base>))] [second 1,000 milli_second] @@ -105,6 +108,7 @@ ) (def .public leap_year + Duration (..composite ..day ..normal_year)) (def .public monoid diff --git a/stdlib/source/test/lux/data/color/hsb.lux b/stdlib/source/test/lux/data/color/hsb.lux new file mode 100644 index 000000000..16f6d9dfb --- /dev/null +++ b/stdlib/source/test/lux/data/color/hsb.lux @@ -0,0 +1,88 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)] + [\\specification + ["[0]S" equivalence]]] + [math + ["[0]" random (.only Random) (.use "[1]#[0]" monad)] + [number + ["f" frac]]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" / (.only) + [// + ["[0]" rgb]]]] + [// + ["[0]T" rgb]]) + +(def .public value + (Random /.Value) + (random#each /.value random.safe_frac)) + +(def .public random + (Random /.HSB) + (do random.monad + [hue ..value + saturation ..value + brightness ..value] + (in (/.hsb hue saturation brightness)))) + +(def .public test + Test + (<| (_.covering /._) + (do [! random.monad] + [expected_value ..value + expected_rgb rgbT.random + expected_hsb ..random + + possible_value random.frac]) + (all _.and + (_.for [/.Value] + (all _.and + (_.coverage [/.value?] + (and (/.value? expected_value) + (not (/.value? (f.+ f.smallest /.most))) + (not (/.value? (f.- f.smallest /.least))))) + (_.coverage [/.value] + (if (/.value? possible_value) + (|> possible_value + /.value + (f.= possible_value)) + (or (f.= /.least (/.value possible_value)) + (f.= /.most (/.value possible_value))))) + (_.coverage [/.least] + (and (f.< /.most + /.least) + (/.value? /.least) + (/.value? (f.+ f.smallest /.least)) + (not (/.value? (f.- f.smallest /.least))))) + (_.coverage [/.most] + (and (f.> /.least + /.most) + (/.value? /.most) + (/.value? (f.- f.smallest /.most)) + (not (/.value? (f.+ f.smallest /.most))))) + )) + (_.for [/.HSB] + (all _.and + (_.for [/.equivalence] + (equivalenceS.spec /.equivalence ..random)) + + (_.coverage [/.hsb + /.hue /.saturation /.brightness] + (|> (/.hsb (/.hue expected_hsb) (/.saturation expected_hsb) (/.brightness expected_hsb)) + (at /.equivalence = expected_hsb))) + (_.coverage [/.of_rgb /.rgb] + (and (|> expected_rgb + /.of_rgb + /.rgb + (at rgb.equivalence = expected_rgb)) + (|> expected_hsb + /.rgb + /.of_rgb + (at /.equivalence = expected_hsb)))) + )) + ))) diff --git a/stdlib/source/test/lux/data/color/hsl.lux b/stdlib/source/test/lux/data/color/hsl.lux index b3221e03b..a0524d2b1 100644 --- a/stdlib/source/test/lux/data/color/hsl.lux +++ b/stdlib/source/test/lux/data/color/hsl.lux @@ -5,11 +5,8 @@ [monad (.only do)] [\\specification ["[0]S" equivalence]]] - [control - ["[0]" try (.use "[1]#[0]" functor)] - ["[0]" exception]] [math - ["[0]" random (.only Random)] + ["[0]" random (.only Random) (.use "[1]#[0]" monad)] [number ["f" frac]]] [test @@ -23,8 +20,7 @@ (def .public value (Random /.Value) - (random.one (|>> /.value try.maybe) - random.safe_frac)) + (random#each /.value random.safe_frac)) (def .public random (Random /.HSL) @@ -32,8 +28,7 @@ [hue ..value saturation ..value luminance ..value] - (random.one (|>> try.maybe) - (in (/.hsl hue saturation luminance))))) + (in (/.hsl hue saturation luminance)))) (def .public test Test @@ -41,30 +36,35 @@ (do [! random.monad] [expected_value ..value expected_rgb rgbT.random - expected_hsl ..random]) + expected_hsl ..random + + possible_value random.frac]) (all _.and (_.for [/.Value] (all _.and + (_.coverage [/.value?] + (and (/.value? expected_value) + (not (/.value? (f.+ f.smallest /.most))) + (not (/.value? (f.- f.smallest /.least))))) (_.coverage [/.value] - (|> expected_value - /.value - (try#each (f.= expected_value)) - (try.else false))) + (if (/.value? possible_value) + (|> possible_value + /.value + (f.= possible_value)) + (or (f.= /.least (/.value possible_value)) + (f.= /.most (/.value possible_value))))) (_.coverage [/.least] - (when (/.value (f.+ +0.001 /.least)) - {try.#Failure _} false - {try.#Success _} true)) + (and (f.< /.most + /.least) + (/.value? /.least) + (/.value? (f.+ f.smallest /.least)) + (not (/.value? (f.- f.smallest /.least))))) (_.coverage [/.most] - (when (/.value (f.- +0.001 /.most)) - {try.#Failure _} false - {try.#Success _} true)) - (_.coverage [/.invalid] - (and (when (/.value (f.- +0.001 /.least)) - {try.#Failure it} (exception.match? /.invalid it) - {try.#Success _} false) - (when (/.value (f.+ +0.001 /.most)) - {try.#Failure it} (exception.match? /.invalid it) - {try.#Success _} false))) + (and (f.> /.least + /.most) + (/.value? /.most) + (/.value? (f.- f.smallest /.most)) + (not (/.value? (f.+ f.smallest /.most))))) )) (_.for [/.HSL] (all _.and @@ -74,8 +74,7 @@ (_.coverage [/.hsl /.hue /.saturation /.luminance] (|> (/.hsl (/.hue expected_hsl) (/.saturation expected_hsl) (/.luminance expected_hsl)) - (try#each (at /.equivalence = expected_hsl)) - (try.else false))) + (at /.equivalence = expected_hsl))) (_.coverage [/.of_rgb /.rgb] (and (|> expected_rgb /.of_rgb diff --git a/stdlib/source/test/lux/math/number/complex.lux b/stdlib/source/test/lux/math/number/complex.lux index 18fbdd28e..501d01cd0 100644 --- a/stdlib/source/test/lux/math/number/complex.lux +++ b/stdlib/source/test/lux/math/number/complex.lux @@ -270,7 +270,8 @@ (def .public test Test (<| (_.covering /._) - (_.for [/.Complex]) + (_.for [/.Complex + /.#imaginary /.#real]) (all _.and (_.for [/.= /.equivalence] ($equivalence.spec /.equivalence ..random)) diff --git a/stdlib/source/test/lux/test.lux b/stdlib/source/test/lux/test.lux index 34891bf65..fd206f642 100644 --- a/stdlib/source/test/lux/test.lux +++ b/stdlib/source/test/lux/test.lux @@ -8,7 +8,8 @@ ["[1][0]" tally] ["[1][0]" unit] ["[1][0]" property] - ["[1][0]" inline]]) + ["[1][0]" inline] + ["[1][0]" benchmark]]) (def .public test Test @@ -18,4 +19,5 @@ /unit.test /property.test /inline.test + /benchmark.test )) diff --git a/stdlib/source/test/lux/test/benchmark.lux b/stdlib/source/test/lux/test/benchmark.lux new file mode 100644 index 000000000..740d444cf --- /dev/null +++ b/stdlib/source/test/lux/test/benchmark.lux @@ -0,0 +1,68 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)] + ["[0]" order]] + [control + ["[0]" io (.only IO)]] + [math + ["[0]" random (.only Random)] + [number + ["n" nat] + ["f" frac]]] + [world + [time + ["[0]" duration]]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" /]]) + +(def .public test + Test + (<| (_.covering /._) + (do [! random.monad] + [angle random.safe_frac + + times (at ! each (n.% 10) random.nat) + + .let [computation (is (IO Frac) + (io.io (|> angle + f.cos f.acos + f.sin f.asin + f.tan f.atan + f.exp f.log)))]]) + (all _.and + (_.coverage [/.time] + (io.run! + (do io.monad + [duration (/.time computation)] + (in (duration.positive? duration))))) + (<| (_.for [/.Benchmark + /.#times /.#minimum /.#maximum /.#average]) + (all _.and + (_.coverage [/.test] + (io.run! + (do io.monad + [it (/.test times computation)] + (in (and (n.= times (the /.#times it)) + (when times + 0 (and (duration.neutral? (the /.#minimum it)) + (duration.neutral? (the /.#maximum it)) + (duration.neutral? (the /.#average it))) + _ (and (duration.positive? (the /.#minimum it)) + (duration.positive? (the /.#maximum it)) + (duration.positive? (the /.#average it)) + + (order.<= duration.order + (the /.#maximum it) + (the /.#minimum it)) + (order.<= duration.order + (the /.#maximum it) + (the /.#average it)) + (order.>= duration.order + (the /.#minimum it) + (the /.#average it))))))))) + )) + ))) |