From 4024d7f87d77fe9e1686fc3ebe021fd07ddd13bb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Apr 2017 18:53:59 -0400 Subject: - Added binary, octal and hexadecimal codecs for ints. - Generalized the bin, oct and hex macros so they also work with ints (in the future, they will also work with degs and reals). - Binary, octal and hexadecimal nats now have a + sign in front, like normal nats. --- stdlib/source/lux/data/number.lux | 242 +++++++++++++++++--------------------- 1 file changed, 110 insertions(+), 132 deletions(-) (limited to 'stdlib/source') diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 62c7abd6b..a854e8bf7 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -131,6 +131,22 @@ [ Min@Monoid Deg (:: Interval top) d.min] ) +(do-template [ ] + [(def: #export + {#;doc } + Real + (_lux_proc ["real" ] []))] + + [not-a-number "not-a-number" "Not-a-number."] + [positive-infinity "positive-infinity" "Positive infinity."] + [negative-infinity "negative-infinity" "Negative infinity."] + ) + +(def: #export (not-a-number? number) + {#;doc "Tests whether a real is actually not-a-number."} + (-> Real Bool) + (not (r.= number number))) + (do-template [ ] [(struct: #export _ (Codec Text ) (def: (encode x) @@ -144,103 +160,10 @@ #;None (#;Left ))))] - [ Deg [ "deg" "encode"] [ "deg" "decode"] "Couldn't decode Deg"] [Real ["real" "encode"] ["real" "decode"] "Couldn't decode Real"] + [ Deg [ "deg" "encode"] [ "deg" "decode"] "Couldn't decode Deg"] ) -(def: (digit-to-text digit) - (-> Nat Text) - (case digit - +0 "0" - +1 "1" +2 "2" +3 "3" - +4 "4" +5 "5" +6 "6" - +7 "7" +8 "8" +9 "9" - _ (undefined))) - -(def: (text-to-digit digit) - (-> Text (Maybe Nat)) - (case digit - "0" (#;Some +0) - "1" (#;Some +1) "2" (#;Some +2) "3" (#;Some +3) - "4" (#;Some +4) "5" (#;Some +5) "6" (#;Some +6) - "7" (#;Some +7) "8" (#;Some +8) "9" (#;Some +9) - _ #;None)) - -(struct: #export _ (Codec Text Int) - (def: (encode value) - (if (i.= 0 value) - "0" - (let [sign (if (i.> 0 value) - "" - "-")] - (loop [input (|> value (i./ 10) (:: Number abs)) - output (|> value (i.% 10) (:: Number abs) int-to-nat digit-to-text)] - (if (i.= 0 input) - (_lux_proc ["text" "append"] [sign output]) - (recur (i./ 10 input) - (_lux_proc ["text" "append"] [(|> input (i.% 10) int-to-nat digit-to-text) - output]))))) - )) - - (def: (decode repr) - (let [input-size (_lux_proc ["text" "size"] [repr])] - (if (n.>= +1 input-size) - (let [sign (case (_lux_proc ["text" "char"] [repr +0]) - (#;Some #"-") - -1 - - _ - 1)] - (loop [idx (if (i.= -1 sign) +1 +0) - output 0] - (if (n.< input-size idx) - (case (_lux_proc ["text" "char"] [repr idx]) - (^=> (#;Some sample) - [(text-to-digit (_lux_proc ["char" "to-text"] [sample])) (#;Some digit)]) - (recur (n.inc idx) - (|> output (i.* 10) (i.+ (nat-to-int digit)))) - - _ - (undefined)) - (#;Right (i.* sign output))))) - (#;Left "Invalid syntax for Int."))))) - -(struct: #export _ (Codec Text Nat) - (def: (encode value) - (case value - +0 - "+0" - - _ - (loop [input value - output ""] - (if (n.= +0 input) - (_lux_proc ["text" "append"] ["+" output]) - (recur (n./ +10 input) - (_lux_proc ["text" "append"] [(digit-to-text (n.% +10 input)) output])))))) - - (def: (decode repr) - (let [input-size (_lux_proc ["text" "size"] [repr])] - (if (n.>= +2 input-size) - (case (_lux_proc ["text" "char"] [repr +0]) - (#;Some #"+") - (loop [idx +1 - output +0] - (if (n.< input-size idx) - (case (_lux_proc ["text" "char"] [repr idx]) - (^=> (#;Some sample) - [(text-to-digit (_lux_proc ["char" "to-text"] [sample])) (#;Some digit)]) - (recur (n.inc idx) - (|> output (n.* +10) (n.+ digit))) - - _ - (undefined)) - (#;Right output))) - - _ - (#;Left "Invalid syntax for Nat.")) - (#;Left "Invalid syntax for Nat."))))) - (struct: #export _ (Hash Nat) (def: eq Eq) (def: hash id)) @@ -255,24 +178,8 @@ (def: (hash value) (_lux_proc ["real" "hash"] [value]))) -(do-template [ ] - [(def: #export - {#;doc } - Real - (_lux_proc ["real" ] []))] - - [not-a-number "not-a-number" "Not-a-number."] - [positive-infinity "positive-infinity" "Positive infinity."] - [negative-infinity "negative-infinity" "Negative infinity."] - ) - -(def: #export (not-a-number? number) - {#;doc "Tests whether a real is actually not-a-number."} - (-> Real Bool) - (not (r.= number number))) - ## [Values & Syntax] -(do-template [ ] +(do-template [ ] [(struct: #export (Codec Text Nat) (def: (encode value) (loop [input value @@ -282,16 +189,75 @@ output]) input' (n./ input)] (if (n.= +0 input') - output' + (_lux_proc ["text" "append"] ["+" output']) (recur input' output'))))) (def: (decode repr) (let [input-size (_lux_proc ["text" "size"] [repr])] - (if (n.= +0 input-size) - (#;Left "Empty input.") - (let [input (_lux_proc ["text" "upper-case"] [repr])] - (loop [idx +0 - output +0] + (if (n.>= +2 input-size) + (case (_lux_proc ["text" "char"] [repr +0]) + (#;Some #"+") + (let [input (_lux_proc ["text" "upper-case"] [repr])] + (loop [idx +1 + output +0] + (if (n.< input-size idx) + (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] + (case (_lux_proc ["text" "index"] + [ + (_lux_proc ["char" "to-text"] [digit]) + +0]) + #;None + (#;Left (_lux_proc ["text" "append"] [ repr])) + + (#;Some index) + (recur (n.inc idx) + (|> output (n.* ) (n.+ index))))) + (#;Right output)))) + + _ + (#;Left (_lux_proc ["text" "append"] [ repr]))) + (#;Left (_lux_proc ["text" "append"] [ repr]))))))] + + [Binary@Codec +2 "01" "Invalid binary syntax: "] + [Octal@Codec +8 "01234567" "Invalid octal syntax: "] + [_ +10 "0123456789" "Invalid syntax for Nat: "] + [Hex@Codec +16 "0123456789ABCDEF" "Invalid hexadecimal syntax: "] + ) + +(do-template [ ] + [(struct: #export (Codec Text Int) + (def: (encode value) + (if (i.= 0 value) + "0" + (let [sign (if (i.< 0 value) + "-" + "")] + (loop [input (|> value (i./ ) (:: Number abs)) + output (|> value (i.% ) (:: Number abs) + int-to-nat [] (_lux_proc ["text" "char"]) + 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'))))))) + + (def: (decode repr) + (let [input-size (_lux_proc ["text" "size"] [repr])] + (if (n.>= +1 input-size) + (let [sign (case (_lux_proc ["text" "char"] [repr +0]) + (#;Some #"-") + -1 + + _ + 1) + input (_lux_proc ["text" "upper-case"] [repr])] + (loop [idx (if (i.= -1 sign) +1 +0) + output 0] (if (n.< input-size idx) (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] (case (_lux_proc ["text" "index"] @@ -303,33 +269,45 @@ (#;Some index) (recur (n.inc idx) - (|> output (n.* ) (n.+ index))))) - (#;Right output)))))))) + (|> output (i.* ) (i.+ (nat-to-int index)))))) + (#;Right (i.* sign output))))) + (#;Left )))))] + + [Binary@Codec 2 "01" "Invalid binary syntax."] + [Octal@Codec 8 "01234567" "Invalid octal syntax."] + [_ 10 "0123456789" "Invalid syntax for Int: "] + [Hex@Codec 16 "0123456789ABCDEF" "Invalid hexadecimal syntax."] + ) - (macro: #export ( tokens state) +(do-template [ ] + [(macro: #export ( tokens state) {#;doc } (case tokens (#;Cons [meta (#;TextS repr)] #;Nil) - (case (:: decode repr) + (case (:: decode repr) (#;Right value) (#;Right [state (list [meta (#;NatS value)])]) - (#;Left error) - (#;Left error)) + (^=> (#;Left _) + [(:: decode repr) (#;Right value)]) + (#;Right [state (list [meta (#;IntS value)])]) + + _ + (#;Left )) _ (#;Left )))] - [Binary@Codec +2 bin "Invalid binary syntax." - "01" - (doc "Given syntax for a binary number, generates a Nat." + [bin Binary@Codec Binary@Codec + "Invalid binary syntax." + (doc "Given syntax for a binary number, generates a Nat, an Int, a Real or a Deg." (bin "11001001"))] - [Octal@Codec +8 oct "Invalid octal syntax." - "01234567" - (doc "Given syntax for an octal number, generates a Nat." + [oct Octal@Codec Octal@Codec + "Invalid octal syntax." + (doc "Given syntax for an octal number, generates a Nat, an Int, a Real or a Deg." (oct "615243"))] - [Hex@Codec +16 hex "Invalid hexadecimal syntax." - "0123456789ABCDEF" - (doc "Given syntax for a hexadecimal number, generates a Nat." + [hex Hex@Codec Hex@Codec + "Invalid hexadecimal syntax." + (doc "Given syntax for a hexadecimal number, generates a Nat, an Int, a Real or a Deg." (hex "deadBEEF"))] ) -- cgit v1.2.3