aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/data/number
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/data/number')
-rw-r--r--stdlib/source/lux/data/number/complex.lux17
-rw-r--r--stdlib/source/lux/data/number/frac.lux441
-rw-r--r--stdlib/source/lux/data/number/int.lux134
-rw-r--r--stdlib/source/lux/data/number/nat.lux211
-rw-r--r--stdlib/source/lux/data/number/ratio.lux21
-rw-r--r--stdlib/source/lux/data/number/rev.lux291
6 files changed, 1097 insertions, 18 deletions
diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux
index aeefa03d6..a7993dcaf 100644
--- a/stdlib/source/lux/data/number/complex.lux
+++ b/stdlib/source/lux/data/number/complex.lux
@@ -5,14 +5,15 @@
[equivalence (#+ Equivalence)]
number
codec
- ["M" monad (#+ do Monad)]
+ ["M" monad (#+ Monad do)]
["p" parser]]
[data
["." maybe]
- ["." number ("frac/." Number<Frac>)]
- [text ("text/." Monoid<Text>)]
+ [number
+ ["." frac ("frac/." number)]]
+ [text ("text/." monoid)]
[collection
- ["." list ("list/." Functor<List>)]]]
+ ["." list ("list/." functor)]]]
["." macro
["." code]
["s" syntax (#+ syntax: Syntax)]]])
@@ -37,8 +38,8 @@
(def: #export zero Complex (complex +0.0 +0.0))
(def: #export (not-a-number? complex)
- (or (number.not-a-number? (get@ #real complex))
- (number.not-a-number? (get@ #imaginary complex))))
+ (or (frac.not-a-number? (get@ #real complex))
+ (frac.not-a-number? (get@ #imaginary complex))))
(def: #export (= param input)
(-> Complex Complex Bit)
@@ -59,7 +60,7 @@
[- f/-]
)
-(structure: #export _ (Equivalence Complex)
+(structure: #export equivalence (Equivalence Complex)
(def: = ..=))
(def: #export negate
@@ -190,7 +191,7 @@
(frac/abs real))))
))))
-(structure: #export _ (Number Complex)
+(structure: #export number (Number Complex)
(def: + ..+)
(def: - ..-)
(def: * ..*)
diff --git a/stdlib/source/lux/data/number/frac.lux b/stdlib/source/lux/data/number/frac.lux
new file mode 100644
index 000000000..a2bd659b0
--- /dev/null
+++ b/stdlib/source/lux/data/number/frac.lux
@@ -0,0 +1,441 @@
+(.module:
+ [lux #*
+ [control
+ [hash (#+ Hash)]
+ [number (#+ Number)]
+ [enum (#+ Enum)]
+ [interval (#+ Interval)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ ["." order (#+ Order)]
+ [codec (#+ Codec)]]
+ [data
+ ["." error (#+ Error)]
+ ["." maybe]]
+ ["." math]]
+ [//
+ ["//." i64]
+ ["//." nat]
+ ["//." int]
+ ["//." rev]])
+
+(structure: #export equivalence (Equivalence Frac)
+ (def: = f/=))
+
+(structure: #export order (Order Frac)
+ (def: &equivalence ..equivalence)
+ (def: < f/<)
+ (def: <= f/<=)
+ (def: > f/>)
+ (def: >= f/>=))
+
+(structure: #export enum (Enum Frac)
+ (def: &order ..order)
+ (def: succ (f/+ ("lux frac smallest")))
+ (def: pred (f/- ("lux frac smallest"))))
+
+(structure: #export interval (Interval Frac)
+ (def: &enum ..enum)
+ (def: top ("lux frac max"))
+ (def: bottom ("lux frac min")))
+
+(structure: #export number (Number Frac)
+ (def: + f/+)
+ (def: - f/-)
+ (def: * f/*)
+ (def: / f//)
+ (def: % f/%)
+ (def: negate (f/* -1.0))
+ (def: (abs x)
+ (if (f/< +0.0 x)
+ (f/* -1.0 x)
+ x))
+ (def: (signum x)
+ (cond (f/= +0.0 x) +0.0
+ (f/< +0.0 x) -1.0
+ ## else
+ +1.0))
+ )
+
+(do-template [<name> <compose> <identity>]
+ [(structure: #export <name> (Monoid Frac)
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [addition f/+ +0.0]
+ [multiplication f/* +1.0]
+ [maximum f/max (:: ..interval bottom)]
+ [minimum f/min (:: ..interval top)]
+ )
+
+(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))))
+
+(structure: #export decimal (Codec Text Frac)
+ (def: (encode x)
+ ("lux frac encode" [x]))
+
+ (def: (decode input)
+ (case ("lux frac decode" [input])
+ (#.Some value)
+ (#error.Success value)
+
+ #.None
+ (#error.Failure "Could not decode Frac"))))
+
+(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 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 (:: //rev.hex 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 //int.binary +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 signum value)
+ raw-bin (:: ..binary 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 decode as-binary)
+ (#error.Failure _)
+ (#error.Failure ("lux text concat" <error> repr))
+
+ output
+ output))
+
+ _
+ (#error.Failure ("lux text concat" <error> repr))))))]
+
+ [octal "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary]
+ [hex "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary]
+ )
+
+(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)
+
+(do-template [<hex> <name>]
+ [(def: <name> (|> <hex> (:: //nat.hex decode) error.assume .i64))]
+
+ ["7FF7FFFFFFFFFFFF" not-a-number-bits]
+ ["7FF0000000000000" positive-infinity-bits]
+ ["FFF0000000000000" negative-infinity-bits]
+ ["0000000000000000" positive-zero-bits]
+ ["8000000000000000" negative-zero-bits]
+ ["7FF" special-exponent-bits]
+ )
+
+(def: #export (frac-to-bits input)
+ (-> Frac I64)
+ (i64 (cond (not-a-number? input)
+ ..not-a-number-bits
+
+ (f/= positive-infinity input)
+ ..positive-infinity-bits
+
+ (f/= negative-infinity input)
+ ..negative-infinity-bits
+
+ (f/= +0.0 input)
+ (let [reciprocal (f// input +1.0)]
+ (if (f/= positive-infinity reciprocal)
+ ## Positive zero
+ ..positive-zero-bits
+ ## Negative zero
+ ..negative-zero-bits))
+
+ ## else
+ (let [sign (:: ..number signum input)
+ input (:: ..number 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/= ..special-exponent-bits 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 (Hash Frac)
+ (def: &equivalence ..equivalence)
+ (def: hash frac-to-bits))
diff --git a/stdlib/source/lux/data/number/int.lux b/stdlib/source/lux/data/number/int.lux
new file mode 100644
index 000000000..1047b68f9
--- /dev/null
+++ b/stdlib/source/lux/data/number/int.lux
@@ -0,0 +1,134 @@
+(.module:
+ [lux #*
+ [control
+ [hash (#+ Hash)]
+ [number (#+ Number)]
+ [enum (#+ Enum)]
+ [interval (#+ Interval)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ ["." order (#+ Order)]
+ [codec (#+ Codec)]]
+ [data
+ ["." error (#+ Error)]
+ ["." maybe]
+ [text (#+ Char)]]]
+ [//
+ ["." nat]])
+
+(structure: #export equivalence (Equivalence Int)
+ (def: = i/=))
+
+(structure: #export order (Order Int)
+ (def: &equivalence ..equivalence)
+ (def: < i/<)
+ (def: <= i/<=)
+ (def: > i/>)
+ (def: >= i/>=))
+
+(structure: #export enum (Enum Int)
+ (def: &order ..order)
+ (def: succ inc)
+ (def: pred dec))
+
+(structure: #export interval (Interval Int)
+ (def: &enum ..enum)
+ (def: top +9_223_372_036_854_775_807)
+ (def: bottom -9_223_372_036_854_775_808))
+
+(structure: #export number (Number Int)
+ (def: + i/+)
+ (def: - i/-)
+ (def: * i/*)
+ (def: / i//)
+ (def: % i/%)
+ (def: negate (i/* -1))
+ (def: (abs x)
+ (if (i/< +0 x)
+ (i/* -1 x)
+ x))
+ (def: (signum x)
+ (cond (i/= +0 x) +0
+ (i/< +0 x) -1
+ ## else
+ +1))
+ )
+
+(do-template [<name> <compose> <identity>]
+ [(structure: #export <name> (Monoid Int)
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [addition i/+ +0]
+ [multiplication i/* +1]
+ [maximum i/max (:: ..interval bottom)]
+ [minimum i/min (:: ..interval top)]
+ )
+
+(def: (int/sign!! value)
+ (-> Int Text)
+ (if (i/< +0 value)
+ "-"
+ "+"))
+
+(def: (int/sign?? representation)
+ (-> Text (Maybe Int))
+ (case ("lux text 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> ("lux text 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 abs))
+ output (|> value (i/% <base>) (:: ..number 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 +2 nat.binary-character nat.binary-value "Invalid binary syntax for Int: "]
+ [octal +8 nat.octal-character nat.octal-value "Invalid octal syntax for Int: "]
+ [decimal +10 nat.decimal-character nat.decimal-value "Invalid syntax for Int: "]
+ [hex +16 nat.hexadecimal-character nat.hexadecimal-value "Invalid hexadecimal syntax for Int: "]
+ )
+
+(structure: #export hash (Hash Int)
+ (def: &equivalence ..equivalence)
+ (def: hash .nat))
diff --git a/stdlib/source/lux/data/number/nat.lux b/stdlib/source/lux/data/number/nat.lux
new file mode 100644
index 000000000..9e249b207
--- /dev/null
+++ b/stdlib/source/lux/data/number/nat.lux
@@ -0,0 +1,211 @@
+(.module:
+ [lux #*
+ [control
+ [hash (#+ Hash)]
+ [number (#+ Number)]
+ [enum (#+ Enum)]
+ [interval (#+ Interval)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ [codec (#+ Codec)]
+ ["." order (#+ Order)]]
+ [data
+ ["." error (#+ Error)]
+ ["." maybe]
+ ["." text (#+ Char)]]
+ ["." function]])
+
+(structure: #export equivalence (Equivalence Nat)
+ (def: = n/=))
+
+(structure: #export order (Order Nat)
+ (def: &equivalence ..equivalence)
+ (def: < n/<)
+ (def: <= n/<=)
+ (def: > n/>)
+ (def: >= n/>=))
+
+(structure: #export enum (Enum Nat)
+ (def: &order ..order)
+ (def: succ inc)
+ (def: pred dec))
+
+(structure: #export interval (Interval Nat)
+ (def: &enum ..enum)
+ (def: top (.nat -1))
+ (def: bottom 0))
+
+(structure: #export number (Number Nat)
+ (def: + n/+)
+ (def: - n/-)
+ (def: * n/*)
+ (def: / n//)
+ (def: % n/%)
+ (def: (negate value) (n/- (:: ..interval top) value))
+ (def: abs function.identity)
+ (def: (signum x)
+ (case x
+ 0 0
+ _ 1))
+ )
+
+(do-template [<name> <compose> <identity>]
+ [(structure: #export <name> (Monoid Nat)
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [addition n/+ 0]
+ [multiplication n/* 1]
+ [maximum n/max (:: ..interval bottom)]
+ [minimum n/min (:: ..interval top)]
+ )
+
+(def: #export (binary-character value)
+ (-> Nat (Maybe Text))
+ (case value
+ 0 (#.Some "0")
+ 1 (#.Some "1")
+ _ #.None))
+
+(def: #export (binary-value digit)
+ (-> Char (Maybe Nat))
+ (case digit
+ (^ (char "0")) (#.Some 0)
+ (^ (char "1")) (#.Some 1)
+ _ #.None))
+
+(def: #export (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: #export (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: #export (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: #export (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: #export (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: #export (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> ("lux text 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 2 binary-character binary-value "Invalid binary syntax for Nat: "]
+ [octal 8 octal-character octal-value "Invalid octal syntax for Nat: "]
+ [decimal 10 decimal-character decimal-value "Invalid syntax for Nat: "]
+ [hex 16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "]
+ )
+
+(structure: #export hash (Hash Nat)
+ (def: &equivalence ..equivalence)
+ (def: hash function.identity))
diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux
index 1447040e6..773baef15 100644
--- a/stdlib/source/lux/data/number/ratio.lux
+++ b/stdlib/source/lux/data/number/ratio.lux
@@ -1,4 +1,4 @@
-(.module: {#.doc "Rational arithmetic."}
+(.module: {#.doc "Rational numbers."}
[lux #*
[control
[equivalence (#+ Equivalence)]
@@ -11,14 +11,15 @@
["." error]
["." product]
["." maybe]
- [number ("nat/." Codec<Text,Nat>)]
- ["." text ("text/." Monoid<Text>)
+ [number
+ [nat ("nat/." decimal)]]
+ ["." text ("text/." monoid)
format]]
["." function]
["." math]
["." macro
["." code]
- ["s" syntax (#+ syntax: Syntax)]]])
+ ["s" syntax (#+ Syntax syntax:)]]])
(type: #export Ratio
{#numerator Nat
@@ -103,17 +104,17 @@
[max >]
)
-(structure: #export _ (Equivalence Ratio)
+(structure: #export equivalence (Equivalence Ratio)
(def: = ..=))
-(structure: #export _ (Order Ratio)
- (def: eq Equivalence<Ratio>)
+(structure: #export order (Order Ratio)
+ (def: &equivalence ..equivalence)
(def: < ..<)
(def: <= ..<=)
(def: > ..>)
(def: >= ..>=))
-(structure: #export _ (Number Ratio)
+(structure: #export number (Number Ratio)
(def: + ..+)
(def: - ..-)
(def: * ..*)
@@ -133,14 +134,14 @@
(-> Nat Text)
(|>> nat/encode (text.split 1) maybe.assume product.right))
-(structure: #export _ (Codec Text Ratio)
+(structure: #export codec (Codec Text Ratio)
(def: (encode (^slots [#numerator #denominator]))
($_ text/compose (part-encode numerator) separator (part-encode denominator)))
(def: (decode input)
(case (text.split-with separator input)
(#.Some [num denom])
- (do error.Monad<Error>
+ (do error.monad
[numerator (nat/decode num)
denominator (nat/decode denom)]
(wrap (normalize {#numerator numerator
diff --git a/stdlib/source/lux/data/number/rev.lux b/stdlib/source/lux/data/number/rev.lux
new file mode 100644
index 000000000..dbfb5a93a
--- /dev/null
+++ b/stdlib/source/lux/data/number/rev.lux
@@ -0,0 +1,291 @@
+(.module:
+ [lux #*
+ [control
+ [hash (#+ Hash)]
+ [number (#+ Number)]
+ [enum (#+ Enum)]
+ [interval (#+ Interval)]
+ [monoid (#+ Monoid)]
+ [equivalence (#+ Equivalence)]
+ ["." order (#+ Order)]
+ [codec (#+ Codec)]]
+ [data
+ ["." error (#+ Error)]
+ ["." maybe]
+ [collection
+ ["." array (#+ Array)]]]
+ ["." function]]
+ [//
+ ["//." i64]
+ ["//." nat]
+ ["//." int]])
+
+(structure: #export equivalence (Equivalence Rev)
+ (def: = r/=))
+
+(structure: #export order (Order Rev)
+ (def: &equivalence ..equivalence)
+ (def: < r/<)
+ (def: <= r/<=)
+ (def: > r/>)
+ (def: >= r/>=))
+
+(structure: #export enum (Enum Rev)
+ (def: &order ..order)
+ (def: succ inc)
+ (def: pred dec))
+
+(structure: #export interval (Interval Rev)
+ (def: &enum ..enum)
+ (def: top (.rev -1))
+ (def: bottom (.rev 0)))
+
+(structure: #export number (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> <compose> <identity>]
+ [(structure: #export <name> (Monoid Rev)
+ (def: identity <identity>)
+ (def: compose <compose>))]
+
+ [addition r/+ (:: interval bottom)]
+ [multiplication r/* (:: interval top)]
+ [maximum r/max (:: interval bottom)]
+ [minimum r/min (:: interval top)]
+ )
+
+(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 //nat.binary 1 "Invalid binary syntax: "]
+ [octal //nat.octal 3 "Invalid octal syntax: "]
+ [hex //nat.hex 4 "Invalid hexadecimal syntax: "]
+ )
+
+## 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 (.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 (.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 (.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"
+ (:: //int.decimal encode (.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 (.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 decimal (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 (.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))))
+ ))
+
+(structure: #export hash (Hash Rev)
+ (def: &equivalence ..equivalence)
+ (def: hash .nat))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-18 03:03:08 +0000