diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/math/logic/fuzzy.lux | 150 | ||||
| -rw-r--r-- | stdlib/test/test/lux/math/logic/fuzzy.lux | 175 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 3 |
3 files changed, 327 insertions, 1 deletions
diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux new file mode 100644 index 000000000..12d8b9dc3 --- /dev/null +++ b/stdlib/source/lux/math/logic/fuzzy.lux @@ -0,0 +1,150 @@ +(;module: + lux + (lux (data [number "Deg/" Interval<Deg>] + (coll [list] + [set]) + text/format) + [math]) + (.. ["&" continuous])) + +(type: #export (Fuzzy a) + (-> a Deg)) + +(def: #export (membership elem set) + (All [a] (-> a (Fuzzy a) Deg)) + (set elem)) + +(def: #export (union left right) + (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a))) + (lambda [elem] + (&;~or (membership elem left) + (membership elem right)))) + +(def: #export (intersection left right) + (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a))) + (lambda [elem] + (&;~and (membership elem left) + (membership elem right)))) + +(def: #export (complement set) + (All [a] (-> (Fuzzy a) (Fuzzy a))) + (lambda [elem] + (&;~not (membership elem set)))) + +(def: #export (difference sub base) + (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a))) + (lambda [elem] + (&;~and (membership elem base) + (&;~not (membership elem sub))))) + +(def: #export (from-predicate predicate) + (All [a] (-> (-> a Bool) (Fuzzy a))) + (lambda [elem] + (if (predicate elem) + &;~true + &;~false))) + +(def: #export (from-set set) + (All [a] (-> (set;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>)) + (lambda [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>)) + (lambda [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] + [r.ascending r.descending r.gradient Real r.< r.> r.<= r.>= r.- r./ real-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.<] + [r.triangle r.trapezoid Real r.ascending r.descending r.<] + ) + +(def: #export (gaussian deviation center) + (-> Real Real (Fuzzy Real)) + (lambda [elem] + (let [scale (|> deviation math;square (r.* 2.0)) + membership (|> elem + (r.- center) + math;square + (r.* -1.0) + (r./ scale) + math;exp)] + (if (r.= 1.0 membership) + &;~true + (real-to-deg membership))))) + +(def: #export (cut treshold set) + (All [a] (-> Deg (Fuzzy a) (Fuzzy a))) + (lambda [elem] + (let [membership (set elem)] + (if (d.> treshold membership) + (|> membership (d.- treshold) (d.* &;~true)) + &;~false)))) + +(def: #export (to-predicate treshold set) + (All [a] (-> Deg (Fuzzy a) (-> a Bool))) + (lambda [elem] + (d.> treshold (set elem)))) + +(type: #export (Fuzzy2 a) + (-> a [Deg Deg])) + +(def: #export (type-2 lower upper) + (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy2 a))) + (lambda [elem] + (let [l-deg (lower elem) + u-deg (upper elem)] + [(d.min l-deg + u-deg) + u-deg]))) diff --git a/stdlib/test/test/lux/math/logic/fuzzy.lux b/stdlib/test/test/lux/math/logic/fuzzy.lux new file mode 100644 index 000000000..5b25ecf44 --- /dev/null +++ b/stdlib/test/test/lux/math/logic/fuzzy.lux @@ -0,0 +1,175 @@ +(;module: + lux + (lux [io] + (control monad) + (codata function) + (data (coll [list] + [set]) + [bool "B/" Eq<Bool>] + [number] + text/format) + ["R" random] + pipe + (math/logic ["&" fuzzy] + continuous)) + lux/test) + +(do-template [<desc> <gen> <triangle> <lt> <lte> <gt> <gte>] + [(test: (format "[" <desc> "] " "Triangles") + [x <gen> + y <gen> + z <gen> + sample <gen> + #let [[bottom middle top] (case (list;sort <lt> (list x y z)) + (^ (list bottom middle top)) + [bottom middle top] + + _ + (undefined)) + triangle (<triangle> x y z)]] + ($_ seq + (assert "The middle value will always have maximum membership." + (d.= ~true (&;membership middle triangle))) + + (assert "Boundary values will always have 0 membership." + (and (d.= ~false (&;membership bottom triangle)) + (d.= ~false (&;membership top triangle)))) + + (assert "Values within range, will have membership > 0." + (B/= (d.> ~false (&;membership sample triangle)) + (and (<gt> bottom sample) + (<lt> top sample)))) + + (assert "Values outside of range, will have membership = 0." + (B/= (d.= ~false (&;membership sample triangle)) + (or (<lte> bottom sample) + (<gte> top sample)))) + ))] + + ["Real" R;real &;r.triangle r.< r.<= r.> r.>=] + ["Deg" R;deg &;d.triangle d.< d.<= d.> d.>=] + ) + +(do-template [<desc> <gen> <trapezoid> <lt> <lte> <gt> <gte>] + [(test: (format "[" <desc> "] " "Trapezoids") + [w <gen> + x <gen> + y <gen> + z <gen> + sample <gen> + #let [[bottom middle-bottom middle-top top] (case (list;sort <lt> (list w x y z)) + (^ (list bottom middle-bottom middle-top top)) + [bottom middle-bottom middle-top top] + + _ + (undefined)) + trapezoid (<trapezoid> w x y z)]] + ($_ seq + (assert "The middle values will always have maximum membership." + (and (d.= ~true (&;membership middle-bottom trapezoid)) + (d.= ~true (&;membership middle-top trapezoid)))) + + (assert "Boundary values will always have 0 membership." + (and (d.= ~false (&;membership bottom trapezoid)) + (d.= ~false (&;membership top trapezoid)))) + + (assert "Values within inner range will have membership = 1" + (B/= (d.= ~true (&;membership sample trapezoid)) + (and (<gte> middle-bottom sample) + (<lte> middle-top sample)))) + + (assert "Values within range, will have membership > 0." + (B/= (d.> ~false (&;membership sample trapezoid)) + (and (<gt> bottom sample) + (<lt> top sample)))) + + (assert "Values outside of range, will have membership = 0." + (B/= (d.= ~false (&;membership sample trapezoid)) + (or (<lte> bottom sample) + (<gte> top sample)))) + ))] + + ["Real" R;real &;r.trapezoid r.< r.<= r.> r.>=] + ["Deg" R;deg &;d.trapezoid d.< d.<= d.> d.>=] + ) + +(test: "Gaussian" + #seed +1485654865687 + [deviation R;real + center R;real + #let [gaussian (&;gaussian deviation center)]] + ($_ seq + (assert "The center value will always have maximum membership." + (d.= ~true (&;membership center gaussian))) + )) + +(def: gen-triangle + (R;Random (&;Fuzzy Real)) + (do R;Monad<Random> + [x R;real + y R;real + z R;real] + (wrap (&;r.triangle x y z)))) + +(test: "Combinators" + [left gen-triangle + right gen-triangle + sample R;real] + ($_ seq + (assert "Union membership as as high as membership in any of its members." + (let [combined (&;union left right) + combined-membership (&;membership sample combined)] + (and (d.>= (&;membership sample left) + combined-membership) + (d.>= (&;membership sample right) + combined-membership)))) + + (assert "Intersection membership as as low as membership in any of its members." + (let [combined (&;intersection left right) + combined-membership (&;membership sample combined)] + (and (d.<= (&;membership sample left) + combined-membership) + (d.<= (&;membership sample right) + combined-membership)))) + + (assert "Complement membership is the opposite of normal membership." + (d.= (&;membership sample left) + (~not (&;membership sample (&;complement left))))) + + (assert "Membership in the difference will never be higher than in the set being subtracted." + (B/= (d.> (&;membership sample right) + (&;membership sample left)) + (d.< (&;membership sample left) + (&;membership sample (&;difference left right))))) + )) + +(test: "From predicates and sets" + [#let [set-10 (set;from-list number;Hash<Nat> (list;n.range +0 +10))] + sample (|> R;nat (:: @ map (n.% +20)))] + ($_ seq + (assert "Values that satisfy a predicate have membership = 1. + Values that don't have membership = 0." + (B/= (d.= ~true (&;membership sample (&;from-predicate n.even?))) + (n.even? sample))) + + (assert "Values that belong to a set have membership = 1. + Values that don't have membership = 0." + (B/= (d.= ~true (&;membership sample (&;from-set set-10))) + (set;member? set-10 sample))) + )) + +(test: "Thresholds" + [fuzzy gen-triangle + sample R;real + threshold R;deg + #let [vip-fuzzy (&;cut threshold fuzzy) + member? (&;to-predicate threshold fuzzy)]] + ($_ seq + (assert "Can increase the threshold of membership of a fuzzy set." + (B/= (d.> ~false (&;membership sample vip-fuzzy)) + (d.> threshold (&;membership sample fuzzy)))) + + (assert "Can turn fuzzy sets into predicates through a threshold." + (B/= (member? sample) + (d.> threshold (&;membership sample fuzzy)))) + )) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 12601f75b..e3d0e15c3 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -53,7 +53,8 @@ ["_;" complex] ## ["_;" random] ["_;" simple] - (logic ["_;" continuous])) + (logic ["_;" continuous] + ["_;" fuzzy])) ## ["_;" macro] (macro ["_;" ast] ["_;" syntax] |