aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/data/number.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/data/number.lux')
-rw-r--r--stdlib/source/lux/data/number.lux961
1 files changed, 9 insertions, 952 deletions
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux
index f297f2788..9e658bd52 100644
--- a/stdlib/source/lux/data/number.lux
+++ b/stdlib/source/lux/data/number.lux
@@ -1,670 +1,15 @@
-(.module: {#.doc "Implementations of common structures for Lux's primitive number types."}
+(.module:
[lux #*
[control
- number
- [monoid (#+ Monoid)]
- [equivalence (#+ Equivalence)]
- hash
- ["." order (#+ Order)]
- enum
- interval
[codec (#+ Codec)]]
[data
["." error (#+ Error)]
- ["." maybe]
- ["." text (#+ Char)]
- [collection
- ["." array (#+ Array)]]]
- ["." function]
- ["." math]]
+ ["." text]]]
[/
- ["." i64]])
-
-(do-template [<type> <test>]
- [(structure: #export _ (Equivalence <type>)
- (def: = <test>))]
-
- [ Nat n/=]
- [ Int i/=]
- [ Rev r/=]
- [Frac f/=]
- )
-
-(do-template [<type> <eq> <lt> <lte> <gt> <gte>]
- [(structure: #export _ (Order <type>)
- (def: eq <eq>)
- (def: < <lt>)
- (def: <= <lte>)
- (def: > <gt>)
- (def: >= <gte>))]
-
- [ Nat Equivalence<Nat> n/< n/<= n/> n/>=]
- [ Int Equivalence<Int> i/< i/<= i/> i/>=]
- [Rev Equivalence<Rev> r/< r/<= r/> r/>=]
- [Frac Equivalence<Frac> f/< f/<= f/> f/>=]
- )
-
-(do-template [<type> <order> <succ> <pred>]
- [(structure: #export _ (Enum <type>)
- (def: order <order>)
- (def: succ <succ>)
- (def: pred <pred>))]
-
- [Nat Order<Nat> inc dec]
- [Int Order<Int> inc dec]
- [Frac Order<Frac> (f/+ ("lux frac smallest")) (f/- ("lux frac smallest"))]
- [Rev Order<Rev> inc dec]
- )
-
-(do-template [<type> <enum> <top> <bottom>]
- [(structure: #export _ (Interval <type>)
- (def: enum <enum>)
- (def: top <top>)
- (def: bottom <bottom>))]
-
- [ Nat Enum<Nat> (:coerce Nat -1) 0]
- [ Int Enum<Int> +9_223_372_036_854_775_807 -9_223_372_036_854_775_808]
- [Frac Enum<Frac> ("lux frac max") ("lux frac min")]
- [ Rev Enum<Rev> (:coerce Rev -1) (:coerce Rev 0)]
- )
-
-(structure: #export _ (Number Nat)
- (def: + n/+)
- (def: - n/-)
- (def: * n/*)
- (def: / n//)
- (def: % n/%)
- (def: (negate value) (n/- (:: Interval<Nat> top) value))
- (def: abs function.identity)
- (def: (signum x)
- (case x
- 0 0
- _ 1))
- )
-
-(do-template [<type> <order> <+> <-> <*> </> <%> <=> <<> <0> <1> <-1>]
- [(structure: #export _ (Number <type>)
- (def: + <+>)
- (def: - <->)
- (def: * <*>)
- (def: / </>)
- (def: % <%>)
- (def: negate (<*> <-1>))
- (def: (abs x)
- (if (<<> <0> x)
- (<*> <-1> x)
- x))
- (def: (signum x)
- (cond (<=> <0> x) <0>
- (<<> <0> x) <-1>
- ## else
- <1>))
- )]
-
- [ Int Order<Int> i/+ i/- i/* i// i/% i/= i/< +0 +1 -1]
- [Frac Order<Frac> f/+ f/- f/* f// f/% f/= f/< +0.0 +1.0 -1.0]
- )
-
-(structure: #export _ (Number Rev)
- (def: + r/+)
- (def: - r/-)
- (def: * r/*)
- (def: / r//)
- (def: % r/%)
- (def: (negate x) (r/- x (:coerce Rev -1)))
- (def: abs function.identity)
- (def: (signum x)
- (:coerce Rev -1)))
-
-(do-template [<name> <type> <identity> <compose>]
- [(structure: #export <name> (Monoid <type>)
- (def: identity <identity>)
- (def: compose <compose>))]
-
- [ Add@Monoid<Nat> Nat 0 n/+]
- [ Mul@Monoid<Nat> Nat 1 n/*]
- [ Max@Monoid<Nat> Nat (:: Interval<Nat> bottom) n/max]
- [ Min@Monoid<Nat> Nat (:: Interval<Nat> top) n/min]
- [ Add@Monoid<Int> Int +0 i/+]
- [ Mul@Monoid<Int> Int +1 i/*]
- [ Max@Monoid<Int> Int (:: Interval<Int> bottom) i/max]
- [ Min@Monoid<Int> Int (:: Interval<Int> top) i/min]
- [Add@Monoid<Frac> Frac +0.0 f/+]
- [Mul@Monoid<Frac> Frac +1.0 f/*]
- [Max@Monoid<Frac> Frac (:: Interval<Frac> bottom) f/max]
- [Min@Monoid<Frac> Frac (:: Interval<Frac> top) f/min]
- [ Add@Monoid<Rev> Rev (:: Interval<Rev> bottom) r/+]
- [ Mul@Monoid<Rev> Rev (:: Interval<Rev> top) r/*]
- [ Max@Monoid<Rev> Rev (:: Interval<Rev> bottom) r/max]
- [ Min@Monoid<Rev> Rev (:: Interval<Rev> top) r/min]
- )
-
-(do-template [<name> <numerator> <doc>]
- [(def: #export <name>
- {#.doc <doc>}
- Frac
- (f// +0.0 <numerator>))]
-
- [not-a-number +0.0 "Not a number."]
- [positive-infinity +1.0 "Positive infinity."]
- [negative-infinity -1.0 "Negative infinity."]
- )
-
-(def: #export (not-a-number? number)
- {#.doc "Tests whether a frac is actually not-a-number."}
- (-> Frac Bit)
- (not (f/= number number)))
-
-(def: #export (frac? value)
- (-> Frac Bit)
- (not (or (not-a-number? value)
- (f/= positive-infinity value)
- (f/= negative-infinity value))))
-
-(do-template [<type> <encoder> <decoder> <error>]
- [(structure: #export _ (Codec Text <type>)
- (def: (encode x)
- (<encoder> [x]))
-
- (def: (decode input)
- (case (<decoder> [input])
- (#.Some value)
- (#error.Success value)
-
- #.None
- (#error.Failure <error>))))]
-
- [Frac "lux frac encode" "lux frac decode" "Could not decode Frac"]
- )
-
-(def: (get-char! full idx)
- (-> Text Nat Char)
- ("lux text char" full idx))
-
-(def: (binary-character value)
- (-> Nat (Maybe Text))
- (case value
- 0 (#.Some "0")
- 1 (#.Some "1")
- _ #.None))
-
-(def: (binary-value digit)
- (-> Char (Maybe Nat))
- (case digit
- (^ (char "0")) (#.Some 0)
- (^ (char "1")) (#.Some 1)
- _ #.None))
-
-(def: (octal-character value)
- (-> Nat (Maybe Text))
- (case value
- 0 (#.Some "0")
- 1 (#.Some "1")
- 2 (#.Some "2")
- 3 (#.Some "3")
- 4 (#.Some "4")
- 5 (#.Some "5")
- 6 (#.Some "6")
- 7 (#.Some "7")
- _ #.None))
-
-(def: (octal-value digit)
- (-> Char (Maybe Nat))
- (case digit
- (^ (char "0")) (#.Some 0)
- (^ (char "1")) (#.Some 1)
- (^ (char "2")) (#.Some 2)
- (^ (char "3")) (#.Some 3)
- (^ (char "4")) (#.Some 4)
- (^ (char "5")) (#.Some 5)
- (^ (char "6")) (#.Some 6)
- (^ (char "7")) (#.Some 7)
- _ #.None))
-
-(def: (decimal-character value)
- (-> Nat (Maybe Text))
- (case value
- 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))
-
-(def: (decimal-value digit)
- (-> Char (Maybe Nat))
- (case digit
- (^ (char "0")) (#.Some 0)
- (^ (char "1")) (#.Some 1)
- (^ (char "2")) (#.Some 2)
- (^ (char "3")) (#.Some 3)
- (^ (char "4")) (#.Some 4)
- (^ (char "5")) (#.Some 5)
- (^ (char "6")) (#.Some 6)
- (^ (char "7")) (#.Some 7)
- (^ (char "8")) (#.Some 8)
- (^ (char "9")) (#.Some 9)
- _ #.None))
-
-(def: (hexadecimal-character value)
- (-> Nat (Maybe Text))
- (case value
- 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")
- 10 (#.Some "A")
- 11 (#.Some "B")
- 12 (#.Some "C")
- 13 (#.Some "D")
- 14 (#.Some "E")
- 15 (#.Some "F")
- _ #.None))
-
-(def: (hexadecimal-value digit)
- (-> Char (Maybe Nat))
- (case digit
- (^ (char "0")) (#.Some 0)
- (^ (char "1")) (#.Some 1)
- (^ (char "2")) (#.Some 2)
- (^ (char "3")) (#.Some 3)
- (^ (char "4")) (#.Some 4)
- (^ (char "5")) (#.Some 5)
- (^ (char "6")) (#.Some 6)
- (^ (char "7")) (#.Some 7)
- (^ (char "8")) (#.Some 8)
- (^ (char "9")) (#.Some 9)
- (^or (^ (char "a")) (^ (char "A"))) (#.Some 10)
- (^or (^ (char "b")) (^ (char "B"))) (#.Some 11)
- (^or (^ (char "c")) (^ (char "C"))) (#.Some 12)
- (^or (^ (char "d")) (^ (char "D"))) (#.Some 13)
- (^or (^ (char "e")) (^ (char "E"))) (#.Some 14)
- (^or (^ (char "f")) (^ (char "F"))) (#.Some 15)
- _ #.None))
-
-(do-template [<struct> <base> <to-character> <to-value> <error>]
- [(structure: #export <struct> (Codec Text Nat)
- (def: (encode value)
- (loop [input value
- output ""]
- (let [digit (maybe.assume (<to-character> (n/% <base> input)))
- output' ("lux text concat" digit output)
- input' (n// <base> input)]
- (if (n/= 0 input')
- output'
- (recur input' output')))))
-
- (def: (decode repr)
- (let [input-size ("lux text size" repr)]
- (if (n/> 0 input-size)
- (loop [idx 0
- output 0]
- (if (n/< input-size idx)
- (case (<to-value> (get-char! repr idx))
- #.None
- (#error.Failure ("lux text concat" <error> repr))
-
- (#.Some digit-value)
- (recur (inc idx)
- (|> output (n/* <base>) (n/+ digit-value))))
- (#error.Success output)))
- (#error.Failure ("lux text concat" <error> repr))))))]
-
- [Binary@Codec<Text,Nat> 2 binary-character binary-value "Invalid binary syntax for Nat: "]
- [Octal@Codec<Text,Nat> 8 octal-character octal-value "Invalid octal syntax for Nat: "]
- [_ 10 decimal-character decimal-value "Invalid syntax for Nat: "]
- [Hex@Codec<Text,Nat> 16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "]
- )
-
-(def: (int/sign!! value)
- (-> Int Text)
- (if (i/< +0 value)
- "-"
- "+"))
-
-(def: (int/sign?? representation)
- (-> Text (Maybe Int))
- (case (get-char! representation 0)
- (^ (char "-"))
- (#.Some -1)
-
- (^ (char "+"))
- (#.Some +1)
-
- _
- #.None))
-
-(def: (int-decode-loop input-size repr sign <base> <to-value> <error>)
- (-> Nat Text Int Int (-> Char (Maybe Nat)) Text (Error Int))
- (loop [idx 1
- output +0]
- (if (n/< input-size idx)
- (case (<to-value> (get-char! repr idx))
- #.None
- (#error.Failure <error>)
-
- (#.Some digit-value)
- (recur (inc idx)
- (|> output (i/* <base>) (i/+ (.int digit-value)))))
- (#error.Success (i/* sign output)))))
-
-(do-template [<struct> <base> <to-character> <to-value> <error>]
- [(structure: #export <struct> (Codec Text Int)
- (def: (encode value)
- (if (i/= +0 value)
- "+0"
- (loop [input (|> value (i// <base>) (:: Number<Int> abs))
- output (|> value (i/% <base>) (:: Number<Int> abs) .nat
- <to-character>
- maybe.assume)]
- (if (i/= +0 input)
- ("lux text concat" (int/sign!! value) output)
- (let [digit (maybe.assume (<to-character> (.nat (i/% <base> input))))]
- (recur (i// <base> input)
- ("lux text concat" digit output)))))))
-
- (def: (decode repr)
- (let [input-size ("lux text size" repr)]
- (if (n/> 1 input-size)
- (case (int/sign?? repr)
- (#.Some sign)
- (int-decode-loop input-size repr sign <base> <to-value> <error>)
-
- #.None
- (#error.Failure <error>))
- (#error.Failure <error>)))))]
-
- [Binary@Codec<Text,Int> +2 binary-character binary-value "Invalid binary syntax for Int: "]
- [Octal@Codec<Text,Int> +8 octal-character octal-value "Invalid octal syntax for Int: "]
- [_ +10 decimal-character decimal-value "Invalid syntax for Int: "]
- [Hex@Codec<Text,Int> +16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Int: "]
- )
-
-(def: (de-prefix input)
- (-> Text Text)
- ("lux text clip" input 1 ("lux text size" input)))
-
-(do-template [<struct> <nat> <char-bit-size> <error>]
- [(with-expansions [<error-output> (as-is (#error.Failure ("lux text concat" <error> repr)))]
- (structure: #export <struct> (Codec Text Rev)
- (def: (encode value)
- (let [raw-output (de-prefix (:: <nat> encode (:coerce Nat value)))
- max-num-chars (n// <char-bit-size> 64)
- raw-size ("lux text size" raw-output)
- zero-padding (loop [zeroes-left (n/- raw-size max-num-chars)
- output ""]
- (if (n/= 0 zeroes-left)
- output
- (recur (dec zeroes-left)
- ("lux text concat" "0" output))))
- padded-output ("lux text concat" zero-padding raw-output)]
- ("lux text concat" "." padded-output)))
-
- (def: (decode repr)
- (let [repr-size ("lux text size" repr)]
- (if (n/>= 2 repr-size)
- (case ("lux text char" repr 0)
- (^ (char "."))
- (case (:: <nat> decode (de-prefix repr))
- (#error.Success output)
- (#error.Success (:coerce Rev output))
-
- _
- <error-output>)
-
- _
- <error-output>)
- <error-output>)))))]
-
- [Binary@Codec<Text,Rev> Binary@Codec<Text,Nat> 1 "Invalid binary syntax: "]
- [Octal@Codec<Text,Rev> Octal@Codec<Text,Nat> 3 "Invalid octal syntax: "]
- [Hex@Codec<Text,Rev> Hex@Codec<Text,Nat> 4 "Invalid hexadecimal syntax: "]
- )
-
-(do-template [<struct> <int> <base> <char-set> <error>]
- [(structure: #export <struct> (Codec Text Frac)
- (def: (encode value)
- (let [whole (frac-to-int value)
- whole-part (:: <int> encode whole)
- decimal (:: Number<Frac> abs (f/% +1.0 value))
- decimal-part (if (f/= +0.0 decimal)
- ".0"
- (loop [dec-left decimal
- output ""]
- (if (f/= +0.0 dec-left)
- ("lux text concat" "." output)
- (let [shifted (f/* <base> dec-left)
- digit-idx (|> shifted (f/% <base>) frac-to-int .nat)]
- (recur (f/% +1.0 shifted)
- ("lux text concat" output ("lux text clip" <char-set> digit-idx (inc digit-idx))))))))]
- ("lux text concat" whole-part decimal-part)))
-
- (def: (decode repr)
- (case ("lux text index" repr "." 0)
- (#.Some split-index)
- (let [whole-part ("lux text clip" repr 0 split-index)
- decimal-part ("lux text clip" repr (inc split-index) ("lux text size" repr))]
- (case [(:: <int> decode whole-part)
- (:: <int> decode decimal-part)]
- (^multi [(#error.Success whole) (#error.Success decimal)]
- (i/>= +0 decimal))
- (let [sign (if (i/< +0 whole)
- -1.0
- +1.0)
- div-power (loop [muls-left ("lux text size" decimal-part)
- output +1.0]
- (if (n/= 0 muls-left)
- output
- (recur (dec muls-left)
- (f/* <base> output))))
- adjusted-decimal (|> decimal int-to-frac (f// div-power))
- dec-rev (case (:: Hex@Codec<Text,Rev> decode ("lux text concat" "." decimal-part))
- (#error.Success dec-rev)
- dec-rev
-
- (#error.Failure error)
- (error! error))]
- (#error.Success (f/+ (int-to-frac whole)
- (f/* sign adjusted-decimal))))
-
- _
- (#error.Failure ("lux text concat" <error> repr))))
-
- _
- (#error.Failure ("lux text concat" <error> repr)))))]
-
- [Binary@Codec<Text,Frac> Binary@Codec<Text,Int> +2.0 "01" "Invalid binary syntax: "]
- )
-
-(def: (segment-digits chunk-size digits)
- (-> Nat Text (List Text))
- (case digits
- ""
- (list)
-
- _
- (let [num-digits ("lux text size" digits)]
- (if (n/<= chunk-size num-digits)
- (list digits)
- (let [boundary (n/- chunk-size num-digits)
- chunk ("lux text clip" digits boundary num-digits)
- remaining ("lux text clip" digits 0 boundary)]
- (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"
- (^or "a" "A") "1010"
- (^or "b" "B") "1011"
- (^or "c" "C") "1100"
- (^or "d" "D") "1101"
- (^or "e" "E") "1110"
- (^or "f" "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 text concat" x (re-join-chunks xs'))))
-
-(do-template [<from> <from-translator> <to> <to-translator> <base-bits>]
- [(def: (<from> on-left? input)
- (-> Bit Text Text)
- (let [max-num-chars (n// <base-bits> 64)
- input-size ("lux 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 (dec zeroes-left)
- ("lux text concat" "0" output))))))
- padded-input (if on-left?
- ("lux text concat" zero-padding input)
- ("lux text concat" input zero-padding))]
- (|> padded-input
- (segment-digits <base-bits>)
- (map <from-translator>)
- re-join-chunks)))
-
- (def: <to>
- (-> Text Text)
- (|>> (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>]
- [(structure: #export <struct> (Codec Text Frac)
- (def: (encode value)
- (let [sign (:: Number<Frac> signum value)
- raw-bin (:: Binary@Codec<Text,Frac> encode value)
- dot-idx (maybe.assume ("lux text index" raw-bin "." 0))
- whole-part ("lux text clip" raw-bin
- (if (f/= -1.0 sign) 1 0)
- dot-idx)
- decimal-part ("lux text clip" raw-bin (inc dot-idx) ("lux text size" raw-bin))
- hex-output (|> (<from> #0 decimal-part)
- ("lux text concat" ".")
- ("lux text concat" (<from> #1 whole-part))
- ("lux text concat" (if (f/= -1.0 sign) "-" "")))]
- hex-output))
-
- (def: (decode repr)
- (let [sign (case ("lux text index" repr "-" 0)
- (#.Some 0)
- -1.0
-
- _
- +1.0)]
- (case ("lux text index" repr "." 0)
- (#.Some split-index)
- (let [whole-part ("lux text clip" repr 1 split-index)
- decimal-part ("lux text clip" repr (inc split-index) ("lux text size" repr))
- as-binary (|> (<to> decimal-part)
- ("lux text concat" ".")
- ("lux text concat" (<to> whole-part))
- ("lux text concat" (if (f/= -1.0 sign) "-" "+")))]
- (case (:: Binary@Codec<Text,Frac> decode as-binary)
- (#error.Failure _)
- (#error.Failure ("lux text concat" <error> repr))
-
- output
- output))
-
- _
- (#error.Failure ("lux text concat" <error> repr))))))]
-
- [Octal@Codec<Text,Frac> "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary]
- [Hex@Codec<Text,Frac> "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary]
- )
+ ["/." nat]
+ ["/." int]
+ ["/." rev]
+ ["/." frac]])
(macro: (encoding-doc tokens state)
(case tokens
@@ -725,301 +70,13 @@
_
(#error.Failure <error>)))]
- [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> Binary@Codec<Text,Rev> Binary@Codec<Text,Frac>
+ [bin /nat.binary /int.binary /rev.binary /frac.binary
"Invalid binary syntax."
(encoding-doc "binary" (bin "+11001001") (bin "+11_00_10_01"))]
- [oct Octal@Codec<Text,Nat> Octal@Codec<Text,Int> Octal@Codec<Text,Rev> Octal@Codec<Text,Frac>
+ [oct /nat.octal /int.octal /rev.octal /frac.octal
"Invalid octal syntax."
(encoding-doc "octal" (oct "+615243") (oct "+615_243"))]
- [hex Hex@Codec<Text,Nat> Hex@Codec<Text,Int> Hex@Codec<Text,Rev> Hex@Codec<Text,Frac>
+ [hex /nat.hex /int.hex /rev.hex /frac.hex
"Invalid hexadecimal syntax."
(encoding-doc "hexadecimal" (hex "deadBEEF") (hex "dead_BEEF"))]
)
-
-## The following code allows one to encode/decode Rev numbers as text.
-## This is not a simple algorithm, and it requires subverting the Rev
-## abstraction a bit.
-## It takes into account the fact that Rev numbers are represented by
-## Lux as 64-bit integers.
-## A valid way to model them is as Lux's Nat type.
-## This is a somewhat hackish way to do things, but it allows one to
-## write the encoding/decoding algorithm once, in pure Lux, rather
-## than having to implement it on the compiler for every platform
-## targeted by Lux.
-(type: Digits (Array Nat))
-
-(def: (make-digits _)
- (-> Any Digits)
- (array.new i64.width))
-
-(def: (digits-get idx digits)
- (-> Nat Digits Nat)
- (|> digits (array.read idx) (maybe.default 0)))
-
-(def: digits-put
- (-> Nat Nat Digits Digits)
- array.write)
-
-(def: (prepend left right)
- (-> Text Text Text)
- ("lux text concat" left right))
-
-(def: (digits-times-5! idx output)
- (-> Nat Digits Digits)
- (loop [idx idx
- carry 0
- output output]
- (if (i/>= +0 (:coerce Int idx))
- (let [raw (|> (digits-get idx output)
- (n/* 5)
- (n/+ carry))]
- (recur (dec idx)
- (n// 10 raw)
- (digits-put idx (n/% 10 raw) output)))
- output)))
-
-(def: (digits-power power)
- (-> Nat Digits)
- (loop [times power
- output (|> (make-digits [])
- (digits-put power 1))]
- (if (i/>= +0 (:coerce Int times))
- (recur (dec times)
- (digits-times-5! power output))
- output)))
-
-(def: (digits-to-text digits)
- (-> Digits Text)
- (loop [idx (dec i64.width)
- all-zeroes? #1
- output ""]
- (if (i/>= +0 (:coerce Int idx))
- (let [digit (digits-get idx digits)]
- (if (and (n/= 0 digit)
- all-zeroes?)
- (recur (dec idx) #1 output)
- (recur (dec idx)
- #0
- ("lux text concat"
- (:: Codec<Text,Int> encode (:coerce Int digit))
- output))))
- (if all-zeroes?
- "0"
- output))))
-
-(def: (digits-add param subject)
- (-> Digits Digits Digits)
- (loop [idx (dec i64.width)
- carry 0
- output (make-digits [])]
- (if (i/>= +0 (:coerce Int idx))
- (let [raw ($_ n/+
- carry
- (digits-get idx param)
- (digits-get idx subject))]
- (recur (dec idx)
- (n// 10 raw)
- (digits-put idx (n/% 10 raw) output)))
- output)))
-
-(def: (text-to-digits input)
- (-> Text (Maybe Digits))
- (let [length ("lux text size" input)]
- (if (n/<= i64.width length)
- (loop [idx 0
- output (make-digits [])]
- (if (n/< length idx)
- (case ("lux text index" "+0123456789" ("lux text clip" input idx (inc idx)) 0)
- #.None
- #.None
-
- (#.Some digit)
- (recur (inc idx)
- (digits-put idx digit output)))
- (#.Some output)))
- #.None)))
-
-(def: (digits-lt param subject)
- (-> Digits Digits Bit)
- (loop [idx 0]
- (and (n/< i64.width idx)
- (let [pd (digits-get idx param)
- sd (digits-get idx subject)]
- (if (n/= pd sd)
- (recur (inc idx))
- (n/< pd sd))))))
-
-(def: (digits-sub-once! idx param subject)
- (-> Nat Nat Digits Digits)
- (let [sd (digits-get idx subject)]
- (if (n/>= param sd)
- (digits-put idx (n/- param sd) subject)
- (let [diff (|> sd
- (n/+ 10)
- (n/- param))]
- (|> subject
- (digits-put idx diff)
- (digits-sub-once! (dec idx) 1))))))
-
-(def: (digits-sub! param subject)
- (-> Digits Digits Digits)
- (loop [idx (dec i64.width)
- output subject]
- (if (i/>= +0 (.int idx))
- (recur (dec idx)
- (digits-sub-once! idx (digits-get idx param) output))
- output)))
-
-(structure: #export _ (Codec Text Rev)
- (def: (encode input)
- (let [input (:coerce Nat input)
- last-idx (dec i64.width)]
- (if (n/= 0 input)
- ".0"
- (loop [idx last-idx
- digits (make-digits [])]
- (if (i/>= +0 (:coerce Int idx))
- (if (i64.set? idx input)
- (let [digits' (digits-add (digits-power (n/- idx last-idx))
- digits)]
- (recur (dec idx)
- digits'))
- (recur (dec idx)
- digits))
- ("lux text concat" "." (digits-to-text digits))
- )))))
-
- (def: (decode input)
- (let [length ("lux text size" input)
- dotted? (case ("lux text index" input "." 0)
- (#.Some 0)
- #1
-
- _
- #0)]
- (if (and dotted?
- (n/<= (inc i64.width) length))
- (case (text-to-digits ("lux text clip" input 1 length))
- (#.Some digits)
- (loop [digits digits
- idx 0
- output 0]
- (if (n/< i64.width idx)
- (let [power (digits-power idx)]
- (if (digits-lt power digits)
- ## Skip power
- (recur digits (inc idx) output)
- (recur (digits-sub! power digits)
- (inc idx)
- (i64.set (n/- idx (dec i64.width)) output))))
- (#error.Success (:coerce Rev output))))
-
- #.None
- (#error.Failure ("lux text concat" "Wrong syntax for Rev: " input)))
- (#error.Failure ("lux text concat" "Wrong syntax for Rev: " input))))
- ))
-
-(def: (log2 input)
- (-> Frac Frac)
- (f// (math.log +2.0)
- (math.log input)))
-
-(def: double-bias Nat 1023)
-
-(def: mantissa-size Nat 52)
-(def: exponent-size Nat 11)
-
-(def: #export (frac-to-bits input)
- (-> Frac I64)
- (i64 (cond (not-a-number? input)
- (hex "7FF7FFFFFFFFFFFF")
-
- (f/= positive-infinity input)
- (hex "7FF0000000000000")
-
- (f/= negative-infinity input)
- (hex "FFF0000000000000")
-
- (f/= +0.0 input)
- (let [reciprocal (f// input +1.0)]
- (if (f/= positive-infinity reciprocal)
- ## Positive zero
- (hex "0000000000000000")
- ## Negative zero
- (hex "8000000000000000")))
-
- ## else
- (let [sign (:: Number<Frac> signum input)
- input (:: Number<Frac> abs input)
- exponent (math.floor (log2 input))
- exponent-mask (|> 1 (i64.left-shift exponent-size) dec)
- mantissa (|> input
- ## Normalize
- (f// (math.pow exponent +2.0))
- ## Make it int-equivalent
- (f/* (math.pow +52.0 +2.0)))
- sign-bit (if (f/= -1.0 sign) 1 0)
- exponent-bits (|> exponent frac-to-int .nat (n/+ double-bias) (i64.and exponent-mask))
- mantissa-bits (|> mantissa frac-to-int .nat)]
- ($_ i64.or
- (i64.left-shift 63 sign-bit)
- (i64.left-shift mantissa-size exponent-bits)
- (i64.clear mantissa-size mantissa-bits)))
- )))
-
-(do-template [<getter> <mask> <size> <offset>]
- [(def: <mask> (|> 1 (i64.left-shift <size>) dec (i64.left-shift <offset>)))
- (def: (<getter> input)
- (-> (I64 Any) I64)
- (|> input (i64.and <mask>) (i64.logical-right-shift <offset>) i64))]
-
- [mantissa mantissa-mask mantissa-size 0]
- [exponent exponent-mask exponent-size mantissa-size]
- [sign sign-mask 1 (n/+ exponent-size mantissa-size)]
- )
-
-(def: #export (bits-to-frac input)
- (-> (I64 Any) Frac)
- (let [S (sign input)
- E (exponent input)
- M (mantissa input)]
- (cond (n/= (hex "7FF") E)
- (if (n/= 0 M)
- (if (n/= 0 S)
- positive-infinity
- negative-infinity)
- not-a-number)
-
- (and (n/= 0 E) (n/= 0 M))
- (if (n/= 0 S)
- +0.0
- (f/* -1.0 +0.0))
-
- ## else
- (let [normalized (|> M (i64.set mantissa-size)
- .int int-to-frac
- (f// (math.pow +52.0 +2.0)))
- power (math.pow (|> E (n/- double-bias)
- .int int-to-frac)
- +2.0)
- shifted (f/* power
- normalized)]
- (if (n/= 0 S)
- shifted
- (f/* -1.0 shifted))))))
-
-(structure: #export _ (Hash Nat)
- (def: eq Equivalence<Nat>)
- (def: hash function.identity))
-
-(structure: #export _ (Hash Int)
- (def: eq Equivalence<Int>)
- (def: hash .nat))
-
-(structure: #export _ (Hash Frac)
- (def: eq Equivalence<Frac>)
- (def: hash frac-to-bits))
-
-(structure: #export _ (Hash Rev)
- (def: eq Equivalence<Rev>)
- (def: hash (|>> (:coerce Nat))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-13 11:44:23 +0000