aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/test
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/test')
-rw-r--r--stdlib/source/test/lux/data/bit.lux35
-rw-r--r--stdlib/source/test/lux/data/color.lux231
2 files changed, 183 insertions, 83 deletions
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 [<field>]
[(def: (<field> 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 [<brightness> <palette>]
+ [(_.cover [<palette>]
+ (let [eB <brightness>
+ expected (/.from-hsb [eH eS eB])
+ palette (<palette> spread variations expected)]
+ (and (n.= variations (list.size palette))
+ (not (list.any? (:: /.equivalence = expected) palette)))))]
+ [+1.0 /.analogous]
+ [+0.5 /.monochromatic]
+ ))
+ (~~ (template [<palette>]
+ [(_.cover [<palette>]
+ (let [expected (/.from-hsb [eH eS +0.5])
+ [c0 c1 c2] (<palette> expected)]
+ (and (:: /.equivalence = expected c0)
+ (not (:: /.equivalence = expected c1))
+ (not (:: /.equivalence = expected c2)))))]
+
+ [/.triad]
+ [/.clash]
+ [/.split-complement]))
+ (~~ (template [<palette>]
+ [(_.cover [<palette>]
+ (let [expected (/.from-hsb [eH eS +0.5])
+ [c0 c1 c2 c3] (<palette> 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)))
+ ))
))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 18:00:43 +0000