From febfa99c2823219c2e76d2c73b1fd8db8f6c9918 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 7 May 2018 01:37:38 -0400 Subject: - Implemented Deg functionality in pure Lux. --- stdlib/source/lux.lux | 160 ++++++++++++++++++++++++------ stdlib/source/lux/data/number.lux | 10 +- stdlib/source/lux/math/logic/fuzzy.lux | 124 ++++++++++------------- stdlib/source/lux/math/random.lux | 8 +- stdlib/test/test/lux.lux | 8 +- stdlib/test/test/lux/math/logic/fuzzy.lux | 29 ++---- 6 files changed, 202 insertions(+), 137 deletions(-) (limited to 'stdlib') 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 [ <<-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."] ) @@ -2384,6 +2423,88 @@ ("lux coerce" Int subject) flat)))) +(do-template [ ] + [(def:''' #export ( param subject) + (list [(tag$ ["lux" "doc"]) + (text$ )]) + (-> ) + ("lux coerce" Deg + ( ("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 [ ] [(def:''' #export ( param subject) (list [(tag$ ["lux" "doc"]) @@ -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 [ ] - [(def:''' #export ( param subject) - (list [(tag$ ["lux" "doc"]) - (text$ )]) - (-> Nat ) - ( 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 [ ] [(def:''' #export ( left right) @@ -5212,15 +5325,6 @@ [nat-to-int Nat Int] ) -(do-template [ ] - [(def: #export ( input) - (-> ) - ( 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 [ ] [(struct: #export _ (Enum ) @@ -94,7 +94,7 @@ [Nat Order n/inc n/dec] [Int Order i/inc i/dec] [Frac Order (f/+ ("lux frac smallest")) (f/- ("lux frac smallest"))] - [Deg Order (d/+ ("lux deg min")) (d/- ("lux deg min"))] + [Deg Order (d/+ (:! Deg +1)) (d/- (:! Deg +1))] ) (do-template [ ] @@ -103,10 +103,10 @@ (def: top ) (def: bottom ))] - [ Nat Enum ("lux coerce" Nat -1) +0] + [ Nat Enum (:! Nat -1) +0] [ Int Enum ("lux int max") ("lux int min")] [Frac Enum ("lux frac max") ("lux frac min")] - [ Deg Enum ("lux deg max") ("lux deg min")] + [ Deg Enum (:! Deg -1) (:! Deg +0)] ) (do-template [ ] 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 [
] - [(def: ( from to) - (-> (Fuzzy )) - (function (_ elem) - (cond ( from elem) - &.~false - - ( to elem) - &.~true - - ## in the middle... - ( (
( from to) - ( from elem)))))) - - (def: ( from to) - (-> (Fuzzy )) - (function (_ elem) - (cond ( from elem) - &.~true - - ( to elem) - &.~false - - ## in the middle... - ( (
( from to) - ( elem to)))))) - - (def: #export ( from to) - (-> (Fuzzy )) - (if ( to from) - ( from to) - ( 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 [ ] - [(def: #export ( bottom middle top) - (-> (Fuzzy )) - (case (list.sort (list bottom middle top)) - (^ (list bottom middle top)) - (intersection ( bottom middle) - ( middle top)) - - _ - (undefined))) - - (def: #export ( bottom middle-bottom middle-top top) - (-> (Fuzzy )) - (case (list.sort (list bottom middle-bottom middle-top top)) - (^ (list bottom middle-bottom middle-top top)) - (intersection ( bottom middle-bottom) - ( 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 map nat-to-int nat)) (def: #export bool (Random Bool) @@ -105,7 +101,7 @@ (def: #export deg (Random Deg) - (:: Monad map frac-to-deg frac)) + (:: Monad 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 -> <- = %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 @@ ( top sample)))) ))))] - ["Frac" number.Hash r.frac &.f/triangle f/< f/<= f/> f/>=] - ["Deg" number.Hash r.deg &.d/triangle d/< d/<= d/> d/>=] + ["Deg" number.Hash r.deg &.triangle d/< d/<= d/> d/>=] ) (do-template [ ] @@ -98,33 +97,23 @@ ( top sample)))) ))))] - ["Frac" number.Hash r.frac &.f/trapezoid f/< f/<= f/> f/>=] - ["Deg" number.Hash r.deg &.d/trapezoid d/< d/<= d/> d/>=] + ["Deg" number.Hash 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 - [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)]] -- cgit v1.2.3