aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser/proc/common.clj2
-rw-r--r--luxc/src/lux/compiler/js/proc/common.clj7
-rw-r--r--luxc/src/lux/compiler/jvm/proc/common.clj11
-rw-r--r--stdlib/source/lux/data/bit.lux2
-rw-r--r--stdlib/source/lux/data/format/json.lux2
-rw-r--r--stdlib/source/lux/data/number.lux178
-rw-r--r--stdlib/source/lux/math.lux28
-rw-r--r--stdlib/test/test/lux/data/number.lux7
8 files changed, 148 insertions, 89 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj
index 29797224f..a0430feb7 100644
--- a/luxc/src/lux/analyser/proc/common.clj
+++ b/luxc/src/lux/analyser/proc/common.clj
@@ -299,7 +299,6 @@
^:private analyse-int-to-real &type/Int &type/Real ["int" "to-real"]
^:private analyse-real-to-int &type/Real &type/Int ["real" "to-int"]
- ^:private analyse-real-hash &type/Real &type/Nat ["real" "hash"]
^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"]
@@ -597,7 +596,6 @@
"negative-infinity" (analyse-real-negative-infinity analyse exo-type ?values)
"to-deg" (analyse-real-to-deg analyse exo-type ?values)
"to-int" (analyse-real-to-int analyse exo-type ?values)
- "hash" (analyse-real-hash analyse exo-type ?values)
)
"char"
diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj
index 2f872676e..871f5e15b 100644
--- a/luxc/src/lux/compiler/js/proc/common.clj
+++ b/luxc/src/lux/compiler/js/proc/common.clj
@@ -151,12 +151,6 @@
^:private compile-real-decode "decodeReal"
)
-(defn ^:private compile-real-hash [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- =x (compile ?x)]
- (return (str "LuxRT$textHash(''+" =x ")"))
- ))
-
(do-template [<name> <compiler> <value>]
(defn <name> [compile ?values special-args]
(|do [:let [(&/$Nil) ?values]]
@@ -549,7 +543,6 @@
"negative-infinity" (compile-real-negative-infinity compile ?values special-args)
"to-deg" (compile-real-to-deg compile ?values special-args)
"to-int" (compile-real-to-int compile ?values special-args)
- "hash" (compile-real-hash compile ?values special-args)
)
"char"
diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj
index 1fe49d227..821fcc619 100644
--- a/luxc/src/lux/compiler/jvm/proc/common.clj
+++ b/luxc/src/lux/compiler/jvm/proc/common.clj
@@ -299,16 +299,6 @@
^:private compile-char-lt Opcodes/IF_ICMPLT &&/unwrap-char
)
-(defn ^:private compile-real-hash [compile ?values special-args]
- (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?input)
- :let [_ (doto *writer*
- &&/unwrap-double
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "doubleToRawLongBits" "(D)J")
- &&/wrap-long)]]
- (return nil)))
-
(do-template [<name> <cmp-output>]
(defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
@@ -966,7 +956,6 @@
"%" (compile-real-rem compile ?values special-args)
"=" (compile-real-eq compile ?values special-args)
"<" (compile-real-lt compile ?values special-args)
- "hash" (compile-real-hash compile ?values special-args)
"smallest-value" (compile-real-smallest-value compile ?values special-args)
"max-value" (compile-real-max-value compile ?values special-args)
"min-value" (compile-real-min-value compile ?values special-args)
diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux
index 29b01e370..bb5b4b7bd 100644
--- a/stdlib/source/lux/data/bit.lux
+++ b/stdlib/source/lux/data/bit.lux
@@ -40,7 +40,7 @@
(-> Nat Nat Nat)
(<op> (shift-left idx +1) input))]
- [set ;;or "Set bit at given index."]
+ [set ;;or "Set bit at given index."]
[flip ;;xor "Flip bit at given index."]
)
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 0919f305f..1cc3000c3 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -11,7 +11,7 @@
[text "Text/" Eq<Text> Monoid<Text>]
text/format
(text [lexer #+ Lexer Monad<Lexer>])
- [number #* "Real/" Codec<Text,Real>]
+ [number "Real/" Codec<Text,Real>]
maybe
[char "Char/" Eq<Char> Codec<Text,Char>]
["R" result #- fail]
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux
index ad37a01ca..eee553ac9 100644
--- a/stdlib/source/lux/data/number.lux
+++ b/stdlib/source/lux/data/number.lux
@@ -8,7 +8,8 @@
enum
interval
codec)
- (data ["R" result])))
+ (data ["R" result]
+ [bit])))
(def: (clean-separators input)
(-> Text Text)
@@ -151,6 +152,12 @@
(-> Real Bool)
(not (r.= number number)))
+(def: #export (real? value)
+ (-> Real Bool)
+ (not (or (not-a-number? value)
+ (r.= positive-infinity value)
+ (r.= negative-infinity value))))
+
(do-template [<type> <encoder> <decoder> <error>]
[(struct: #export _ (Codec Text <type>)
(def: (encode x)
@@ -167,24 +174,6 @@
[Real ["real" "encode"] ["real" "decode"] "Could not decode Real"]
)
-(struct: #export _ (Hash Nat)
- (def: eq Eq<Nat>)
- (def: hash id))
-
-(struct: #export _ (Hash Int)
- (def: eq Eq<Int>)
- (def: hash int-to-nat))
-
-(struct: #export _ (Hash Real)
- (def: eq Eq<Real>)
-
- (def: (hash value)
- (_lux_proc ["real" "hash"] [value])))
-
-(struct: #export _ (Hash Deg)
- (def: eq Eq<Deg>)
- (def: hash (|>. (:! Nat))))
-
## [Values & Syntax]
(do-template [<struct> <base> <char-set> <error>]
[(struct: #export <struct> (Codec Text Nat)
@@ -616,33 +605,11 @@
## write the encoding/decoding algorithm once, in pure Lux, rather
## than having to implement it on the compiler for every platform
## targeted by Lux.
-(def: deg-bits Nat +64)
-
-(def: (bit-shift-left param subject)
- (-> Nat Nat Nat)
- (_lux_proc ["bit" "shift-left"] [subject param]))
-
-(def: (bit-and param subject)
- (-> Nat Nat Nat)
- (_lux_proc ["bit" "and"] [subject param]))
-
-(def: (bit-or param subject)
- (-> Nat Nat Nat)
- (_lux_proc ["bit" "or"] [subject param]))
-
-(def: (bit-set? idx input)
- (-> Nat Nat Bool)
- (|> input (bit-and (bit-shift-left idx +1)) (n.= +0) ;not))
-
-(def: (bit-set idx input)
- (-> Nat Nat Nat)
- (bit-or (bit-shift-left idx +1) input))
-
(type: Digits (#;Host "#Array" (#;Cons Nat #;Nil)))
(def: (make-digits _)
(-> Top Digits)
- (_lux_proc ["array" "new"] [deg-bits]))
+ (_lux_proc ["array" "new"] [bit;width]))
(def: (digits-get idx digits)
(-> Nat Digits Nat)
@@ -682,7 +649,7 @@
(def: (digits-to-text digits)
(-> Digits Text)
- (loop [idx (n.dec deg-bits)
+ (loop [idx (n.dec bit;width)
all-zeroes? true
output ""]
(if (i.>= 0 (:! Int idx))
@@ -701,7 +668,7 @@
(def: (digits-add param subject)
(-> Digits Digits Digits)
- (loop [idx (n.dec deg-bits)
+ (loop [idx (n.dec bit;width)
carry +0
output (make-digits [])]
(if (i.>= 0 (:! Int idx))
@@ -717,7 +684,7 @@
(def: (text-to-digits input)
(-> Text (Maybe Digits))
(let [length (_lux_proc ["text" "size"] [input])]
- (if (n.<= deg-bits length)
+ (if (n.<= bit;width length)
(loop [idx +0
output (make-digits [])]
(if (n.< length idx)
@@ -738,7 +705,7 @@
(def: (digits-lt param subject)
(-> Digits Digits Bool)
(loop [idx +0]
- (and (n.< deg-bits idx)
+ (and (n.< bit;width idx)
(let [pd (digits-get idx param)
sd (digits-get idx subject)]
(if (n.= pd sd)
@@ -759,7 +726,7 @@
(def: (digits-sub! param subject)
(-> Digits Digits Digits)
- (loop [idx (n.dec deg-bits)
+ (loop [idx (n.dec bit;width)
output subject]
(if (i.>= 0 (nat-to-int idx))
(recur (n.dec idx)
@@ -769,13 +736,13 @@
(struct: #export _ (Codec Text Deg)
(def: (encode input)
(let [input (:! Nat input)
- last-idx (n.dec deg-bits)]
+ last-idx (n.dec bit;width)]
(if (n.= +0 input)
".0"
(loop [idx last-idx
digits (make-digits [])]
(if (i.>= 0 (:! Int idx))
- (if (bit-set? idx input)
+ (if (bit;set? idx input)
(let [digits' (digits-add (digits-power (n.- idx last-idx))
digits)]
(recur (n.dec idx)
@@ -794,7 +761,7 @@
_
false)]
(if (and dotted?
- (n.<= (n.inc deg-bits) length))
+ (n.<= (n.inc bit;width) length))
(case (|> (_lux_proc ["text" "clip"] [input +1 length])
assume
clean-separators
@@ -803,17 +770,124 @@
(loop [digits digits
idx +0
output +0]
- (if (n.< deg-bits idx)
+ (if (n.< bit;width idx)
(let [power (digits-power idx)]
(if (digits-lt power digits)
## Skip power
(recur digits (n.inc idx) output)
(recur (digits-sub! power digits)
(n.inc idx)
- (bit-set (n.- idx (n.dec deg-bits)) output))))
+ (bit;set (n.- idx (n.dec bit;width)) output))))
(#R;Success (:! Deg output))))
#;None
(#R;Error (_lux_proc ["text" "append"] ["Wrong syntax for Deg: " input])))
(#R;Error (_lux_proc ["text" "append"] ["Wrong syntax for Deg: " input]))))
))
+
+(def: (log2 input)
+ (-> Real Real)
+ (r./ (_lux_proc ["math" "log"] [2.0])
+ (_lux_proc ["math" "log"] [input])))
+
+(def: double-bias Nat +1023)
+
+(def: mantissa-size Nat +52)
+(def: exponent-size Nat +11)
+
+(def: #export (real-to-bits input)
+ (-> Real Nat)
+ (cond (not-a-number? input)
+ (hex "+7FF7FFFFFFFFFFFF")
+
+ (r.= positive-infinity input)
+ (hex "+7FF0000000000000")
+
+ (r.= negative-infinity input)
+ (hex "+FFF0000000000000")
+
+ (r.= 0.0 input)
+ (let [reciprocal (r./ input 1.0)]
+ (if (r.= positive-infinity reciprocal)
+ ## Positive zero
+ (hex "+0000000000000000")
+ ## Negative zero
+ (hex "+8000000000000000")))
+
+ ## else
+ (let [sign (:: Number<Real> signum input)
+ input (:: Number<Real> abs input)
+ exponent (_lux_proc ["math" "floor"] [(log2 input)])
+ exponent-mask (|> +1 (bit;shift-left exponent-size) n.dec)
+ mantissa (|> input
+ ## Normalize
+ (r./ (_lux_proc ["math" "pow"] [2.0 exponent]))
+ ## Make it int-equivalent
+ (r.* (_lux_proc ["math" "pow"] [2.0 52.0])))
+ sign-bit (if (r.= -1.0 sign) +1 +0)
+ exponent-bits (|> exponent real-to-int int-to-nat (n.+ double-bias) (bit;and exponent-mask))
+ mantissa-bits (|> mantissa real-to-int int-to-nat)]
+ ($_ bit;or
+ (bit;shift-left +63 sign-bit)
+ (bit;shift-left mantissa-size exponent-bits)
+ (bit;clear mantissa-size mantissa-bits)))
+ ))
+
+(do-template [<getter> <mask> <size> <offset>]
+ [(def: <mask> (|> +1 (bit;shift-left <size>) n.dec (bit;shift-left <offset>)))
+ (def: (<getter> input)
+ (-> Nat Nat)
+ (|> input (bit;and <mask>) (bit;unsigned-shift-right <offset>)))]
+
+ [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-real input)
+ (-> Nat Real)
+ (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
+ (r.* -1.0 0.0))
+
+ ## else
+ (let [normalized (|> M (bit;set mantissa-size)
+ nat-to-int int-to-real
+ (r./ (_lux_proc ["math" "pow"] [2.0 52.0])))
+ power (|> E (n.- double-bias)
+ nat-to-int int-to-real
+ [2.0] (_lux_proc ["math" "pow"]))
+ shifted (r.* power
+ normalized)]
+ (if (n.= +0 S)
+ shifted
+ (r.* -1.0 shifted))))))
+
+## [Hash]
+(struct: #export _ (Hash Nat)
+ (def: eq Eq<Nat>)
+ (def: hash id))
+
+(struct: #export _ (Hash Int)
+ (def: eq Eq<Int>)
+ (def: hash int-to-nat))
+
+(struct: #export _ (Hash Real)
+ (def: eq Eq<Real>)
+
+ (def: hash real-to-bits))
+
+(struct: #export _ (Hash Deg)
+ (def: eq Eq<Deg>)
+ (def: hash (|>. (:! Nat))))
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
index 1fb9d63db..b89747622 100644
--- a/stdlib/source/lux/math.lux
+++ b/stdlib/source/lux/math.lux
@@ -1,10 +1,8 @@
(;module: {#;doc "Common mathematical constants and functions."}
lux
(lux (control monad)
- (data (coll [list "" Fold<List>])
- [number "Int/" Number<Int>]
- [product]
- text/format)
+ (data (coll [list "L/" Fold<List>])
+ [product])
[macro]
(macro ["s" syntax #+ syntax: Syntax "s/" Functor<Syntax>]
[code])))
@@ -49,7 +47,7 @@
[ceil "ceil"]
[floor "floor"]
- [round "round"]
+ [round "round"]
)
(do-template [<name> <method>]
@@ -122,22 +120,22 @@
init-op s;any
init-param (infix^ [])
steps (s;some (s;seq s;any (infix^ [])))]
- (wrap (product;right (fold (function [[op param] [subject [_subject _op _param]]]
- [param [(#Infix _subject _op _param)
- (` and)
- (#Infix subject op param)]])
- [init-param [init-subject init-op init-param]]
- steps))))
+ (wrap (product;right (L/fold (function [[op param] [subject [_subject _op _param]]]
+ [param [(#Infix _subject _op _param)
+ (` and)
+ (#Infix subject op param)]])
+ [init-param [init-subject init-op init-param]]
+ steps))))
(do s;Monad<Syntax>
[_ (wrap [])
init-subject (infix^ [])
init-op s;any
init-param (infix^ [])
steps (s;some (s;seq s;any (infix^ [])))]
- (wrap (fold (function [[op param] [_subject _op _param]]
- [(#Infix _subject _op _param) op param])
- [init-subject init-op init-param]
- steps)))
+ (wrap (L/fold (function [[op param] [_subject _op _param]]
+ [(#Infix _subject _op _param) op param])
+ [init-subject init-op init-param]
+ steps)))
))
))
diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux
index 3b4ba4909..378731fbf 100644
--- a/stdlib/test/test/lux/data/number.lux
+++ b/stdlib/test/test/lux/data/number.lux
@@ -142,3 +142,10 @@
["Real/Decimal" R;real Eq<Real> Codec<Text,Real>]
["Real/Hex" R;real Eq<Real> Hex@Codec<Text,Real>]
)
+
+(test: "Can convert real values to/from their bit patterns."
+ [raw R;real
+ factor (|> R;nat (:: @ map (|>. (n.% +1000) (n.max +1))))
+ #let [sample (|> factor nat-to-int int-to-real (r.* raw))]]
+ (assert "Can convert real values to/from their bit patterns."
+ (|> sample real-to-bits bits-to-real (r.= sample))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 02:28:08 +0000