From fb72b937aba7886ce204379e97aa06c327a4029f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 May 2018 23:27:12 -0400 Subject: - Implemented Nat functionality in pure Lux. --- stdlib/source/lux.lux | 189 +++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 165 insertions(+), 24 deletions(-) (limited to 'stdlib/source/lux.lux') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 6bec61741..6e6397eeb 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -867,6 +867,11 @@ #Nil])])))) (record$ #Nil)) +("lux def" export-meta + ("lux check" (#Product Code Code) + [(tag$ ["lux" "export?"]) (bool$ true)]) + (record$ #Nil)) + ("lux def" export?-meta ("lux check" Code (flag-meta "export?")) @@ -893,6 +898,11 @@ (#Cons tail #Nil)))))) (record$ #Nil)) +("lux def" doc-meta + ("lux check" (#Function Text (#Product Code Code)) + (function'' [doc] [(tag$ ["lux" "doc"]) (text$ doc)])) + (record$ #Nil)) + ("lux def" def:'' ("lux check" Macro (function'' [tokens] @@ -1104,6 +1114,36 @@ syntax}) ) +(def:'' (n/+ param subject) + (#.Cons (doc-meta "Nat(ural) addition.") + (#.Cons export-meta + #.Nil)) + (#Function Nat (#Function Nat Nat)) + ("lux coerce" Nat + ("lux int +" + ("lux coerce" Int subject) + ("lux coerce" Int param)))) + +(def:'' (n/- param subject) + (#.Cons (doc-meta "Nat(ural) substraction.") + (#.Cons export-meta + #.Nil)) + (#Function Nat (#Function Nat Nat)) + ("lux coerce" Nat + ("lux int -" + ("lux coerce" Int subject) + ("lux coerce" Int param)))) + +(def:'' (n/* param subject) + (#.Cons (doc-meta "Nat(ural) multiplication.") + (#.Cons export-meta + #.Nil)) + (#Function Nat (#Function Nat Nat)) + ("lux coerce" Nat + ("lux int *" + ("lux coerce" Int subject) + ("lux coerce" Int param)))) + (def:'' (update-bounds code) #Nil (#Function Code Code) @@ -1119,7 +1159,7 @@ pairs)) [_ (#Form (#Cons [_ (#Tag "lux" "Bound")] (#Cons [_ (#Nat idx)] #Nil)))] - (form$ (#Cons (tag$ ["lux" "Bound"]) (#Cons (nat$ ("lux nat +" +2 idx)) #Nil))) + (form$ (#Cons (tag$ ["lux" "Bound"]) (#Cons (nat$ (n/+ +2 idx)) #Nil))) [_ (#Form members)] (form$ (list/map update-bounds members)) @@ -1170,7 +1210,7 @@ #Nil (#UnivQ #Nil (#Function ($' List (#Bound +1)) Nat)) - (list/fold (function'' [_ acc] ("lux nat +" +1 acc)) +0 list)) + (list/fold (function'' [_ acc] (n/+ +1 acc)) +0 list)) (macro:' #export (All tokens) (#Cons [(tag$ ["lux" "doc"]) @@ -1209,10 +1249,7 @@ body' [false _] - (replace-syntax (#Cons [self-name (make-bound ("lux nat *" - +2 ("lux nat -" - (list/size names) - +1)))] + (replace-syntax (#Cons [self-name (make-bound (n/* +2 (n/- +1 (list/size names))))] #Nil) body')}) #Nil))))) @@ -1260,10 +1297,7 @@ body' [false _] - (replace-syntax (#Cons [self-name (make-bound ("lux nat *" - +2 ("lux nat -" - (list/size names) - +1)))] + (replace-syntax (#Cons [self-name (make-bound (n/* +2 (n/- +1 (list/size names))))] #Nil) body')}) #Nil))))) @@ -2163,6 +2197,73 @@ (-> (-> a Bool) ($' List a) Bool)) (list/fold (function' [_2 _1] (if _1 (p _2) false)) true xs)) +(def:''' #export (n/= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Nat(ural) equality.")]) + (-> Nat Nat Bool) + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test))) + +(def:''' (high-bits value) + (list) + (-> Nat Int) + ("lux coerce" Int ("lux bit logical-right-shift" value +32))) + +(def:''' low-mask + (list) + Nat + ("lux coerce" Nat + ("lux int -" + ("lux coerce" Int + ("lux bit left-shift" +1 +32)) + 1))) + +(def:''' (low-bits value) + (list) + (-> Nat Int) + ("lux coerce" Int ("lux bit and" value low-mask))) + +(def:''' #export (n/< test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Nat(ural) less-than.")]) + (-> Nat Nat Bool) + (let' [testH (high-bits test) + subjectH (high-bits subject)] + (if ("lux int <" subjectH testH) + true + (if ("lux int =" subjectH testH) + ("lux int <" + (low-bits subject) + (low-bits test)) + false)))) + +(def:''' #export (n/<= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Nat(ural) less-than-equal.")]) + (-> Nat Nat Bool) + (if (n/< test subject) + true + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test)))) + +(def:''' #export (n/> test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Nat(ural) greater-than.")]) + (-> Nat Nat Bool) + (n/< subject test)) + +(def:''' #export (n/>= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Nat(ural) greater-than-equal.")]) + (-> Nat Nat Bool) + (if (n/< subject test) + true + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test)))) + (macro:' #export (do-template tokens) (list [(tag$ ["lux" "doc"]) (text$ "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. @@ -2181,7 +2282,7 @@ (let' [apply ("lux check" (-> RepEnv ($' List Code)) (function' [env] (list/map (apply-template env) templates))) num-bindings (list/size bindings')] - (if (every? (function' [sample] ("lux nat =" num-bindings sample)) + (if (every? (n/= num-bindings) (list/map list/size data')) (|> data' (join-map (compose apply (make-env bindings'))) @@ -2231,9 +2332,6 @@ true ( subject test)))] - [ Nat "lux nat =" "lux nat <" n/= n/< n/<= n/> n/>= - "Nat(ural) equality." "Nat(ural) less-than." "Nat(ural) less-than-equal." "Nat(ural) greater-than." "Nat(ural) greater-than-equal."] - [ 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."] @@ -2244,6 +2342,48 @@ "Frac(tion) equality." "Frac(tion) less-than." "Frac(tion) less-than-equal." "Frac(tion) greater-than." "Frac(tion) greater-than-equal."] ) +(def:''' #export (n// param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Nat(ural) division.")]) + (-> Nat Nat Nat) + (if ("lux int <" ("lux coerce" Int param) 0) + (if (n/< param subject) + +0 + +1) + (let' [quotient ("lux bit left-shift" + ("lux coerce" Nat + ("lux int /" + ("lux coerce" Int + ("lux bit logical-right-shift" + subject + +1)) + ("lux coerce" Int param))) + +1) + remainder ("lux coerce" Nat + ("lux int -" + ("lux coerce" Int subject) + ("lux int *" + ("lux coerce" Int quotient) + ("lux coerce" Int param))))] + (if (n/< param remainder) + quotient + ("lux coerce" Nat + ("lux int +" + ("lux coerce" Int quotient) + 1)))))) + +(def:''' #export (n/% param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Nat(ural) remainder.")]) + (-> Nat Nat Nat) + (let' [flat ("lux int *" + ("lux coerce" Int (n// param subject)) + ("lux coerce" Int param))] + ("lux coerce" Nat + ("lux int -" + ("lux coerce" Int subject) + flat)))) + (do-template [ ] [(def:''' #export ( param subject) (list [(tag$ ["lux" "doc"]) @@ -2251,12 +2391,6 @@ (-> ) ( subject param))] - [ Nat n/+ "lux nat +" "Nat(ural) addition."] - [ Nat n/- "lux nat -" "Nat(ural) substraction."] - [ Nat n/* "lux nat *" "Nat(ural) multiplication."] - [ Nat n// "lux nat /" "Nat(ural) division."] - [ Nat n/% "lux nat %" "Nat(ural) remainder."] - [ Int i/+ "lux int +" "Int(eger) addition."] [ Int i/- "lux int -" "Int(eger) substraction."] [ Int i/* "lux int *" "Int(eger) multiplication."] @@ -2305,8 +2439,8 @@ [d/min Deg d/< "Deg(ree) minimum."] [d/max Deg d/> "Deg(ree) maximum."] - [f/min Frac f/< "Frac minimum."] - [f/max Frac f/> "Frac minimum."] + [f/min Frac f/< "Frac(tion) minimum."] + [f/max Frac f/> "Frac(tion) minimum."] ) (def:''' (bool/encode x) @@ -5069,13 +5203,20 @@ (-> Ident Text) (|>> ident/encode (text/compose "#"))) +(do-template [ ] + [(def: #export + (-> ) + (|>> (:! )))] + + [int-to-nat Int Nat] + [nat-to-int Nat Int] + ) + (do-template [ ] [(def: #export ( input) (-> ) ( input))] - [int-to-nat "lux int to-nat" Int Nat] - [nat-to-int "lux nat to-int" Nat Int] [frac-to-deg "lux frac to-deg" Frac Deg] [deg-to-frac "lux deg to-frac" Deg Frac] ) -- cgit v1.2.3