diff options
| -rw-r--r-- | stdlib/source/lux/data/number.lux | 273 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/number.lux | 34 |
2 files changed, 277 insertions, 30 deletions
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 7077ce70c..204b5e3a2 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -238,13 +238,12 @@ assume [] (_lux_proc ["char" "to-text"]))] - (let [digit (assume (_lux_proc ["text" "char"] [<char-set> (int-to-nat (i.% <base> input))])) - output' (_lux_proc ["text" "append"] [(_lux_proc ["char" "to-text"] [digit]) - output]) - input' (i./ <base> input)] - (if (i.= 0 input') - (_lux_proc ["text" "append"] [sign output']) - (recur input' output'))))))) + (if (i.= 0 input) + (_lux_proc ["text" "append"] [sign output]) + (let [digit (assume (_lux_proc ["text" "char"] [<char-set> (int-to-nat (i.% <base> input))]))] + (recur (i./ <base> input) + (_lux_proc ["text" "append"] [(_lux_proc ["char" "to-text"] [digit]) + output])))))))) (def: (decode repr) (let [input-size (_lux_proc ["text" "size"] [repr])] @@ -305,17 +304,253 @@ (^=> (#;Some #".") [(:: <nat> decode (_lux_proc ["text" "append"] ["+" (de-prefix repr)])) (#;Some output)]) - (#;Some (:! Deg output)) + (#;Right (:! Deg output)) _ (#;Left (_lux_proc ["text" "append"] [<error> repr]))) (#;Left (_lux_proc ["text" "append"] [<error> repr]))))))] [Binary@Codec<Text,Deg> Binary@Codec<Text,Nat> +1 "Invalid binary syntax: "] + [Octal@Codec<Text,Deg> Octal@Codec<Text,Nat> +3 "Invalid octal syntax: "] [Hex@Codec<Text,Deg> Hex@Codec<Text,Nat> +4 "Invalid hexadecimal syntax: "] ) -(do-template [<macro> <nat> <int> <error> <doc>] +(do-template [<struct> <int> <base> <char-set> <error>] + [(struct: #export <struct> (Codec Text Real) + (def: (encode value) + (let [whole (real-to-int value) + whole-part (:: <int> encode whole) + decimal (:: Number<Real> abs (r.% 1.0 value)) + decimal-part (if (r.= 0.0 decimal) + ".0" + (loop [dec-left decimal + output ""] + (if (r.= 0.0 dec-left) + (_lux_proc ["text" "append"] ["." output]) + (let [shifted (r.* <base> dec-left) + digit (|> shifted (r.% <base>) real-to-int int-to-nat + [<char-set>] (_lux_proc ["text" "char"]) assume + [] (_lux_proc ["char" "to-text"]))] + (recur (r.% 1.0 shifted) + (_lux_proc ["text" "append"] [output digit]))))))] + (_lux_proc ["text" "append"] [whole-part decimal-part]))) + + (def: (decode repr) + (case (_lux_proc ["text" "index"] [repr "." +0]) + (#;Some split-index) + (let [whole-part (assume (_lux_proc ["text" "clip"] [repr +0 split-index])) + decimal-part (assume (_lux_proc ["text" "clip"] [repr (n.inc split-index) (_lux_proc ["text" "size"] [repr])]))] + (case [(:: <int> decode whole-part) + (:: <int> decode decimal-part)] + (^=> [(#;Some whole) (#;Some decimal)] + (i.>= 0 decimal)) + (let [sign (if (i.< 0 whole) + -1.0 + 1.0) + div-power (loop [muls-left (_lux_proc ["text" "size"] [decimal-part]) + output 1.0] + (if (n.= +0 muls-left) + output + (recur (n.dec muls-left) + (r.* <base> output)))) + adjusted-decimal (|> decimal int-to-real (r./ div-power)) + dec-deg (case (:: Hex@Codec<Text,Deg> decode (_lux_proc ["text" "append"] ["." decimal-part])) + (#;Right dec-deg) + dec-deg + + (#;Left error) + (error! error))] + (#;Right (r.+ (int-to-real whole) + (r.* sign adjusted-decimal)))) + + _ + (#;Left (_lux_proc ["text" "append"] [<error> repr])))) + + _ + (#;Left (_lux_proc ["text" "append"] [<error> repr])))))] + + [Binary@Codec<Text,Real> Binary@Codec<Text,Int> 2.0 "01" "Invalid binary syntax: "] + ) + +(def: (segment-digits chunk-size digits) + (-> Nat Text (List Text)) + (let [num-digits (_lux_proc ["text" "size"] [digits])] + (if (n.<= chunk-size num-digits) + (list digits) + (let [chunk (assume (_lux_proc ["text" "clip"] [digits +0 chunk-size])) + remaining (assume (_lux_proc ["text" "clip"] [digits chunk-size num-digits]))] + (list& chunk (segment-digits chunk-size remaining)))))) + +(def: (bin-segment-to-hex input) + (-> Text Text) + (case input + "0000" "0" + "0001" "1" + "0010" "2" + "0011" "3" + "0100" "4" + "0101" "5" + "0110" "6" + "0111" "7" + "1000" "8" + "1001" "9" + "1010" "A" + "1011" "B" + "1100" "C" + "1101" "D" + "1110" "E" + "1111" "F" + _ (undefined))) + +(def: (hex-segment-to-bin input) + (-> Text Text) + (case input + "0" "0000" + "1" "0001" + "2" "0010" + "3" "0011" + "4" "0100" + "5" "0101" + "6" "0110" + "7" "0111" + "8" "1000" + "9" "1001" + "A" "1010" + "B" "1011" + "C" "1100" + "D" "1101" + "E" "1110" + "F" "1111" + _ (undefined))) + +(def: (bin-segment-to-octal input) + (-> Text Text) + (case input + "000" "0" + "001" "1" + "010" "2" + "011" "3" + "100" "4" + "101" "5" + "110" "6" + "111" "7" + _ (undefined))) + +(def: (octal-segment-to-bin input) + (-> Text Text) + (case input + "0" "000" + "1" "001" + "2" "010" + "3" "011" + "4" "100" + "5" "101" + "6" "110" + "7" "111" + _ (undefined))) + +(def: (map f xs) + (All [a b] (-> (-> a b) (List a) (List b))) + (case xs + #;Nil + #;Nil + + (#;Cons x xs') + (#;Cons (f x) (map f xs')))) + +(def: (re-join-chunks xs) + (-> (List Text) Text) + (case xs + #;Nil + "" + + (#;Cons x xs') + (_lux_proc ["text" "append"] [x (re-join-chunks xs')]))) + +(do-template [<from> <from-translator> <to> <to-translator> <base-bits>] + [(def: (<from> input) + (-> Text Text) + (let [max-num-chars (n./ <base-bits> +64) + input-size (_lux_proc ["text" "size"] [input]) + zero-padding (let [num-digits-that-need-padding (n.% <base-bits> input-size)] + (if (n.= +0 num-digits-that-need-padding) + "" + (loop [zeroes-left (n.- num-digits-that-need-padding + <base-bits>) + output ""] + (if (n.= +0 zeroes-left) + output + (recur (n.dec zeroes-left) + (_lux_proc ["text" "append"] ["0" output])))))) + padded-input (_lux_proc ["text" "append"] [input zero-padding])] + (|> padded-input + (segment-digits <base-bits>) + (map <from-translator>) + re-join-chunks))) + + (def: (<to> input) + (-> Text Text) + (|> input + (segment-digits +1) + (map <to-translator>) + re-join-chunks))] + + [binary-to-hex bin-segment-to-hex hex-to-binary hex-segment-to-bin +4] + [binary-to-octal bin-segment-to-octal octal-to-binary octal-segment-to-bin +3] + ) + +(do-template [<struct> <error> <from> <to>] + [(struct: #export <struct> (Codec Text Real) + (def: (encode value) + (let [sign (:: Number<Real> signum value) + raw-bin (:: Binary@Codec<Text,Real> encode value) + dot-idx (assume (_lux_proc ["text" "index"] [raw-bin "." +0])) + whole-part (assume (_lux_proc ["text" "clip"] [raw-bin + (if (r.= -1.0 sign) +1 +0) + dot-idx])) + decimal-part (assume (_lux_proc ["text" "clip"] [raw-bin (n.inc dot-idx) (_lux_proc ["text" "size"] [raw-bin])])) + hex-output (|> (<from> decimal-part) + ["."] + (_lux_proc ["text" "append"]) + [(<from> whole-part)] + (_lux_proc ["text" "append"]) + [(if (r.= -1.0 sign) "-" "")] + (_lux_proc ["text" "append"]))] + hex-output)) + + (def: (decode repr) + (let [sign (case (_lux_proc ["text" "index"] [repr "-" +0]) + (#;Some +0) + -1.0 + + _ + 1.0)] + (case (_lux_proc ["text" "index"] [repr "." +0]) + (#;Some split-index) + (let [whole-part (assume (_lux_proc ["text" "clip"] [repr (if (r.= -1.0 sign) +1 +0) split-index])) + decimal-part (assume (_lux_proc ["text" "clip"] [repr (n.inc split-index) (_lux_proc ["text" "size"] [repr])])) + as-binary (|> (<to> decimal-part) + ["."] + (_lux_proc ["text" "append"]) + [(<to> whole-part)] + (_lux_proc ["text" "append"]) + [(if (r.= -1.0 sign) "-" "")] + (_lux_proc ["text" "append"]))] + (case (:: Binary@Codec<Text,Real> decode as-binary) + (#;Left _) + (#;Left (_lux_proc ["text" "append"] [<error> repr])) + + output + output)) + + _ + (#;Left (_lux_proc ["text" "append"] [<error> repr]))))))] + + [Octal@Codec<Text,Real> "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary] + [Hex@Codec<Text,Real> "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary] + ) + +(do-template [<macro> <nat> <int> <deg> <real> <error> <doc>] [(macro: #export (<macro> tokens state) {#;doc <doc>} (case tokens @@ -328,22 +563,30 @@ [(:: <int> decode repr) (#;Right value)]) (#;Right [state (list [meta (#;IntS value)])]) + (^=> (#;Left _) + [(:: <deg> decode repr) (#;Right value)]) + (#;Right [state (list [meta (#;DegS value)])]) + + (^=> (#;Left _) + [(:: <real> decode repr) (#;Right value)]) + (#;Right [state (list [meta (#;RealS value)])]) + _ (#;Left <error>)) _ (#;Left <error>)))] - [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> + [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> Binary@Codec<Text,Deg> Binary@Codec<Text,Real> "Invalid binary syntax." - (doc "Given syntax for a binary number, generates a Nat, an Int, a Real or a Deg." + (doc "Given syntax for a binary number, generates a Nat, an Int, a Deg or a Real." (bin "11001001"))] - [oct Octal@Codec<Text,Nat> Octal@Codec<Text,Int> + [oct Octal@Codec<Text,Nat> Octal@Codec<Text,Int> Octal@Codec<Text,Deg> Octal@Codec<Text,Real> "Invalid octal syntax." - (doc "Given syntax for an octal number, generates a Nat, an Int, a Real or a Deg." + (doc "Given syntax for a octal number, generates a Nat, an Int, a Deg or a Real." (oct "615243"))] - [hex Hex@Codec<Text,Nat> Hex@Codec<Text,Int> + [hex Hex@Codec<Text,Nat> Hex@Codec<Text,Int> Hex@Codec<Text,Deg> Hex@Codec<Text,Real> "Invalid hexadecimal syntax." - (doc "Given syntax for a hexadecimal number, generates a Nat, an Int, a Real or a Deg." + (doc "Given syntax for a hexadecimal number, generates a Nat, an Int, a Deg or a Real." (hex "deadBEEF"))] ) diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux index eb09eec09..131db1441 100644 --- a/stdlib/test/test/lux/data/number.lux +++ b/stdlib/test/test/lux/data/number.lux @@ -122,19 +122,23 @@ (#;Left _) false))))] - ["Nat/Binary" R;nat Eq<Nat> Binary@Codec<Text,Nat>] - ["Nat/Octal" R;nat Eq<Nat> Octal@Codec<Text,Nat>] - ["Nat" R;nat Eq<Nat> Codec<Text,Nat>] - ["Nat/Hex" R;nat Eq<Nat> Hex@Codec<Text,Nat>] - - ["Int/Binary" R;int Eq<Int> Binary@Codec<Text,Int>] - ["Int/Octal" R;int Eq<Int> Octal@Codec<Text,Int>] - ["Int" R;int Eq<Int> Codec<Text,Int>] - ["Int/Hex" R;int Eq<Int> Hex@Codec<Text,Int>] - - ["Deg/Binary" R;deg Eq<Deg> Binary@Codec<Text,Deg>] - ["Deg" R;deg Eq<Deg> Codec<Text,Deg>] - ["Deg/Hex" R;deg Eq<Deg> Hex@Codec<Text,Deg>] - - ["Real" R;real Eq<Real> Codec<Text,Real>] + ["Nat/Binary" R;nat Eq<Nat> Binary@Codec<Text,Nat>] + ["Nat/Octal" R;nat Eq<Nat> Octal@Codec<Text,Nat>] + ["Nat/Decimal" R;nat Eq<Nat> Codec<Text,Nat>] + ["Nat/Hex" R;nat Eq<Nat> Hex@Codec<Text,Nat>] + + ["Int/Binary" R;int Eq<Int> Binary@Codec<Text,Int>] + ["Int/Octal" R;int Eq<Int> Octal@Codec<Text,Int>] + ["Int/Decimal" R;int Eq<Int> Codec<Text,Int>] + ["Int/Hex" R;int Eq<Int> Hex@Codec<Text,Int>] + + ["Deg/Binary" R;deg Eq<Deg> Binary@Codec<Text,Deg>] + ["Deg/Octal" R;deg Eq<Deg> Octal@Codec<Text,Deg>] + ["Deg/Decimal" R;deg Eq<Deg> Codec<Text,Deg>] + ["Deg/Hex" R;deg Eq<Deg> Hex@Codec<Text,Deg>] + + ["Real/Binary" R;real Eq<Real> Binary@Codec<Text,Real>] + ["Real/Octal" R;real Eq<Real> Octal@Codec<Text,Real>] + ["Real/Decimal" R;real Eq<Real> Codec<Text,Real>] + ["Real/Hex" R;real Eq<Real> Hex@Codec<Text,Real>] ) |