From 5d2dd7ab4defe092d99adc1259e28cab36765dad Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Apr 2017 00:59:05 -0400 Subject: - Added binary, octal and hexadecimal codecs for reals. - Added octal codec for degs. --- stdlib/source/lux/data/number.lux | 273 +++++++++++++++++++++++++++++++++++--- 1 file changed, 258 insertions(+), 15 deletions(-) (limited to 'stdlib/source') 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"] [ (int-to-nat (i.% input))])) - output' (_lux_proc ["text" "append"] [(_lux_proc ["char" "to-text"] [digit]) - output]) - input' (i./ 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"] [ (int-to-nat (i.% input))]))] + (recur (i./ 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 #".") [(:: decode (_lux_proc ["text" "append"] ["+" (de-prefix repr)])) (#;Some output)]) - (#;Some (:! Deg output)) + (#;Right (:! Deg output)) _ (#;Left (_lux_proc ["text" "append"] [ repr]))) (#;Left (_lux_proc ["text" "append"] [ repr]))))))] [Binary@Codec Binary@Codec +1 "Invalid binary syntax: "] + [Octal@Codec Octal@Codec +3 "Invalid octal syntax: "] [Hex@Codec Hex@Codec +4 "Invalid hexadecimal syntax: "] ) -(do-template [ ] +(do-template [ ] + [(struct: #export (Codec Text Real) + (def: (encode value) + (let [whole (real-to-int value) + whole-part (:: encode whole) + decimal (:: Number 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.* dec-left) + digit (|> shifted (r.% ) real-to-int int-to-nat + [] (_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 [(:: decode whole-part) + (:: 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.* output)))) + adjusted-decimal (|> decimal int-to-real (r./ div-power)) + dec-deg (case (:: Hex@Codec 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"] [ repr])))) + + _ + (#;Left (_lux_proc ["text" "append"] [ repr])))))] + + [Binary@Codec Binary@Codec 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 [ ] + [(def: ( input) + (-> Text Text) + (let [max-num-chars (n./ +64) + input-size (_lux_proc ["text" "size"] [input]) + zero-padding (let [num-digits-that-need-padding (n.% input-size)] + (if (n.= +0 num-digits-that-need-padding) + "" + (loop [zeroes-left (n.- num-digits-that-need-padding + ) + 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 ) + (map ) + re-join-chunks))) + + (def: ( input) + (-> Text Text) + (|> input + (segment-digits +1) + (map ) + 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: #export (Codec Text Real) + (def: (encode value) + (let [sign (:: Number signum value) + raw-bin (:: Binary@Codec 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 (|> ( decimal-part) + ["."] + (_lux_proc ["text" "append"]) + [( 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 (|> ( decimal-part) + ["."] + (_lux_proc ["text" "append"]) + [( whole-part)] + (_lux_proc ["text" "append"]) + [(if (r.= -1.0 sign) "-" "")] + (_lux_proc ["text" "append"]))] + (case (:: Binary@Codec decode as-binary) + (#;Left _) + (#;Left (_lux_proc ["text" "append"] [ repr])) + + output + output)) + + _ + (#;Left (_lux_proc ["text" "append"] [ repr]))))))] + + [Octal@Codec "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary] + [Hex@Codec "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary] + ) + +(do-template [ ] [(macro: #export ( tokens state) {#;doc } (case tokens @@ -328,22 +563,30 @@ [(:: decode repr) (#;Right value)]) (#;Right [state (list [meta (#;IntS value)])]) + (^=> (#;Left _) + [(:: decode repr) (#;Right value)]) + (#;Right [state (list [meta (#;DegS value)])]) + + (^=> (#;Left _) + [(:: decode repr) (#;Right value)]) + (#;Right [state (list [meta (#;RealS value)])]) + _ (#;Left )) _ (#;Left )))] - [bin Binary@Codec Binary@Codec + [bin Binary@Codec Binary@Codec Binary@Codec Binary@Codec "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 Octal@Codec + [oct Octal@Codec Octal@Codec Octal@Codec Octal@Codec "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 Hex@Codec + [hex Hex@Codec Hex@Codec Hex@Codec Hex@Codec "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"))] ) -- cgit v1.2.3