diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux.lux | 160 | ||||
| -rw-r--r-- | stdlib/source/lux/data/number.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/math/logic/fuzzy.lux | 124 | ||||
| -rw-r--r-- | stdlib/source/lux/math/random.lux | 8 | ||||
| -rw-r--r-- | stdlib/test/test/lux.lux | 8 | ||||
| -rw-r--r-- | stdlib/test/test/lux/math/logic/fuzzy.lux | 29 |
6 files changed, 202 insertions, 137 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 6e6397eeb..6270d0b47 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2295,6 +2295,48 @@ _ (fail "Wrong syntax for do-template")})) +(def:''' #export (d/= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) equality.")]) + (-> Deg Deg Bool) + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test))) + +(def:''' #export (d/< test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) less-than.")]) + (-> Deg Deg Bool) + (n/< ("lux coerce" Nat test) + ("lux coerce" Nat subject))) + +(def:''' #export (d/<= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) less-than-equal.")]) + (-> Deg Deg Bool) + (if (n/< ("lux coerce" Nat test) + ("lux coerce" Nat subject)) + true + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test)))) + +(def:''' #export (d/> test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) greater-than.")]) + (-> Deg Deg Bool) + (d/< subject test)) + +(def:''' #export (d/>= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) greater-than-equal.")]) + (-> Deg Deg Bool) + (if (d/< subject test) + true + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test)))) + (do-template [<type> <eq-proc> <lt-proc> <eq-name> <lt-name> <lte-name> <gt-name> <gte-name> <eq-doc> <<-doc> <<=-doc> <>-doc> <>=-doc>] @@ -2335,9 +2377,6 @@ [ Int "lux int =" "lux int <" i/= i/< i/<= i/> i/>= "Int(eger) equality." "Int(eger) less-than." "Int(eger) less-than-equal." "Int(eger) greater-than." "Int(eger) greater-than-equal."] - [ Deg "lux deg =" "lux deg <" d/= d/< d/<= d/> d/>= - "Deg(ree) equality." "Deg(ree) less-than." "Deg(ree) less-than-equal." "Deg(ree) greater-than." "Deg(ree) greater-than-equal."] - [Frac "lux frac =" "lux frac <" f/= f/< f/<= f/> f/>= "Frac(tion) equality." "Frac(tion) less-than." "Frac(tion) less-than-equal." "Frac(tion) greater-than." "Frac(tion) greater-than-equal."] ) @@ -2389,6 +2428,88 @@ (list [(tag$ ["lux" "doc"]) (text$ <doc>)]) (-> <type> <type> <type>) + ("lux coerce" Deg + (<op> ("lux coerce" Int subject) + ("lux coerce" Int param))))] + + [ Deg d/+ "lux int +" "Deg(ree) addition."] + [ Deg d/- "lux int -" "Deg(ree) substraction."] + ) + +(def:''' #export (d/* param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) multiplication.")]) + (-> Deg Deg Deg) + (let' [subjectH (high-bits ("lux coerce" Nat subject)) + subjectL (low-bits ("lux coerce" Nat subject)) + paramH (high-bits ("lux coerce" Nat param)) + paramL (low-bits ("lux coerce" Nat param)) + bottom ("lux coerce" Int + ("lux bit logical-right-shift" + ("lux coerce" Nat ("lux int *" subjectL paramL)) + +32)) + middle ("lux int +" + ("lux int *" subjectH paramL) + ("lux int *" subjectL paramH)) + top ("lux int *" subjectH paramH)] + ("lux coerce" Deg + ("lux int +" + (high-bits + ("lux coerce" Nat + ("lux int +" + bottom + middle))) + top)))) + +(def:''' least-significant-bit-mask (list) Nat +1) + +(def:''' #export (d// param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) division.")]) + (-> Deg Deg Deg) + (if (|> param ("lux coerce" Int) ("lux int =" 0)) + ("lux io error" "Cannot divide Deg by zero!") + (let' [[trailing-zeroes remaining] (("lux check" (-> Nat Nat (#Product Nat Nat)) + (function' recur [count remaining] + (if (|> remaining + ("lux bit and" least-significant-bit-mask) + ("lux coerce" Int) + ("lux int =" 0)) + (recur (|> count + ("lux coerce" Int) + ("lux int +" 1) + ("lux coerce" Nat)) + ("lux bit logical-right-shift" remaining +1)) + [count remaining]))) + +0 ("lux coerce" Nat param)) + [trailing-zeroes denominator] (if (|> trailing-zeroes ("lux coerce" Int) ("lux int =" 0)) + [+1 ("lux bit logical-right-shift" remaining +1)] + [trailing-zeroes remaining]) + shift ("lux coerce" Nat + ("lux int -" + 64 + ("lux coerce" Int trailing-zeroes))) + numerator ("lux bit left-shift" +1 shift)] + ("lux coerce" Deg + ("lux int /" + ("lux int *" + ("lux coerce" Int subject) + ("lux coerce" Int numerator)) + ("lux coerce" Int denominator)))))) + +(def:''' #export (d/% param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) remainder.")]) + (-> Deg Deg Deg) + ("lux coerce" Deg + (n/% ("lux coerce" Nat subject) + ("lux coerce" Nat param)))) + +(do-template [<type> <name> <op> <doc>] + [(def:''' #export (<name> param subject) + (list [(tag$ ["lux" "doc"]) + (text$ <doc>)]) + (-> <type> <type> <type>) (<op> subject param))] [ Int i/+ "lux int +" "Int(eger) addition."] @@ -2397,12 +2518,6 @@ [ Int i// "lux int /" "Int(eger) division."] [ Int i/% "lux int %" "Int(eger) remainder."] - [ Deg d/+ "lux deg +" "Deg(ree) addition."] - [ Deg d/- "lux deg -" "Deg(ree) substraction."] - [ Deg d/* "lux deg *" "Deg(ree) multiplication."] - [ Deg d// "lux deg /" "Deg(ree) division."] - [ Deg d/% "lux deg %" "Deg(ree) remainder."] - [Frac f/+ "lux frac +" "Frac(tion) addition."] [Frac f/- "lux frac -" "Frac(tion) substraction."] [Frac f/* "lux frac *" "Frac(tion) multiplication."] @@ -2410,16 +2525,14 @@ [Frac f/% "lux frac %" "Frac(tion) remainder."] ) -(do-template [<type> <name> <op> <doc>] - [(def:''' #export (<name> param subject) - (list [(tag$ ["lux" "doc"]) - (text$ <doc>)]) - (-> Nat <type> <type>) - (<op> subject param))] - - [ Deg d/scale "lux deg scale" "Deg(ree) scale."] - [ Deg d/reciprocal "lux deg reciprocal" "Deg(ree) reciprocal."] - ) +(def:''' #export (d/scale param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) scale.")]) + (-> Nat Deg Deg) + ("lux coerce" Deg + ("lux int *" + ("lux coerce" Int subject) + ("lux coerce" Int param)))) (do-template [<name> <type> <test> <doc>] [(def:''' #export (<name> left right) @@ -5212,15 +5325,6 @@ [nat-to-int Nat Int] ) -(do-template [<name> <op> <from> <to>] - [(def: #export (<name> input) - (-> <from> <to>) - (<op> input))] - - [frac-to-deg "lux frac to-deg" Frac Deg] - [deg-to-frac "lux deg to-frac" Deg Frac] - ) - (def: #export frac-to-nat (|>> frac-to-int int-to-nat)) (def: #export nat-to-frac (|>> nat-to-int int-to-frac)) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index bd1d34cad..eb712d046 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -80,10 +80,10 @@ (def: * d/*) (def: / d//) (def: % d/%) - (def: (negate x) (d/- x ("lux deg max"))) + (def: (negate x) (d/- x (:! Deg -1))) (def: abs id) (def: (signum x) - ("lux deg max"))) + (:! Deg -1))) (do-template [<type> <order> <succ> <pred>] [(struct: #export _ (Enum <type>) @@ -94,7 +94,7 @@ [Nat Order<Nat> n/inc n/dec] [Int Order<Int> i/inc i/dec] [Frac Order<Frac> (f/+ ("lux frac smallest")) (f/- ("lux frac smallest"))] - [Deg Order<Deg> (d/+ ("lux deg min")) (d/- ("lux deg min"))] + [Deg Order<Deg> (d/+ (:! Deg +1)) (d/- (:! Deg +1))] ) (do-template [<type> <enum> <top> <bottom>] @@ -103,10 +103,10 @@ (def: top <top>) (def: bottom <bottom>))] - [ Nat Enum<Nat> ("lux coerce" Nat -1) +0] + [ Nat Enum<Nat> (:! Nat -1) +0] [ Int Enum<Int> ("lux int max") ("lux int min")] [Frac Enum<Frac> ("lux frac max") ("lux frac min")] - [ Deg Enum<Deg> ("lux deg max") ("lux deg min")] + [ Deg Enum<Deg> (:! Deg -1) (:! Deg +0)] ) (do-template [<name> <type> <identity> <compose>] diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux index 7933027c9..7c5ee4150 100644 --- a/stdlib/source/lux/math/logic/fuzzy.lux +++ b/stdlib/source/lux/math/logic/fuzzy.lux @@ -48,81 +48,57 @@ (All [a] (-> (Set a) (Fuzzy a))) (from-predicate (set.member? set))) -(do-template [<ascending> <descending> <gradient> <type> <lt> <gt> <lte> <gte> <sub> <div> <post>] - [(def: (<ascending> from to) - (-> <type> <type> (Fuzzy <type>)) - (function (_ elem) - (cond (<lte> from elem) - &.~false - - (<gte> to elem) - &.~true - - ## in the middle... - (<post> (<div> (<sub> from to) - (<sub> from elem)))))) - - (def: (<descending> from to) - (-> <type> <type> (Fuzzy <type>)) - (function (_ elem) - (cond (<lte> from elem) - &.~true - - (<gte> to elem) - &.~false - - ## in the middle... - (<post> (<div> (<sub> from to) - (<sub> elem to)))))) - - (def: #export (<gradient> from to) - (-> <type> <type> (Fuzzy <type>)) - (if (<lt> to from) - (<ascending> from to) - (<descending> from to)))] - - [d/ascending d/descending d/gradient Deg d/< d/> d/<= d/>= d/- d// id] - [f/ascending f/descending f/gradient Frac f/< f/> f/<= f/>= f/- f// frac-to-deg] - ) - -(do-template [<triangle> <trapezoid> <type> <ascending> <descending> <lt>] - [(def: #export (<triangle> bottom middle top) - (-> <type> <type> <type> (Fuzzy <type>)) - (case (list.sort <lt> (list bottom middle top)) - (^ (list bottom middle top)) - (intersection (<ascending> bottom middle) - (<descending> middle top)) - - _ - (undefined))) - - (def: #export (<trapezoid> bottom middle-bottom middle-top top) - (-> <type> <type> <type> <type> (Fuzzy <type>)) - (case (list.sort <lt> (list bottom middle-bottom middle-top top)) - (^ (list bottom middle-bottom middle-top top)) - (intersection (<ascending> bottom middle-bottom) - (<descending> middle-top top)) - - _ - (undefined)))] - - [d/triangle d/trapezoid Deg d/ascending d/descending d/<] - [f/triangle f/trapezoid Frac f/ascending f/descending f/<] - ) - -(def: #export (gaussian deviation center) - (-> Frac Frac (Fuzzy Frac)) +(def: (ascending from to) + (-> Deg Deg (Fuzzy Deg)) (function (_ elem) - (let [scale (|> deviation (math.pow 2.0) (f/* 2.0)) - membership (|> elem - (f/- center) - (math.pow 2.0) - (f/* -1.0) - (f// scale) - math.exp)] - (if (f/= 1.0 membership) - &.~true - (frac-to-deg membership))))) + (cond (d/<= from elem) + &.~false + + (d/>= to elem) + &.~true + + ## in the middle... + (d// (d/- from to) + (d/- from elem))))) + +(def: (descending from to) + (-> Deg Deg (Fuzzy Deg)) + (function (_ elem) + (cond (d/<= from elem) + &.~true + + (d/>= to elem) + &.~false + + ## in the middle... + (d// (d/- from to) + (d/- elem to))))) + +(def: #export (gradient from to) + (-> Deg Deg (Fuzzy Deg)) + (if (d/< to from) + (ascending from to) + (descending from to))) + +(def: #export (triangle bottom middle top) + (-> Deg Deg Deg (Fuzzy Deg)) + (case (list.sort d/< (list bottom middle top)) + (^ (list bottom middle top)) + (intersection (ascending bottom middle) + (descending middle top)) + + _ + (undefined))) + +(def: #export (trapezoid bottom middle-bottom middle-top top) + (-> Deg Deg Deg Deg (Fuzzy Deg)) + (case (list.sort d/< (list bottom middle-bottom middle-top top)) + (^ (list bottom middle-bottom middle-top top)) + (intersection (ascending bottom middle-bottom) + (descending middle-top top)) + + _ + (undefined))) (def: #export (cut treshold set) (All [a] (-> Deg (Fuzzy a) (Fuzzy a))) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 39d7d880d..695323c98 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -74,11 +74,7 @@ (def: #export int (Random Int) - (function (_ prng) - (let [[prng left] (prng []) - [prng right] (prng [])] - [prng (nat-to-int (n/+ (bit.left-shift +32 left) - right))]))) + (:: Monad<Random> map nat-to-int nat)) (def: #export bool (Random Bool) @@ -105,7 +101,7 @@ (def: #export deg (Random Deg) - (:: Monad<Random> map frac-to-deg frac)) + (:: Monad<Random> map (|>> (:! Deg)) nat)) (def: #export (text' char-gen size) (-> (Random Nat) Nat (Random Text)) diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index b8861eab6..a089f7cee 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -135,10 +135,10 @@ (|> x' (/ y) (* y) (= x')))) ))))] - ["Nat" r.nat n/= n/+ n/- n/* n// n/% n/> +0 +1 +1000000 %n (n/% +1000) id] - ["Int" r.int i/= i/+ i/- i/* i// i/% i/> 0 1 1000000 %i (i/% 1000) id] - ["Frac" r.frac f/= f/+ f/- f/* f// f/% f/> 0.0 1.0 1000000.0 %r id math.floor] - ["Deg" r.deg d/= d/+ d/- d/* d// d/% d/> .0 ("lux deg max") ("lux deg max") %f id id] + ["Nat" r.nat n/= n/+ n/- n/* n// n/% n/> +0 +1 +1000000 %n (n/% +1000) id] + ["Int" r.int i/= i/+ i/- i/* i// i/% i/> 0 1 1000000 %i (i/% 1000) id] + ["Frac" r.frac f/= f/+ f/- f/* f// f/% f/> 0.0 1.0 1000000.0 %r id math.floor] + ["Deg" r.deg d/= d/+ d/- d/* d// d/% d/> .0 (:! Deg -1) (:! Deg -1) %f id id] ) (do-template [category rand-gen -> <- = <cap> %a %z] diff --git a/stdlib/test/test/lux/math/logic/fuzzy.lux b/stdlib/test/test/lux/math/logic/fuzzy.lux index 068e00523..6530fcb4a 100644 --- a/stdlib/test/test/lux/math/logic/fuzzy.lux +++ b/stdlib/test/test/lux/math/logic/fuzzy.lux @@ -50,8 +50,7 @@ (<gte> top sample)))) ))))] - ["Frac" number.Hash<Frac> r.frac &.f/triangle f/< f/<= f/> f/>=] - ["Deg" number.Hash<Deg> r.deg &.d/triangle d/< d/<= d/> d/>=] + ["Deg" number.Hash<Deg> r.deg &.triangle d/< d/<= d/> d/>=] ) (do-template [<desc> <hash> <gen> <trapezoid> <lt> <lte> <gt> <gte>] @@ -98,33 +97,23 @@ (<gte> top sample)))) ))))] - ["Frac" number.Hash<Frac> r.frac &.f/trapezoid f/< f/<= f/> f/>=] - ["Deg" number.Hash<Deg> r.deg &.d/trapezoid d/< d/<= d/> d/>=] + ["Deg" number.Hash<Deg> r.deg &.trapezoid d/< d/<= d/> d/>=] ) -(context: "Gaussian" - (<| (times +100) - (do @ - [deviation (|> r.frac (r.filter (f/> 0.0))) - center r.frac - #let [gaussian (&.gaussian deviation center)]] - (test "The center value will always have maximum membership." - (d/= ~true (&.membership center gaussian)))))) - (def: gen-triangle - (r.Random (&.Fuzzy Frac)) + (r.Random (&.Fuzzy Deg)) (do r.Monad<Random> - [x r.frac - y r.frac - z r.frac] - (wrap (&.f/triangle x y z)))) + [x r.deg + y r.deg + z r.deg] + (wrap (&.triangle x y z)))) (context: "Combinators" (<| (times +100) (do @ [left gen-triangle right gen-triangle - sample r.frac] + sample r.deg] ($_ seq (test "Union membership as as high as membership in any of its members." (let [combined (&.union left right) @@ -174,7 +163,7 @@ (<| (times +100) (do @ [fuzzy gen-triangle - sample r.frac + sample r.deg threshold r.deg #let [vip-fuzzy (&.cut threshold fuzzy) member? (&.to-predicate threshold fuzzy)]] |