From de673c2adf9fdf848f8fff977a6cddc036cbfa9e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 4 Oct 2020 21:50:52 -0400 Subject: Test to make sure modules cannot import themselves. --- stdlib/source/lux/data/bit.lux | 4 +- stdlib/source/lux/data/color.lux | 164 +++++++++------ stdlib/source/lux/data/number/frac.lux | 14 +- stdlib/source/lux/time/date.lux | 100 ++++----- stdlib/source/lux/time/year.lux | 97 ++++++++- .../source/lux/tool/compiler/default/platform.lux | 149 +++++++------ stdlib/source/test/lux/data/bit.lux | 35 ++-- stdlib/source/test/lux/data/color.lux | 231 +++++++++++++++------ 8 files changed, 508 insertions(+), 286 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux index 3c1bcc02d..fee6eba92 100644 --- a/stdlib/source/lux/data/bit.lux +++ b/stdlib/source/lux/data/bit.lux @@ -37,7 +37,9 @@ [conjunction #1 and] ) -(structure: #export codec (Codec Text Bit) +(structure: #export codec + (Codec Text Bit) + (def: (encode x) (if x "#1" diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux index 36b9fdf6d..4334e7f41 100644 --- a/stdlib/source/lux/data/color.lux +++ b/stdlib/source/lux/data/color.lux @@ -1,23 +1,24 @@ (.module: [lux #* [abstract - [equivalence (#+ Equivalence)]] + [equivalence (#+ Equivalence)] + [monoid (#+ Monoid)]] [data [number ["n" nat] ["." int] - ["." rev ("#;." interval)] + ["." rev ("#@." interval)] ["f" frac]] [collection - ["." list ("#;." functor)]]] + ["." list ("#@." functor)]]] ["." math] [type abstract]]) -(def: rgb Nat 256) -(def: top Nat (dec rgb)) +(def: rgb 256) +(def: top (dec rgb)) -(def: rgb-factor Frac (|> top .int int.frac)) +(def: rgb-factor (|> top .int int.frac)) (def: scale-down (-> Nat Frac) @@ -49,21 +50,68 @@ (def: #export (from-rgb [red green blue]) (-> RGB Color) - (:abstraction {#red (n.% rgb red) - #green (n.% rgb green) - #blue (n.% rgb blue)})) + (:abstraction {#red (n.% ..rgb red) + #green (n.% ..rgb green) + #blue (n.% ..rgb blue)})) (def: #export to-rgb (-> Color RGB) (|>> :representation)) - (structure: #export equivalence (Equivalence Color) + (structure: #export equivalence + (Equivalence Color) + (def: (= reference sample) (let [[rr rg rb] (:representation reference) [sr sg sb] (:representation sample)] (and (n.= rr sr) (n.= rg sg) (n.= rb sb))))) + + (def: #export black + (..from-rgb {#red 0 + #green 0 + #blue 0})) + + (def: #export white + (..from-rgb {#red ..top + #green ..top + #blue ..top})) + + (structure: #export addition + (Monoid Color) + + (def: identity ..black) + + (def: (compose left right) + (let [[lR lG lB] (:representation left) + [rR rG rB] (:representation right)] + (:abstraction {#red (n.max lR rR) + #green (n.max lG rG) + #blue (n.max lB rB)})))) + + (def: (complement' value) + (-> Nat Nat) + (|> ..top (n.- value))) + + (def: #export (complement color) + (-> Color Color) + (let [[red green blue] (:representation color)] + (:abstraction {#red (complement' red) + #green (complement' green) + #blue (complement' blue)}))) + + (structure: #export subtraction + (Monoid Color) + + (def: identity ..white) + + (def: (compose left right) + (let [[lR lG lB] (:representation (..complement left)) + [rR rG rB] (:representation right)] + (:abstraction {#red (n.min lR rR) + #green (n.min lG rG) + #blue (n.min lB rB)})))) ) (def: #export (to-hsl color) @@ -227,14 +275,14 @@ (f.% +1.0 ratio) (f.< +0.0 ratio) - (|> +1.0 (f.+ (f.% +1.0 ratio))) + (|> ratio (f.% +1.0) (f.+ +1.0)) ## else ratio)) (def: #export (interpolate ratio end start) (-> Frac Color Color Color) - (let [dS (normalize ratio) + (let [dS (..normalize ratio) dE (|> +1.0 (f.- dS)) interpolate' (: (-> Nat Nat Nat) (function (_ end start) @@ -248,37 +296,22 @@ #green (interpolate' greenE greenS) #blue (interpolate' blueE blueS)}))) -(def: #export black (from-rgb {#red 0 - #green 0 - #blue 0})) -(def: #export white (from-rgb {#red top - #green top - #blue top})) - (template [ ] [(def: #export ( ratio color) (-> Frac Color Color) - (interpolate ratio color))] + (..interpolate ratio color))] [darker black] [brighter white] ) -(def: #export (complement color) - (-> Color Color) - (let [[red green blue] (to-rgb color) - adjust (function (_ value) (|> top (n.- value)))] - (from-rgb {#red (adjust red) - #green (adjust green) - #blue (adjust blue)}))) - (template [ ] [(def: #export ( ratio color) (-> Frac Color Color) (let [[hue saturation luminance] (to-hsl color)] (from-hsl [hue (|> saturation - (f.* (|> +1.0 ( (normalize ratio)))) + (f.* (|> +1.0 ( (..normalize ratio)))) (f.min +1.0)) luminance])))] @@ -298,10 +331,10 @@ (-> Color [Color Color Color]) (let [[hue saturation luminance] (to-hsl color)] [color - (from-hsl [(|> hue (f.+ <1>) normalize) + (from-hsl [(|> hue (f.+ <1>) ..normalize) saturation luminance]) - (from-hsl [(|> hue (f.+ <2>) normalize) + (from-hsl [(|> hue (f.+ <2>) ..normalize) saturation luminance])]))] @@ -313,15 +346,15 @@ (template [ <1> <2> <3>] [(def: #export ( color) (-> Color [Color Color Color Color]) - (let [[hue saturation luminance] (to-hsl color)] + (let [[hue saturation luminance] (to-hsb color)] [color - (from-hsl [(|> hue (f.+ <1>) normalize) + (from-hsb [(|> hue (f.+ <1>) ..normalize) saturation luminance]) - (from-hsl [(|> hue (f.+ <2>) normalize) + (from-hsb [(|> hue (f.+ <2>) ..normalize) saturation luminance]) - (from-hsl [(|> hue (f.+ <3>) normalize) + (from-hsb [(|> hue (f.+ <3>) ..normalize) saturation luminance])]))] @@ -329,37 +362,40 @@ [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))] ) -(def: #export (analogous results slice color) - (-> Nat Frac Color (List Color)) - (if (n.= 0 results) - (list) - (let [[hue saturation luminance] (to-hsl color) - slice (normalize slice)] - (list;map (function (_ idx) - (from-hsl [(|> idx .int int.frac (f.* slice) (f.+ hue) normalize) - saturation - luminance])) - (list.indices results))))) - -(def: #export (monochromatic results color) - (-> Nat Color (List Color)) - (if (n.= 0 results) - (list) - (let [[hue saturation brightness] (to-hsb color) - slice (|> +1.0 (f./ (|> results .int int.frac)))] - (|> (list.indices results) - (list;map (|>> .int int.frac - (f.* slice) - (f.+ brightness) - normalize - [hue saturation] - from-hsb)))))) - -(type: #export Alpha Rev) +(type: #export Spread + Frac) + +(type: #export Palette + (-> Spread Nat Color (List Color))) + +(def: #export (analogous spread variations color) + (-> Spread Nat Color (List Color)) + (let [[hue saturation brightness] (to-hsb color) + spread (..normalize spread)] + (list@map (function (_ idx) + (from-hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize) + saturation + brightness])) + (list.indices variations)))) + +(def: #export (monochromatic spread variations color) + (-> Spread Nat Color (List Color)) + (let [[hue saturation brightness] (to-hsb color) + spread (..normalize spread)] + (|> (list.indices variations) + (list@map (|>> inc .int int.frac + (f.* spread) + (f.+ brightness) + ..normalize + [hue saturation] + from-hsb))))) + +(type: #export Alpha + Rev) (def: #export transparent Alpha - rev;bottom) + rev@bottom) (def: #export translucent Alpha @@ -367,7 +403,7 @@ (def: #export opaque Alpha - rev;top) + rev@top) (type: #export Pigment {#color Color diff --git a/stdlib/source/lux/data/number/frac.lux b/stdlib/source/lux/data/number/frac.lux index 22a8e5372..47ad25f30 100644 --- a/stdlib/source/lux/data/number/frac.lux +++ b/stdlib/source/lux/data/number/frac.lux @@ -9,7 +9,8 @@ [control ["." try (#+ Try)]] [data - ["." maybe]] + ["." maybe] + ["." text]] ["." math]] ["." // #_ ["#." i64] @@ -160,9 +161,14 @@ (Codec Text Frac) (def: (encode x) - (if (..< +0.0 x) - ("lux f64 encode" x) - ("lux text concat" "+" ("lux f64 encode" x)))) + (case x + -0.0 (let [output ("lux f64 encode" x)] + (if (text.starts-with? "-" output) + output + ("lux text concat" "+" output))) + _ (if (..< +0.0 x) + ("lux f64 encode" x) + ("lux text concat" "+" ("lux f64 encode" x))))) (def: (decode input) (case ("lux f64 decode" [input]) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 455176de6..aadd8199b 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -16,7 +16,7 @@ ["." text ("#@." monoid)] [number ["n" nat ("#@." decimal)] - ["i" int ("#@." decimal)]] + ["i" int]] [collection ["." list ("#@." fold)] ["." dictionary (#+ Dictionary)]]] @@ -53,21 +53,9 @@ ["Value" (n@encode day)] ["Minimum" (n@encode ..minimum-day)] ["Maximum" (n@encode (..month-days year month))] - ["Year" (i@encode year)] + ["Year" (:: //year.codec encode year)] ["Month" (n@encode (//month.number month))])) -(def: (internal-year year) - (-> Year Year) - (if (i.< +0 year) - (inc year) - year)) - -(def: (external-year year) - (-> Year Year) - (if (i.> +0 year) - year - (dec year))) - (def: (pad value) (-> Nat Text) (let [digits (n@encode value)] @@ -85,25 +73,22 @@ (def: #export (date year month day) (-> Year Month Nat (Try Date)) - (case year - +0 (exception.throw ..there-is-no-year-0 []) - _ (let [year (..internal-year year)] - (if (..day-is-within-limits? year month day) - (#try.Success - (:abstraction - {#year year - #month month - #day day})) - (exception.throw ..invalid-day [year month day]))))) - - (template [ ] + (if (..day-is-within-limits? year month day) + (#try.Success + (:abstraction + {#year year + #month month + #day day})) + (exception.throw ..invalid-day [year month day]))) + + (template [ ] [(def: #export (-> Date ) - (|>> :representation (get@ ) ))] + (|>> :representation (get@ )))] - [year Year #year ..external-year] - [month Month #month (|>)] - [day-of-month Nat #day (|>)] + [year Year #year] + [month Month #month] + [day-of-month Nat #day] ) (structure: #export equivalence @@ -112,8 +97,9 @@ (def: (= reference sample) (let [reference (:representation reference) sample (:representation sample)] - (and (i.= (get@ #year reference) - (get@ #year sample)) + (and (:: //year.equivalence = + (get@ #year reference) + (get@ #year sample)) (:: //month.equivalence = (get@ #month reference) (get@ #month sample)) @@ -128,10 +114,12 @@ (def: (< reference sample) (let [reference (:representation reference) sample (:representation sample)] - (or (i.< (get@ #year reference) - (get@ #year sample)) - (and (i.= (get@ #year reference) - (get@ #year sample)) + (or (:: //year.order < + (get@ #year reference) + (get@ #year sample)) + (and (:: //year.equivalence = + (get@ #year reference) + (get@ #year sample)) (or (:: //month.order < (get@ #month reference) (get@ #month sample)) @@ -142,16 +130,6 @@ (get@ #day sample))))))))) ) -(def: parse-year - (Parser Year) - (do {@ <>.monad} - [sign (<>.or (.this "-") (wrap [])) - digits (.many .decimal) - raw-year (<>.codec i.decimal (wrap (text@compose "+" digits)))] - (wrap (case sign - (#.Left _) (i.* -1 raw-year) - (#.Right _) raw-year)))) - (def: parse-section (Parser Nat) (<>.codec n.decimal (.exactly 2 .decimal))) @@ -185,7 +163,7 @@ (def: #export parser (Parser Date) (do <>.monad - [utc-year ..parse-year + [utc-year //year.parser _ (.this ..separator) utc-month ..parse-month _ (.this ..separator) @@ -195,13 +173,10 @@ (def: (encode value) (-> Date Text) - (let [year (..year value)] - ($_ text@compose - (if (i.< +0 year) - (i@encode year) - (n@encode (.nat year))) - ..separator (..pad (|> value ..month //month.number)) - ..separator (..pad (..day-of-month value))))) + ($_ text@compose + (:: //year.codec encode (..year value)) + ..separator (..pad (|> value ..month //month.number)) + ..separator (..pad (..day-of-month value)))) (structure: #export codec {#.doc (doc "Based on ISO 8601." @@ -292,7 +267,8 @@ (def: (civil-year utc-month utc-year) (-> Nat Year Int) - (let [utc-year (..internal-year utc-year)] + (let [## Coercing, because the year is already in external form. + utc-year (:coerce Int utc-year)] (if (n.< ..first-month-of-civil-year utc-month) (dec utc-year) utc-year))) @@ -349,6 +325,18 @@ year (if (n.< ..first-month-of-civil-year month) (inc year) year)] - (try.assume (..date (..external-year year) + ## Coercing, because the year is already in internal form. + (try.assume (..date (:coerce Year year) (maybe.assume (dictionary.get month ..month-by-number)) day)))) + +(structure: #export enum + (Enum Date) + + (def: &order ..order) + + (def: succ + (|>> ..days inc ..from-days)) + + (def: pred + (|>> ..days dec ..from-days))) diff --git a/stdlib/source/lux/time/year.lux b/stdlib/source/lux/time/year.lux index 0ba2025c6..43e2181ab 100644 --- a/stdlib/source/lux/time/year.lux +++ b/stdlib/source/lux/time/year.lux @@ -1,19 +1,57 @@ (.module: [lux #* + [abstract + [monad (#+ do)] + [codec (#+ Codec)] + [equivalence (#+ Equivalence)] + [order (#+ Order)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["" text (#+ Parser)]]] [data + ["." text ("#@." monoid)] [number - ["n" nat] - ["i" int]]]]) + ["n" nat ("#@." decimal)] + ["i" int ("#@." decimal)]]] + [type + abstract]]) -(type: #export Year - Int) +(def: (internal year) + (-> Int Int) + (if (i.< +0 year) + (inc year) + year)) + +(def: (external year) + (-> Int Int) + (if (i.> +0 year) + year + (dec year))) + +(exception: #export there-is-no-year-0) + +(abstract: #export Year + Int + + (def: #export (year value) + (-> Int (Try Year)) + (case value + +0 (exception.throw ..there-is-no-year-0 []) + _ (#try.Success (:abstraction (..internal value))))) + + (def: #export value + (-> Year Int) + (|>> :representation ..external)) + ) (def: #export days 365) (def: #export epoch Year - +1970) + (try.assume (..year +1970))) (type: #export Period Nat) @@ -35,9 +73,10 @@ ## https://en.wikipedia.org/wiki/Leap_year#Algorithm (def: #export (leap? year) (-> Year Bit) - (and (..divisible? (.int ..leap) year) - (or (not (..divisible? (.int ..century) year)) - (..divisible? (.int ..era) year)))) + (let [year (|> year ..value ..internal)] + (and (..divisible? (.int ..leap) year) + (or (not (..divisible? (.int ..century) year)) + (..divisible? (.int ..era) year))))) (def: (with-year-0-leap year days) (let [after-year-0? (i.> +0 year)] @@ -47,7 +86,8 @@ (def: #export (leaps year) (-> Year Int) - (let [limit (if (i.> +0 year) + (let [year (|> year ..value ..internal) + limit (if (i.> +0 year) (dec year) (inc year))] (`` (|> +0 @@ -59,3 +99,42 @@ [i.+ ..era] )) (..with-year-0-leap year))))) + +(def: (encode year) + (-> Year Text) + (let [year (..value year)] + (if (i.< +0 year) + (i@encode year) + (n@encode (.nat year))))) + +(def: #export parser + (Parser Year) + (do {@ <>.monad} + [sign (<>.or (.this "-") (wrap [])) + digits (.many .decimal) + raw-year (<>.codec i.decimal (wrap (text@compose "+" digits)))] + (<>.lift (..year (case sign + (#.Left _) (i.* -1 raw-year) + (#.Right _) raw-year))))) + +(structure: #export codec + {#.doc (doc "Based on ISO 8601." + "For example: 2017")} + (Codec Text Year) + + (def: encode ..encode) + (def: decode (.run ..parser))) + +(structure: #export equivalence + (Equivalence Year) + + (def: (= reference subject) + (i.= (..value reference) (..value subject)))) + +(structure: #export order + (Order Year) + + (def: &equivalence ..equivalence) + + (def: (< reference subject) + (i.< (..value reference) (..value subject)))) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 0580372c1..2d005d450 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -6,6 +6,7 @@ ["." monad (#+ Monad do)]] [control ["." try (#+ Try)] + ["." exception (#+ exception:)] [concurrency ["." promise (#+ Promise Resolver) ("#@." monad)] ["." stm (#+ Var STM)]]] @@ -13,7 +14,7 @@ ["." binary (#+ Binary)] ["." bit] ["." product] - ["." text + ["." text ("#@." equivalence) ["%" format (#+ format)]] [collection ["." dictionary (#+ Dictionary)] @@ -362,6 +363,16 @@ try.assume product.left)) + (exception: #export (module-cannot-import-itself {module Module}) + (exception.report + ["Module" (%.text module)])) + + (def: (verify-no-self-import! module dependencies) + (-> Module (List Module) (Try Any)) + (if (list.any? (text@= module) dependencies) + (exception.throw ..module-cannot-import-itself [module]) + (#try.Success []))) + (def: #export (compile import static expander platform compilation context) (All [] (-> Import Static Expander Compilation )) @@ -371,75 +382,75 @@ context} {(///.Compiler .Module Any) (:assume - ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))})] - (do (try.with promise.monad) - [#let [compiler (..parallel - context - (function (_ import! module-id [archive state] module) - (do (try.with promise.monad) - [#let [state (..set-current-module module state)] - input (context.read (get@ #&file-system platform) - import - compilation-sources - (get@ #static.host-module-extension static) - module)] - (loop [[archive state] [archive state] - compilation (base-compiler (:coerce ///.Input input)) - all-dependencies (: (List Module) - (list))] - (do {@ (try.with promise.monad)} - [#let [new-dependencies (get@ #///.dependencies compilation) - all-dependencies (list@compose new-dependencies all-dependencies) - continue! (:share [] - { - platform} - {(-> (///.Compilation .Module Any) (List Module) - (Action [Archive ])) - (:assume - recur)})] - [archive state] (case new-dependencies - #.Nil - (wrap [archive state]) + ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))}) + compiler (..parallel + context + (function (_ import! module-id [archive state] module) + (do {@ (try.with promise.monad)} + [#let [state (..set-current-module module state)] + input (context.read (get@ #&file-system platform) + import + compilation-sources + (get@ #static.host-module-extension static) + module)] + (loop [[archive state] [archive state] + compilation (base-compiler (:coerce ///.Input input)) + all-dependencies (: (List Module) + (list))] + (let [new-dependencies (get@ #///.dependencies compilation) + all-dependencies (list@compose new-dependencies all-dependencies) + continue! (:share [] + { + platform} + {(-> (///.Compilation .Module Any) (List Module) + (Action [Archive ])) + (:assume + recur)})] + (do @ + [[archive state] (case new-dependencies + #.Nil + (wrap [archive state]) - (#.Cons _) - (do @ - [archive,document+ (|> new-dependencies - (list@map import!) - (monad.seq ..monad)) - #let [archive (|> archive,document+ - (list@map product.left) - (list@fold archive.merge archive))]] - (wrap [archive (try.assume - (..updated-state archive state))])))] - (case ((get@ #///.process compilation) - ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP. - ## TODO: The context shouldn't need to be re-set either. - (|> (///directive.set-current-module module) - (///phase.run' state) - try.assume - product.left) - archive) - (#try.Success [state more|done]) - (case more|done - (#.Left more) - (continue! [archive state] more all-dependencies) + (#.Cons _) + (do @ + [_ (:: promise.monad wrap (verify-no-self-import! module new-dependencies)) + archive,document+ (|> new-dependencies + (list@map import!) + (monad.seq ..monad)) + #let [archive (|> archive,document+ + (list@map product.left) + (list@fold archive.merge archive))]] + (wrap [archive (try.assume + (..updated-state archive state))])))] + (case ((get@ #///.process compilation) + ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP. + ## TODO: The context shouldn't need to be re-set either. + (|> (///directive.set-current-module module) + (///phase.run' state) + try.assume + product.left) + archive) + (#try.Success [state more|done]) + (case more|done + (#.Left more) + (continue! [archive state] more all-dependencies) - (#.Right [[descriptor document] output]) - (do (try.with promise.monad) - [#let [_ (log! (..module-compilation-log state)) - descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)] - _ (..cache-module static platform module-id [[descriptor document] output])] - (case (archive.add module [descriptor document] archive) - (#try.Success archive) - (wrap [archive - (..with-reset-log state)]) - - (#try.Failure error) - (promise@wrap (#try.Failure error))))) + (#.Right [[descriptor document] output]) + (do @ + [#let [_ (log! (..module-compilation-log state)) + descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)] + _ (..cache-module static platform module-id [[descriptor document] output])] + (case (archive.add module [descriptor document] archive) + (#try.Success archive) + (wrap [archive + (..with-reset-log state)]) + + (#try.Failure error) + (promise@wrap (#try.Failure error))))) - (#try.Failure error) - (do (try.with promise.monad) - [_ (ioW.freeze (get@ #&file-system platform) static archive)] - (promise@wrap (#try.Failure error)))))))))]] - (compiler compilation-module)))) + (#try.Failure error) + (do @ + [_ (ioW.freeze (get@ #&file-system platform) static archive)] + (promise@wrap (#try.Failure error))))))))))] + (compiler compilation-module))) )) diff --git a/stdlib/source/test/lux/data/bit.lux b/stdlib/source/test/lux/data/bit.lux index 6f281818d..0be42e466 100644 --- a/stdlib/source/test/lux/data/bit.lux +++ b/stdlib/source/test/lux/data/bit.lux @@ -1,8 +1,8 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] - ["r" math/random] + [math + ["." random]] [abstract [monad (#+ do)] {[0 #spec] @@ -17,21 +17,20 @@ (def: #export test Test - (<| (_.context (%.name (name-of .Bit))) - (do r.monad - [value r.bit] + (<| (_.covering /._) + (do random.monad + [value random.bit] ($_ _.and - ($equivalence.spec /.equivalence r.bit) - ($codec.spec /.equivalence /.codec r.bit) - (<| (_.context "Disjunction.") - ($monoid.spec /.equivalence /.disjunction r.bit)) - (<| (_.context "Conjunction.") - ($monoid.spec /.equivalence /.conjunction r.bit)) - (_.test "A value cannot be true and false at the same time." - (not (and value (not value)))) - (_.test "A value must be either true or false at any time." - (or value (not value))) - (_.test "Can create the complement of a predicate." - (and (not (:: /.equivalence = value ((/.complement function.identity) value))) - (:: /.equivalence = value ((/.complement not) value)))) + (_.with-cover [/.equivalence] + ($equivalence.spec /.equivalence random.bit)) + (_.with-cover [/.disjunction] + ($monoid.spec /.equivalence /.disjunction random.bit)) + (_.with-cover [/.conjunction] + ($monoid.spec /.equivalence /.conjunction random.bit)) + (_.with-cover [/.codec] + ($codec.spec /.equivalence /.codec random.bit)) + + (_.cover [/.complement] + (and (not (:: /.equivalence = value ((/.complement function.identity) value))) + (:: /.equivalence = value ((/.complement not) value)))) )))) diff --git a/stdlib/source/test/lux/data/color.lux b/stdlib/source/test/lux/data/color.lux index a7b5c0088..388b49d93 100644 --- a/stdlib/source/test/lux/data/color.lux +++ b/stdlib/source/test/lux/data/color.lux @@ -5,41 +5,53 @@ [monad (#+ do)] {[0 #spec] [/ - ["$." equivalence]]}] + ["$." equivalence] + ["$." monoid]]}] [data - ["%" text/format (#+ format)] [number + ["n" nat] ["." int] - ["f" frac]]] + ["f" frac] + ["r" rev]] + [collection + ["." list]]] + [macro + ["." template]] ["." math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {1 - ["." / (#+ Color)]}) + ["." / (#+ Color) + ["." named]]}) (def: #export color (Random Color) - (|> ($_ r.and r.nat r.nat r.nat) - (:: r.monad map /.from-rgb))) + (|> ($_ random.and random.nat random.nat random.nat) + (:: random.monad map /.from-rgb))) (def: scale (-> Nat Frac) (|>> .int int.frac)) (def: square (-> Frac Frac) (math.pow +2.0)) +(def: square-root (-> Frac Frac) (math.pow +0.5)) -(def: (distance from to) +(def: (distance/1 from to) + (-> Frac Frac Frac) + (square-root + (square + (f.- from to)))) + +(def: (distance/3 from to) (-> Color Color Frac) (let [[fr fg fb] (/.to-rgb from) [tr tg tb] (/.to-rgb to)] - (math.pow +0.5 ($_ f.+ - (|> (scale tr) (f.- (scale fr)) square) - (|> (scale tg) (f.- (scale fg)) square) - (|> (scale tb) (f.- (scale fb)) square))))) - -(def: error-margin Frac +1.8) + (square-root + ($_ f.+ + (|> (scale tr) (f.- (scale fr)) square) + (|> (scale tg) (f.- (scale fg)) square) + (|> (scale tb) (f.- (scale fb)) square))))) -(def: black (/.from-rgb [0 0 0])) -(def: white (/.from-rgb [255 255 255])) +(def: rgb-error-margin +1.8) (template [] [(def: ( color) @@ -51,56 +63,145 @@ [luminance] ) +(def: (encoding expected) + (-> /.Color Test) + ($_ _.and + (_.cover [/.RGB /.to-rgb /.from-rgb] + (|> expected /.to-rgb /.from-rgb + (:: /.equivalence = expected))) + (_.cover [/.HSL /.to-hsl /.from-hsl] + (|> expected /.to-hsl /.from-hsl + (distance/3 expected) + (f.<= ..rgb-error-margin))) + (_.cover [/.HSB /.to-hsb /.from-hsb] + (|> expected /.to-hsb /.from-hsb + (distance/3 expected) + (f.<= ..rgb-error-margin))) + (_.cover [/.CMYK /.to-cmyk /.from-cmyk] + (|> expected /.to-cmyk /.from-cmyk + (distance/3 expected) + (f.<= ..rgb-error-margin))) + )) + +(def: transformation + Test + (do random.monad + [colorful (|> ..color + (random.filter (function (_ color) (|> (distance/3 color /.black) (f.>= +100.0)))) + (random.filter (function (_ color) (|> (distance/3 color /.white) (f.>= +100.0))))) + mediocre (|> ..color + (random.filter (|>> saturation + ((function (_ saturation) + (and (f.>= +0.25 saturation) + (f.<= +0.75 saturation))))))) + ratio (|> random.safe-frac (random.filter (f.>= +0.5)))] + ($_ _.and + (_.cover [/.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)))) + (_.cover [/.interpolate] + (and (f.<= (distance/3 colorful /.black) + (distance/3 (/.interpolate ratio /.black colorful) /.black)) + (f.<= (distance/3 colorful /.white) + (distance/3 (/.interpolate ratio /.white colorful) /.white)))) + (_.cover [/.saturate] + (f.> (saturation mediocre) + (saturation (/.saturate ratio mediocre)))) + (_.cover [/.de-saturate] + (f.< (saturation mediocre) + (saturation (/.de-saturate ratio mediocre)))) + (_.cover [/.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 + (_.with-cover [/.Spread /.Palette] + (do {@ random.monad} + [eH (:: @ map (|>> f.abs (f.% +0.9) (f.+ +0.05)) + random.safe-frac) + #let [eS +0.5] + variations (:: @ map (|>> (n.% 3) (n.+ 2)) random.nat) + #let [max-spread (f./ (|> variations inc .int int.frac) + +1.0) + min-spread (f./ +2.0 max-spread) + spread-space (f.- min-spread max-spread)] + spread (:: @ map (|>> f.abs (f.% spread-space) (f.+ min-spread)) + random.safe-frac)] + (`` ($_ _.and + (~~ (template [ ] + [(_.cover [] + (let [eB + expected (/.from-hsb [eH eS eB]) + palette ( spread variations expected)] + (and (n.= variations (list.size palette)) + (not (list.any? (:: /.equivalence = expected) palette)))))] + [+1.0 /.analogous] + [+0.5 /.monochromatic] + )) + (~~ (template [] + [(_.cover [] + (let [expected (/.from-hsb [eH eS +0.5]) + [c0 c1 c2] ( expected)] + (and (:: /.equivalence = expected c0) + (not (:: /.equivalence = expected c1)) + (not (:: /.equivalence = expected c2)))))] + + [/.triad] + [/.clash] + [/.split-complement])) + (~~ (template [] + [(_.cover [] + (let [expected (/.from-hsb [eH eS +0.5]) + [c0 c1 c2 c3] ( expected)] + (and (:: /.equivalence = expected c0) + (not (:: /.equivalence = expected c1)) + (not (:: /.equivalence = expected c2)) + (not (:: /.equivalence = expected c3)))))] + + [/.square] + [/.tetradic])) + ))))) + (def: #export test Test - (<| (_.context (%.name (name-of /._))) - (do r.monad - [any ..color - colorful (|> color - (r.filter (function (_ color) (|> (distance color black) (f.>= +100.0)))) - (r.filter (function (_ color) (|> (distance color white) (f.>= +100.0))))) - mediocre (|> color - (r.filter (|>> saturation - ((function (_ saturation) - (and (f.>= +0.25 saturation) - (f.<= +0.75 saturation))))))) - ratio (|> r.safe-frac (r.filter (f.>= +0.5)))] + (<| (_.covering /._) + (_.with-cover [/.Color]) + (do {@ random.monad} + [expected ..color] ($_ _.and - ($equivalence.spec /.equivalence ..color) - (_.test "Can convert to/from HSL." - (|> any /.to-hsl /.from-hsl - (distance any) - (f.<= error-margin))) - (_.test "Can convert to/from HSB." - (|> any /.to-hsb /.from-hsb - (distance any) - (f.<= error-margin))) - (_.test "Can convert to/from CMYK." - (|> any /.to-cmyk /.from-cmyk - (distance any) - (f.<= error-margin))) - (_.test "Can interpolate between 2 colors." - (and (f.<= (distance colorful black) - (distance (/.darker ratio colorful) black)) - (f.<= (distance colorful white) - (distance (/.brighter ratio colorful) white)))) - (_.test "Can calculate complement." - (let [~any (/.complement any) - (^open "/@.") /.equivalence] - (and (not (/@= any ~any)) - (/@= any (/.complement ~any))))) - (_.test "Can saturate color." - (f.> (saturation mediocre) - (saturation (/.saturate ratio mediocre)))) - (_.test "Can de-saturate color." - (f.< (saturation mediocre) - (saturation (/.de-saturate ratio mediocre)))) - (_.test "Can gray-scale color." - (let [gray'ed (/.gray-scale mediocre)] - (and (f.= +0.0 - (saturation gray'ed)) - (|> (luminance gray'ed) - (f.- (luminance mediocre)) - f.abs - (f.<= error-margin))))) + (_.with-cover [/.equivalence] + ($equivalence.spec /.equivalence ..color)) + (_.with-cover [/.addition] + ($monoid.spec /.equivalence /.addition ..color)) + (_.with-cover [/.subtraction] + ($monoid.spec /.equivalence /.addition ..color)) + + (..encoding expected) + (_.cover [/.complement] + (let [~expected (/.complement expected) + (^open "/@.") /.equivalence] + (and (not (/@= expected ~expected)) + (/@= expected (/.complement ~expected))))) + (_.cover [/.black /.white] + (and (:: /.equivalence = /.white (/.complement /.black)) + (:: /.equivalence = /.black (/.complement /.white)))) + ..transformation + ..palette + (_.with-cover [/.Alpha /.Pigment] + ($_ _.and + (_.cover [/.transparent /.opaque] + (and (r.= /.opaque (dec /.transparent)) + (r.= /.transparent (inc /.opaque)))) + (_.cover [/.translucent] + (r.= /.transparent (r.+ /.translucent /.translucent))) + )) )))) -- cgit v1.2.3