diff options
Diffstat (limited to '')
25 files changed, 207 insertions, 1182 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 3606fab8b..93e83c2a2 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -177,14 +177,6 @@ ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool - ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg - ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg - ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg - ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg - ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg - ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool - ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool - ^:private analyse-frac-add ["frac" "+"] &type/Frac &type/Frac ^:private analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac ^:private analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac @@ -194,20 +186,6 @@ ^:private analyse-frac-lt ["frac" "<"] &type/Frac &type/Bool ) -(do-template [<name> <proc>] - (defn <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse &type/Deg x) - =y (&&/analyse-1 analyse &type/Nat y) - _ (&type/check exo-type &type/Deg) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-deg-scale ["deg" "scale"] - ^:private analyse-deg-reciprocal ["deg" "reciprocal"] - ) - (do-template [<encode> <encode-op> <decode> <decode-op> <type>] (do (defn <encode> [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Nil)) ?values] @@ -240,9 +218,6 @@ ^:private analyse-int-min &type/Int ["int" "min"] ^:private analyse-int-max &type/Int ["int" "max"] - ^:private analyse-deg-min &type/Deg ["deg" "min"] - ^:private analyse-deg-max &type/Deg ["deg" "max"] - ^:private analyse-frac-smallest &type/Frac ["frac" "smallest"] ^:private analyse-frac-min &type/Frac ["frac" "min"] ^:private analyse-frac-max &type/Frac ["frac" "max"] @@ -265,9 +240,6 @@ ^:private analyse-int-to-frac &type/Int &type/Frac ["int" "to-frac"] ^:private analyse-frac-to-int &type/Frac &type/Int ["frac" "to-int"] - ^:private analyse-deg-to-frac &type/Deg &type/Frac ["deg" "to-frac"] - ^:private analyse-frac-to-deg &type/Frac &type/Deg ["frac" "to-deg"] - ^:private analyse-io-log &type/Text &type/Top ["io" "log"] ^:private analyse-io-error &type/Text &type/Bottom ["io" "error"] ^:private analyse-io-exit &type/Int &type/Bottom ["io" "exit"] @@ -511,19 +483,6 @@ "lux int to-frac" (analyse-int-to-frac analyse exo-type ?values) "lux int char" (analyse-int-char analyse exo-type ?values) - "lux deg +" (analyse-deg-add analyse exo-type ?values) - "lux deg -" (analyse-deg-sub analyse exo-type ?values) - "lux deg *" (analyse-deg-mul analyse exo-type ?values) - "lux deg /" (analyse-deg-div analyse exo-type ?values) - "lux deg %" (analyse-deg-rem analyse exo-type ?values) - "lux deg =" (analyse-deg-eq analyse exo-type ?values) - "lux deg <" (analyse-deg-lt analyse exo-type ?values) - "lux deg min" (analyse-deg-min analyse exo-type ?values) - "lux deg max" (analyse-deg-max analyse exo-type ?values) - "lux deg to-frac" (analyse-deg-to-frac analyse exo-type ?values) - "lux deg scale" (analyse-deg-scale analyse exo-type ?values) - "lux deg reciprocal" (analyse-deg-reciprocal analyse exo-type ?values) - "lux frac +" (analyse-frac-add analyse exo-type ?values) "lux frac -" (analyse-frac-sub analyse exo-type ?values) "lux frac *" (analyse-frac-mul analyse exo-type ?values) @@ -539,7 +498,6 @@ "lux frac not-a-number" (analyse-frac-not-a-number analyse exo-type ?values) "lux frac positive-infinity" (analyse-frac-positive-infinity analyse exo-type ?values) "lux frac negative-infinity" (analyse-frac-negative-infinity analyse exo-type ?values) - "lux frac to-deg" (analyse-frac-to-deg analyse exo-type ?values) "lux frac to-int" (analyse-frac-to-int analyse exo-type ?values) "lux math cos" (analyse-math-cos analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index b79ceb3ae..018ccf55d 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -208,12 +208,6 @@ ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long - ^:private compile-deg-add Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-deg-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-deg-reciprocal Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-frac-add Opcodes/DADD &&/unwrap-double &&/wrap-double ^:private compile-frac-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double ^:private compile-frac-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double @@ -251,33 +245,6 @@ ^:private compile-frac-lt Opcodes/DCMPG -1 &&/unwrap-double ) -(do-template [<name> <cmp-output>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitLdcInsn (int <cmp-output>)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-deg-eq 0 - ^:private compile-deg-lt -1 - ) - (do-template [<name> <instr> <wrapper>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Nil) ?values] @@ -290,9 +257,6 @@ ^:private compile-int-min (.visitLdcInsn Long/MIN_VALUE) &&/wrap-long ^:private compile-int-max (.visitLdcInsn Long/MAX_VALUE) &&/wrap-long - ^:private compile-deg-min (.visitLdcInsn 0) &&/wrap-long - ^:private compile-deg-max (.visitLdcInsn -1) &&/wrap-long - ^:private compile-frac-smallest (.visitLdcInsn Double/MIN_VALUE) &&/wrap-double ^:private compile-frac-min (.visitLdcInsn (* -1.0 Double/MAX_VALUE)) &&/wrap-double ^:private compile-frac-max (.visitLdcInsn Double/MAX_VALUE) &&/wrap-double @@ -330,41 +294,6 @@ ^:private compile-frac-decode "decode_frac" ) -(do-template [<name> <method>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long)] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> "(JJ)J") - &&/wrap-long)]] - (return nil))) - - ^:private compile-deg-mul "mul_deg" - ^:private compile-deg-div "div_deg" - ) - -(do-template [<name> <class> <method> <sig> <unwrap> <wrap>] - (let [+wrapper-class+ (&host-generics/->bytecode-class-name <class>)] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - <unwrap> - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> <sig>) - <wrap>)]] - (return nil)))) - - ^:private compile-deg-to-frac "java.lang.Long" "deg-to-frac" "(J)D" &&/unwrap-long &&/wrap-double - ^:private compile-frac-to-deg "java.lang.Double" "frac-to-deg" "(D)J" &&/unwrap-double &&/wrap-long - ) - (defn ^:private compile-int-char [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer @@ -787,22 +716,6 @@ "remove" (compile-array-remove compile ?values special-args) "size" (compile-array-size compile ?values special-args)) - "deg" - (case proc - "+" (compile-deg-add compile ?values special-args) - "-" (compile-deg-sub compile ?values special-args) - "*" (compile-deg-mul compile ?values special-args) - "/" (compile-deg-div compile ?values special-args) - "%" (compile-deg-rem compile ?values special-args) - "=" (compile-deg-eq compile ?values special-args) - "<" (compile-deg-lt compile ?values special-args) - "max" (compile-deg-max compile ?values special-args) - "min" (compile-deg-min compile ?values special-args) - "to-frac" (compile-deg-to-frac compile ?values special-args) - "scale" (compile-deg-scale compile ?values special-args) - "reciprocal" (compile-deg-reciprocal compile ?values special-args) - ) - "int" (case proc "+" (compile-int-add compile ?values special-args) @@ -834,7 +747,6 @@ "positive-infinity" (compile-frac-positive-infinity compile ?values special-args) "negative-infinity" (compile-frac-negative-infinity compile ?values special-args) "to-int" (compile-frac-to-int compile ?values special-args) - "to-deg" (compile-frac-to-deg compile ?values special-args) "encode" (compile-frac-encode compile ?values special-args) "decode" (compile-frac-decode compile ?values special-args) ) diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index dfd60b6a0..da5917e3b 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -292,30 +292,6 @@ (.visitEnd)))] nil)) -(defn ^:private low-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. - (.visitLdcInsn (int -1)) - (.visitInsn Opcodes/I2L) - ;; Then do a bitwise and. - (.visitInsn Opcodes/LAND) - )) - -(defn ^:private high-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - )) - -(defn ^:private swap2 [^MethodVisitor =method] - (doto =method - ;; X2, Y2 - (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X2 - )) - (defn ^:private swap2x1 [^MethodVisitor =method] (doto =method ;; X1, Y2 @@ -323,147 +299,6 @@ (.visitInsn Opcodes/POP2) ;; Y2, X1 )) -(defn ^:private bit-set-64? [^MethodVisitor =method] - (doto =method - ;; L, I - (.visitLdcInsn (long 1)) ;; L, I, L - (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L - (.visitInsn Opcodes/POP2) ;; L, L, I - (.visitInsn Opcodes/LSHL) ;; L, L - (.visitInsn Opcodes/LAND) ;; L - (.visitLdcInsn (long 0)) ;; L, L - (.visitInsn Opcodes/LCMP) ;; I - )) - -(defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] - (|let [deg-bits 64 - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) - ;; Based on: http://stackoverflow.com/a/31629280/6823464 - (.visitCode) - ;; Bottom part - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Middle part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - (.visitInsn Opcodes/LADD) - ;; Join middle and bottom - (.visitInsn Opcodes/LADD) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Top part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - ;; Join top with rest - (.visitInsn Opcodes/LADD) - ;; Return - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (let [$loop-start (new Label) - $done (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_leading_zeros" "(J)I" nil nil) - (.visitCode) - (.visitLdcInsn (int 64)) - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFEQ $done) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/LUSHR) - (.visitVarInsn Opcodes/LSTORE 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitLabel $done) - (.visitInsn Opcodes/IRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$same (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFEQ $same) - ;; Based on: http://stackoverflow.com/a/8510587/6823464 - ;; Shifting the operands as much as possible can help - ;; avoid some loss of precision later. - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_leading_zeros" "(J)I") - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_leading_zeros" "(J)I") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "min" "(II)I") - (.visitVarInsn Opcodes/ISTORE 4) - (.visitVarInsn Opcodes/LLOAD 0) (.visitVarInsn Opcodes/ILOAD 4) (.visitInsn Opcodes/LSHL) - (.visitVarInsn Opcodes/LLOAD 2) (.visitVarInsn Opcodes/ILOAD 4) (.visitInsn Opcodes/LSHL) high-4b - (.visitInsn Opcodes/LDIV) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LSHL) - (.visitInsn Opcodes/LRETURN) - (.visitLabel $same) - (.visitLdcInsn (long -1)) ;; ~= 1.0 DEG - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-frac" "(J)D" nil nil) - (.visitCode) - ;; Translate high bytes - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Translate low bytes - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Combine and return - (.visitInsn Opcodes/DADD) - (.visitInsn Opcodes/DRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac-to-deg" "(D)J" nil nil) - (.visitCode) - ;; Drop any excess - (.visitVarInsn Opcodes/DLOAD 0) - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - ;; Shift upper half, but retain remaining decimals - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Make a copy, so the lower half can be extracted - (.visitInsn Opcodes/DUP2) - ;; Get that lower half - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Turn it into a deg - (.visitInsn Opcodes/D2L) - ;; Turn the upper half into deg too - swap2 - (.visitInsn Opcodes/D2L) - ;; Combine both pieces - (.visitInsn Opcodes/LADD) - ;; FINISH - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd))] - nil)) - (do-template [<name> <method> <class> <parse-method> <signature> <wrapper>] (defn <name> [^ClassWriter =class] (do (let [$from (new Label) @@ -755,7 +590,6 @@ (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) (compile-LuxRT-int-methods) - (compile-LuxRT-deg-methods) (compile-LuxRT-frac-methods) (compile-LuxRT-text-methods) (compile-LuxRT-process-methods))]] diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux index f9e00be2a..28b993f91 100644 --- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux @@ -219,9 +219,6 @@ [frac//not-a-number Double::NaN runtimeT.frac] [frac//positive-infinity Double::POSITIVE_INFINITY runtimeT.frac] [frac//negative-infinity Double::NEGATIVE_INFINITY runtimeT.frac] - - [deg//min 0 runtimeT.int] - [deg//max -1 runtimeT.int] ) (do-template [<name> <op>] @@ -234,14 +231,6 @@ [int//mul runtimeT.int//*] [int//div runtimeT.int///] [int//rem runtimeT.int//%] - - [deg//add runtimeT.int//+] - [deg//sub runtimeT.int//-] - [deg//mul runtimeT.deg//*] - [deg//div runtimeT.deg///] - [deg//rem runtimeT.int//-] - [deg//scale runtimeT.int//*] - [deg//reciprocal runtimeT.int///] ) (do-template [<name> <op>] @@ -268,8 +257,6 @@ [int//= runtimeT.int//=] [int//< runtimeT.int//<] - [deg//= runtimeT.int//=] - [deg//< runtimeT.int//<] ) (def: (frac//encode inputJS) @@ -289,8 +276,6 @@ [int//to-frac runtimeT.int//to-number] [frac//to-int runtimeT.int//from-number] - [frac//to-deg runtimeT.deg//from-frac] - [deg//to-frac runtimeT.deg//to-frac] [text//hash runtimeT.text//hash] ) @@ -475,23 +460,6 @@ (install "to-frac" (unary int//to-frac)) (install "char" (unary int//char))))) -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//=)) - (install "<" (binary deg//<)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary deg//to-frac))))) - (def: frac-procs Bundle (<| (prefix "frac") @@ -509,7 +477,6 @@ (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary frac//to-deg)) (install "to-int" (unary frac//to-int)) (install "encode" (unary frac//encode)) (install "decode" (unary frac//decode))))) @@ -603,7 +570,6 @@ (|> lux-procs (dict.merge bit-procs) (dict.merge int-procs) - (dict.merge deg-procs) (dict.merge frac-procs) (dict.merge text-procs) (dict.merge array-procs) diff --git a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux index 5fab92941..a95268013 100644 --- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux @@ -584,70 +584,6 @@ __int/// __int//%)) -(runtime: deg//* "mulD64" - (format "(function " @ "(l,r) {" - "var lL = " int//from-number "(l.L);" - "var rL = " int//from-number "(r.L);" - "var lH = " int//from-number "(l.H);" - "var rH = " int//from-number "(r.H);" - - "var bottom = " bit//logical-right-shift "(" int//* "(lL,rL),32);" - "var middle = " int//+ "(" int//* "(lH,rL)," int//* "(lL,rH));" - "var top = " int//* "(lH,rH);" - - "var bottomAndMiddle = " bit//logical-right-shift "(" int//+ "(middle,bottom),32);" - - "return " int//+ "(top,bottomAndMiddle);" - "})")) - -(runtime: deg//leading-zeroes "countLeadingZeroes" - (format "(function " @ "(input) {" - "var zeroes = 64;" - (format "while(!" int//= "(input," int//zero ")) {" - "zeroes--;" - "input = " bit//logical-right-shift "(input,1);" - "}") - "return zeroes;" - "})")) - -(runtime: deg/// "divD64" - (format "(function " @ "(l,r) {" - (format "if(" int//= "(l,r)) {" - "return " int//negate "(" int//one ");" ## ~= 1.0 DEG - "}" - "else {" - "var minShift = Math.min(" deg//leading-zeroes "(l), " deg//leading-zeroes "(r));" - "l = " bit//left-shift "(l,minShift);" - "r = " bit//left-shift "(r,minShift);" - "return " bit//left-shift "(" int/// "(l," int//from-number "(r.H)),32);" - "}") - "})")) - -(runtime: deg//to-frac "degToFrac" - (format "(function " @ "(input) {" - "var two32 = Math.pow(2,32);" - "var high = input.H / two32;" - "var low = (input.L / two32) / two32;" - "return high+low;" - "})")) - -(runtime: deg//from-frac "fracToDeg" - (format "(function " @ "(input) {" - "var two32 = Math.pow(2,32);" - "var shifted = (input % 1.0) * two32;" - "var low = ((shifted % 1.0) * two32) | 0;" - "var high = shifted | 0;" - "return " int//new "(high,low);" - "})")) - -(def: runtime//deg - Runtime - (format __deg//* - __deg//leading-zeroes - __deg/// - __deg//to-frac - __deg//from-frac)) - (runtime: text//index "index" (format "(function " @ "(text,part,start) {" "var idx = text.indexOf(part," int//to-number "(start));" @@ -807,7 +743,6 @@ runtime//adt runtime//bit runtime//int - runtime//deg runtime//text runtime//array runtime//io diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux index 05a38eb2f..59b7c8b4b 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -265,8 +265,6 @@ $.Method ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) -(def: deg-method $.Method nat-method) - (do-template [<name> <const> <type>] [(def: (<name> _) Nullary @@ -281,9 +279,6 @@ [frac//not-a-number ($i.double Double::NaN) #$.Double] [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double] [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double] - - [deg//min ($i.long 0) #$.Long] - [deg//max ($i.long -1) #$.Long] ) (do-template [<name> <type> <op>] @@ -305,14 +300,6 @@ [frac//mul #$.Double $i.DMUL] [frac//div #$.Double $i.DDIV] [frac//rem #$.Double $i.DREM] - - [deg//add #$.Long $i.LADD] - [deg//sub #$.Long $i.LSUB] - [deg//mul #$.Long ($i.INVOKESTATIC hostL.runtime-class "mul_deg" deg-method false)] - [deg//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_deg" deg-method false)] - [deg//rem #$.Long $i.LSUB] - [deg//scale #$.Long $i.LMUL] - [deg//reciprocal #$.Long $i.LDIV] ) (do-template [<eq> <lt> <unwrap> <cmp>] @@ -329,7 +316,6 @@ [int//eq int//lt ($i.unwrap #$.Long) $i.LCMP] [frac//eq frac//lt ($i.unwrap #$.Double) $i.DCMPG] - [deg//eq deg//lt ($i.unwrap #$.Long) $i.LCMP] ) (do-template [<name> <prepare> <transform>] @@ -342,17 +328,10 @@ ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))] [frac//to-int ($i.unwrap #$.Double) (<| ($i.wrap #$.Long) $i.D2L)] - [frac//to-deg ($i.unwrap #$.Double) - (<| ($i.wrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "frac_to_deg" - ($t.method (list $t.double) (#.Some $t.long) (list)) false))] [frac//encode ($i.unwrap #$.Double) ($i.INVOKESTATIC "java.lang.Double" "toString" ($t.method (list $t.double) (#.Some $String) (list)) false)] [frac//decode ($i.CHECKCAST "java.lang.String") ($i.INVOKESTATIC hostL.runtime-class "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) false)] - - [deg//to-frac ($i.unwrap #$.Long) - (<| ($i.wrap #$.Double) ($i.INVOKESTATIC hostL.runtime-class "deg_to_frac" - ($t.method (list $t.long) (#.Some $t.double) (list)) false))] ) ## [[Text]] @@ -622,23 +601,6 @@ (install "to-frac" (unary int//to-frac)) (install "char" (unary int//char))))) -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//eq)) - (install "<" (binary deg//lt)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary deg//to-frac))))) - (def: frac-procs Bundle (<| (prefix "frac") @@ -656,7 +618,6 @@ (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary frac//to-deg)) (install "to-int" (unary frac//to-int)) (install "encode" (unary frac//encode)) (install "decode" (unary frac//decode))))) @@ -750,7 +711,6 @@ (|> lux-procs (dict.merge bit-procs) (dict.merge int-procs) - (dict.merge deg-procs) (dict.merge frac-procs) (dict.merge text-procs) (dict.merge array-procs) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux index 58ed736ab..300c0c353 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -176,107 +176,10 @@ (|>> ($i.ALOAD +0) ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false) ($i.wrap #$.Double)))) - ($d.method #$.Public $.staticM "frac_to_deg" ($t.method (list $t.double) (#.Some $t.long) (list)) - (let [swap2 (|>> $i.DUP2_X2 $i.POP2) - drop-excessI (|>> ($i.double 1.0) $i.DREM) - shiftI (|>> frac-shiftI $i.DMUL)] - (|>> ($i.DLOAD +0) - ## Get upper half - drop-excessI - shiftI - ## Make a copy, so the lower half can be extracted - $i.DUP2 - ## Get lower half - drop-excessI - shiftI - ## Turn it into a deg - $i.D2L - ## Turn the upper half into deg too - swap2 - $i.D2L - ## Combine both pieces - $i.LADD - ## FINISH - $i.LRETURN - ))) )) -(def: deg-bits Nat +64) -(def: deg-method $.Method ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) (def: clz-method $.Method ($t.method (list $t.long) (#.Some $t.int) (list))) -(def: deg-methods - $.Def - (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. - low-half (|>> ($i.int -1) $i.I2L $i.LAND) - high-half (|>> ($i.int 32) $i.LUSHR)] - (|>> ($d.method #$.Public $.staticM "mul_deg" deg-method - ## Based on: http://stackoverflow.com/a/31629280/6823464 - (let [shift-downI (|>> ($i.int 32) $i.LUSHR) - low-leftI (|>> ($i.LLOAD +0) low-half) - high-leftI (|>> ($i.LLOAD +0) high-half) - low-rightI (|>> ($i.LLOAD +2) low-half) - high-rightI (|>> ($i.LLOAD +2) high-half) - bottomI (|>> low-leftI low-rightI $i.LMUL) - middleLI (|>> high-leftI low-rightI $i.LMUL) - middleRI (|>> low-leftI high-rightI $i.LMUL) - middleI (|>> middleLI middleRI $i.LADD) - topI (|>> high-leftI high-rightI $i.LMUL)] - (|>> bottomI shift-downI - middleI $i.LADD shift-downI - topI $i.LADD - $i.LRETURN))) - ($d.method #$.Public $.staticM "count_leading_zeros" clz-method - (let [when-zeroI (function (_ @where) (|>> ($i.long 0) $i.LCMP ($i.IFEQ @where))) - shift-rightI (function (_ amount) (|>> ($i.int amount) $i.LUSHR)) - decI (|>> ($i.int 1) $i.ISUB)] - (<| $i.with-label (function (_ @start)) - $i.with-label (function (_ @done)) - (|>> ($i.int 64) - ($i.label @start) - ($i.LLOAD +0) (when-zeroI @done) - ($i.LLOAD +0) (shift-rightI 1) ($i.LSTORE +0) - decI - ($i.GOTO @start) - ($i.label @done) - $i.IRETURN)))) - ($d.method #$.Public $.staticM "div_deg" deg-method - (<| $i.with-label (function (_ @same)) - (let [subjectI ($i.LLOAD +0) - paramI ($i.LLOAD +2) - equal?I (function (_ @where) (|>> $i.LCMP ($i.IFEQ @where))) - count-leading-zerosI ($i.INVOKESTATIC hostL.runtime-class "count_leading_zeros" clz-method false) - calc-max-shiftI (|>> subjectI count-leading-zerosI - paramI count-leading-zerosI - ($i.INVOKESTATIC "java.lang.Math" "min" ($t.method (list $t.int $t.int) (#.Some $t.int) (list)) false) - ($i.ISTORE +4)) - shiftI (|>> ($i.ILOAD +4) $i.LSHL) - imprecise-divisionI (|>> subjectI shiftI - paramI shiftI high-half - $i.LDIV) - scale-downI (|>> ($i.int 32) $i.LSHL)] - (|>> subjectI paramI - (equal?I @same) - ## Based on: http://stackoverflow.com/a/8510587/6823464 - ## Shifting the operands as much as possible can help - ## avoid some loss of precision later. - calc-max-shiftI - imprecise-divisionI - scale-downI - $i.LRETURN - ($i.label @same) - ($i.long -1) ## ~= 1.0 Degrees - $i.LRETURN)))) - ($d.method #$.Public $.staticM "deg_to_frac" ($t.method (list $t.long) (#.Some $t.double) (list)) - (let [highI (|>> ($i.LLOAD +0) high-half $i.L2D) - lowI (|>> ($i.LLOAD +0) low-half $i.L2D) - scaleI (|>> frac-shiftI $i.DDIV)] - (|>> highI scaleI - lowI scaleI scaleI - $i.DADD - $i.DRETURN))) - ))) - (def: text-methods $.Def (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) @@ -533,7 +436,6 @@ #let [bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runtime-class (list) ["java.lang.Object" (list)] (list) (|>> adt-methods frac-methods - deg-methods text-methods pm-methods io-methods diff --git a/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux index a9849b557..d751c6781 100644 --- a/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux @@ -200,9 +200,6 @@ [frac//smallest Double::MIN_VALUE lua.float] [frac//min (f/* -1.0 Double::MAX_VALUE) lua.float] [frac//max Double::MAX_VALUE lua.float] - - [deg//min 0 lua.int] - [deg//max -1 lua.int] ) (do-template [<name> <expression>] @@ -234,14 +231,6 @@ [int//mul lua.*] [int//div lua.//] [int//rem lua.%] - - [deg//add lua.+] - [deg//sub lua.-] - [deg//mul runtimeT.deg//*] - [deg//div runtimeT.deg///] - [deg//rem lua.-] - [deg//scale lua.*] - [deg//reciprocal lua.//] ) (do-template [<name> <op>] @@ -268,8 +257,6 @@ [int//= lua.=] [int//< lua.<] - [deg//= lua.=] - [deg//< lua.<] ) (def: frac//encode @@ -287,7 +274,6 @@ (lua./ <divisor> inputO))] [int//to-frac (lua.float 1.0)] - [deg//to-frac (lua.bit-shl (lua.int 32) (lua.int 1))] ) (do-template [<name> <transform>] @@ -296,7 +282,6 @@ (|> inputO <transform>))] [frac//to-int (<| (lua.apply "math.floor") (list))] - [frac//to-deg runtimeT.deg//from-frac] [text//hash runtimeT.text//hash] ) @@ -462,23 +447,6 @@ (install "to-frac" (unary int//to-frac)) (install "char" (unary int//char))))) -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//=)) - (install "<" (binary deg//<)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary deg//to-frac))))) - (def: frac-procs Bundle (<| (prefix "frac") @@ -496,7 +464,6 @@ (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary frac//to-deg)) (install "to-int" (unary frac//to-int)) (install "encode" (unary frac//encode)) (install "decode" (unary frac//decode))))) @@ -585,7 +552,6 @@ (|> lux-procs (dict.merge bit-procs) (dict.merge int-procs) - (dict.merge deg-procs) (dict.merge frac-procs) (dict.merge text-procs) (dict.merge array-procs) diff --git a/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux index cd5d0c090..de2d574ec 100644 --- a/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/runtime.jvm.lux @@ -197,65 +197,6 @@ (format @@bit//count @@bit//logical-right-shift)) -(runtime: deg//low-mask - (|> (lua.int 1) - (lua.bit-shl (lua.int 32)) - (lua.- (lua.int 1)))) - -(runtime: (deg//* param subject) - (lua.block! (list (lua.local! "sL" (#.Some (lua.bit-and deg//low-mask subject))) - (lua.local! "sH" (#.Some (bit//logical-right-shift (lua.int 32) subject))) - (lua.local! "pL" (#.Some (lua.bit-and deg//low-mask param))) - (lua.local! "pH" (#.Some (bit//logical-right-shift (lua.int 32) param))) - (lua.local! "bottom" (#.Some (bit//logical-right-shift (lua.int 32) - (lua.* "pL" "sL")))) - (lua.local! "middle" (#.Some (lua.+ (lua.* "pL" "sH") - (lua.* "pH" "sL")))) - (lua.local! "top" (#.Some (lua.* "pH" "sH"))) - (lua.return! (|> "bottom" - (lua.+ "middle") - (bit//logical-right-shift (lua.int 32)) - (lua.+ "top")))))) - -(runtime: (deg//leading-zeroes input) - (lua.block! (list (lua.local! "zeroes" (#.Some (lua.int 64))) - (lua.while! (lua.not (lua.= (lua.int 0) input)) - (lua.block! (list (lua.set! "zeroes" (lua.- (lua.int 1) "zeroes")) - (lua.set! input (bit//logical-right-shift (lua.int 1) input))))) - (lua.return! "zeroes")))) - -(runtime: (deg/// param subject) - (lua.if! (lua.= param subject) - (lua.return! (lua.int -1)) - (lua.block! (list (lua.local! "min_shift" (#.Some (lua.apply "math.min" (list (deg//leading-zeroes param) - (deg//leading-zeroes subject))))) - (lua.return! (|> (lua.bit-shl "min_shift" subject) - (lua.// (|> (lua.bit-shl "min_shift" param) - (lua.bit-and deg//low-mask))) - (lua.bit-shl (lua.int 32)))))))) - -(runtime: (deg//from-frac input) - (let [->int (|>> (list) (lua.apply "math.floor"))] - (lua.block! (list (lua.local! "two32" (#.Some (lua.apply "math.pow" (list (lua.float 2.0) (lua.float 32.0))))) - (lua.local! "shifted" (#.Some (|> input - (lua.% (lua.float 1.0)) - (lua.* "two32")))) - (lua.local! "low" (#.Some (|> "shifted" - (lua.% (lua.float 1.0)) - (lua.* "two32") - ->int))) - (lua.local! "high" (#.Some (|> "shifted" ->int))) - (lua.return! (lua.+ (lua.bit-shl (lua.int 32) "high") - "low")))))) - -(def: runtime//deg - Runtime - (format @@deg//low-mask - @@deg//* - @@deg//leading-zeroes - @@deg/// - @@deg//from-frac)) - (runtime: (text//index subject param start) (lua.block! (list (lua.local! "idx" (#.Some (lua.apply "string.find" (list subject param start (lua.bool true))))) (lua.if! (lua.= lua.nil "idx") @@ -447,7 +388,6 @@ (format runtime//lux runtime//adt runtime//bit - runtime//deg runtime//text runtime//array runtime//atom diff --git a/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux index 69b4aede4..0f5a3fdc9 100644 --- a/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux @@ -231,9 +231,6 @@ [frac//smallest Double::MIN_VALUE python.float] [frac//min (f/* -1.0 Double::MAX_VALUE) python.float] [frac//max Double::MAX_VALUE python.float] - - [deg//min 0 python.int] - [deg//max -1 python.int] ) (do-template [<name> <expression>] @@ -265,11 +262,6 @@ [int//add python.+] [int//sub python.-] [int//mul python.*] - - [deg//add python.+] - [deg//sub python.-] - [deg//rem python.-] - [deg//scale python.*] ) (do-template [<name> <op>] @@ -280,10 +272,6 @@ [int//div python./] [int//rem python.%] - - [deg//mul runtimeT.deg//*] - [deg//div runtimeT.deg///] - [deg//reciprocal python./] ) (do-template [<name> <op>] @@ -310,9 +298,6 @@ [int//= python.=] [int//< python.<] - - [deg//= python.=] - [deg//< python.<] ) (def: (apply1 func) @@ -325,15 +310,6 @@ (function (_ object) (python.send (list) method object))) -(do-template [<name> <divisor>] - [(def: (<name> inputO) - Unary - (|> inputO (python./ <divisor>)))] - - [deg//to-frac (python.apply (list (|> (python.int 1) (python.bit-shl (python.int 32)))) - (python.global "float"))] - ) - (def: int-procs Bundle (<| (prefix "int") @@ -350,23 +326,6 @@ (install "to-frac" (unary (apply1 (python.global "float")))) (install "char" (unary (apply1 (python.global "chr"))))))) -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//=)) - (install "<" (binary deg//<)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary deg//to-frac))))) - (def: frac-procs Bundle (<| (prefix "frac") @@ -384,7 +343,6 @@ (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary runtimeT.deg//from-frac)) (install "to-int" (unary (apply1 (python.global "int")))) (install "encode" (unary (apply1 (python.global "repr")))) (install "decode" (unary runtimeT.frac//decode))))) @@ -530,7 +488,6 @@ (|> lux-procs (dict.merge bit-procs) (dict.merge int-procs) - (dict.merge deg-procs) (dict.merge frac-procs) (dict.merge text-procs) (dict.merge array-procs) diff --git a/new-luxc/source/luxc/lang/translation/python/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/python/runtime.jvm.lux index 3457cc49b..9bcc46680 100644 --- a/new-luxc/source/luxc/lang/translation/python/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/python/runtime.jvm.lux @@ -282,77 +282,6 @@ @@bit//count @@bit//logical-right-shift)) -(def: high (-> Expression Expression) (bit//logical-right-shift (python.int 32))) -(def: low (-> Expression Expression) (python.bit-and full-32-bits)) - -(runtime: (deg//* param subject) - (with-vars [$sL $sH $pL $pH $bottom $middle $top] - ($_ python.then! - (python.set! (list $sL) (..low subject)) - (python.set! (list $sH) (high subject)) - (python.set! (list $pL) (..low param)) - (python.set! (list $pH) (high param)) - (python.set! (list $bottom) (bit//logical-right-shift (python.int 32) - (python.* (@@ $pL) (@@ $sL)))) - (python.set! (list $middle) (python.+ (python.* (@@ $pL) (@@ $sH)) - (python.* (@@ $pH) (@@ $sL)))) - (python.set! (list $top) (python.* (@@ $pH) (@@ $sH))) - (python.return! (|> (@@ $bottom) - (python.+ (@@ $middle)) - high - (python.+ (@@ $top))))))) - -(runtime: (deg//leading-zeroes input) - (with-vars [zeroes remaining] - ($_ python.then! - (python.set! (list zeroes) (python.int 64)) - (python.set! (list remaining) input) - (python.while! (python.not (python.= (python.int 0) (@@ remaining))) - ($_ python.then! - (python.set! (list zeroes) (python.- (python.int 1) (@@ zeroes))) - (python.set! (list remaining) (bit//logical-right-shift (python.int 1) (@@ remaining))))) - (python.return! (@@ zeroes))))) - -(runtime: (deg/// param subject) - (with-vars [min-shift] - (python.if! (python.= param subject) - (python.return! (python.int -1)) - ($_ python.then! - (python.set! (list min-shift) - (python.apply (list (deg//leading-zeroes param) - (deg//leading-zeroes subject)) - (python.global "min"))) - (python.return! (|> (python.bit-shl (@@ min-shift) subject) - (python./ (|> param (python.bit-shl (@@ min-shift)) ..low)) - (python.bit-shl (python.int 32)))))))) - -(def: (float-to-int float) - (-> Expression Expression) - (python.apply (list float) (python.global "int"))) - -(runtime: (deg//from-frac input) - (with-vars [two32 shifted] - ($_ python.then! - (python.set! (list two32) (|> (python.float 2.0) - (python.** (python.float 32.0)))) - (python.set! (list shifted) (|> input - (python.% (python.float 1.0)) - (python.* (@@ two32)))) - (let [low (|> (@@ shifted) - (python.% (python.float 1.0)) - (python.* (@@ two32)) - float-to-int) - high (|> (@@ shifted) float-to-int (python.bit-shl (python.int 32)))] - (python.return! (|> low (python.+ high))))))) - -(def: runtime//deg - Runtime - ($_ python.then! - @@deg//* - @@deg//leading-zeroes - @@deg/// - @@deg//from-frac)) - (runtime: (frac//decode input) (let [$ex (python.var "ex")] (python.try! @@ -522,7 +451,6 @@ runtime//lux runtime//adt runtime//bit - runtime//deg runtime//frac runtime//text runtime//array diff --git a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux index 9554abc86..68b0bb67d 100644 --- a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux @@ -231,9 +231,6 @@ [int//min runtimeT.int//min] [int//max runtimeT.int//max] - - [deg//min runtimeT.int//zero] - [deg//max runtimeT.int//-one] ) (do-template [<name> <frac>] @@ -256,14 +253,6 @@ [int//mul runtimeT.int//*] [int//div runtimeT.int///] [int//rem runtimeT.int//%] - - [deg//add runtimeT.int//+] - [deg//sub runtimeT.int//-] - [deg//rem runtimeT.int//-] - [deg//scale runtimeT.int//*] - [deg//mul runtimeT.deg//*] - [deg//div runtimeT.deg///] - [deg//reciprocal runtimeT.int///] ) (do-template [<name> <op>] @@ -290,9 +279,6 @@ [int//= runtimeT.int//=] [int//< runtimeT.int//<] - - [deg//= runtimeT.int//=] - [deg//< runtimeT.int//<] ) (def: (apply1 func) @@ -318,23 +304,6 @@ (install "to-frac" (unary runtimeT.int//to-float)) (install "char" (unary int//char))))) -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//=)) - (install "<" (binary deg//<)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary runtimeT.deg//to-frac))))) - (def: (frac//encode value) (-> Expression Expression) (r.apply (list (r.string "%f") value) (r.global "sprintf"))) @@ -356,7 +325,6 @@ (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary runtimeT.deg//from-frac)) (install "to-int" (unary (apply1 (r.global "as.integer")))) (install "encode" (unary frac//encode)) (install "decode" (unary runtimeT.frac//decode))))) @@ -517,7 +485,6 @@ (|> lux-procs (dict.merge bit-procs) (dict.merge int-procs) - (dict.merge deg-procs) (dict.merge frac-procs) (dict.merge text-procs) (dict.merge array-procs) diff --git a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux index 70a9f62df..ced898662 100644 --- a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux @@ -664,72 +664,6 @@ @@bit//logical-right-shift )) -(runtime: (deg//* param subject) - (with-vars [sL sH pL pH bottom middle top] - ($_ r.then - (r.set! sL (int//from-float (int64-low (@@ subject)))) - (r.set! sH (int//from-float (int64-high (@@ subject)))) - (r.set! pL (int//from-float (int64-low (@@ param)))) - (r.set! pH (int//from-float (int64-high (@@ param)))) - (let [bottom (bit//logical-right-shift (r.int 32) - (int//* (@@ pL) (@@ sL))) - middle (int//+ (int//* (@@ pL) (@@ sH)) - (int//* (@@ pH) (@@ sL))) - top (int//* (@@ pH) (@@ sH))] - (|> bottom - (int//+ middle) - (bit//logical-right-shift (r.int 32)) - (int//+ top)))))) - -(runtime: (deg//leading-zeroes input) - (with-vars [zeroes remaining] - ($_ r.then - (r.set! zeroes (r.int 64)) - (r.set! remaining (@@ input)) - (r.while (|> (@@ remaining) (int//= int//zero) r.not) - ($_ r.then - (r.set! zeroes (|> (@@ zeroes) (r.- (r.int 1)))) - (r.set! remaining (|> (@@ remaining) (bit//logical-right-shift (r.int 1)))))) - (@@ zeroes)))) - -(runtime: (deg/// param subject) - (with-vars [min-shift] - (r.if (|> (@@ subject) (int//= (@@ param))) - int//-one - ($_ r.then - (r.set! min-shift - (r.apply (list (deg//leading-zeroes (@@ param)) - (deg//leading-zeroes (@@ subject))) - (r.global "min"))) - (let [subject' (|> (@@ subject) (bit//left-shift (@@ min-shift))) - param' (|> (@@ param) (bit//left-shift (@@ min-shift)) int64-high int//from-float)] - (|> subject' - (int/// param') - (bit//left-shift (r.int 32)))))))) - -(runtime: (deg//from-frac input) - (with-vars [two32 shifted] - ($_ r.then - (r.set! two32 (|> (r.float 2.0) (r.** (r.float 32.0)))) - (r.set! shifted (|> (@@ input) (r.%% (r.float 1.0)) (r.* (@@ two32)))) - (let [low (|> (@@ shifted) (r.%% (r.float 1.0)) (r.* (@@ two32)) as-integer) - high (|> (@@ shifted) as-integer)] - (int//new high low))))) - -(runtime: (deg//to-frac input) - (let [high (|> (int64-high (@@ input)) (r./ f2^32)) - low (|> (int64-low (@@ input)) (r./ f2^32) (r./ f2^32))] - (|> low (r.+ high)))) - -(def: runtime//deg - Runtime - ($_ r.then - @@deg//* - @@deg//leading-zeroes - @@deg/// - @@deg//from-frac - @@deg//to-frac)) - (runtime: (frac//decode input) (with-vars [output] ($_ r.then @@ -958,7 +892,6 @@ runtime//bit runtime//int runtime//adt - runtime//deg runtime//frac runtime//text runtime//array diff --git a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux index e38dfff28..729acd978 100644 --- a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux @@ -236,9 +236,6 @@ [frac//smallest Double::MIN_VALUE ruby.float] [frac//min (f/* -1.0 Double::MAX_VALUE) ruby.float] [frac//max Double::MAX_VALUE ruby.float] - - [deg//min 0 ruby.int] - [deg//max -1 ruby.int] ) (do-template [<name> <expression>] @@ -278,14 +275,6 @@ [int//div ruby./] [int//rem ruby.%] - - [deg//add ruby.+] - [deg//sub ruby.-] - [deg//mul runtimeT.deg//*] - [deg//div runtimeT.deg///] - [deg//rem ruby.-] - [deg//scale ruby.*] - [deg//reciprocal ruby./] ) (do-template [<name> <op>] @@ -312,8 +301,7 @@ [int//= ruby.=] [int//< ruby.<] - [deg//= ruby.=] - [deg//< ruby.<]) + ) (def: frac//encode Unary @@ -331,25 +319,6 @@ (ruby.return! (runtimeT.some "temp")) (ruby.return! runtimeT.none))))))) -(do-template [<name> <divisor>] - [(def: (<name> inputO) - Unary - (ruby./ <divisor> inputO))] - - [int//to-frac (ruby.float 1.0)] - [deg//to-frac (ruby.send "to_f" (list) - (ruby.bit-shl (ruby.int 32) (ruby.int 1)))] - ) - -(do-template [<name> <transform>] - [(def: <name> - Unary - <transform>)] - - [frac//to-int (ruby.send "floor" (list))] - [frac//to-deg runtimeT.deg//from-frac] - ) - (def: int-procs Bundle (<| (prefix "int") @@ -363,26 +332,9 @@ (install "<" (binary int//<)) (install "min" (nullary int//min)) (install "max" (nullary int//max)) - (install "to-frac" (unary int//to-frac)) + (install "to-frac" (unary (ruby./ (ruby.float 1.0)))) (install "char" (unary (ruby.send "chr" (list))))))) -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//=)) - (install "<" (binary deg//<)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary deg//to-frac))))) - (def: frac-procs Bundle (<| (prefix "frac") @@ -400,8 +352,7 @@ (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary frac//to-deg)) - (install "to-int" (unary frac//to-int)) + (install "to-int" (unary (ruby.send "floor" (list)))) (install "encode" (unary frac//encode)) (install "decode" (unary frac//decode))))) @@ -608,7 +559,6 @@ (|> lux-procs (dict.merge bit-procs) (dict.merge int-procs) - (dict.merge deg-procs) (dict.merge frac-procs) (dict.merge text-procs) (dict.merge array-procs) diff --git a/new-luxc/source/luxc/lang/translation/ruby/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/runtime.jvm.lux index 7f66b0cd5..ac8f7b11a 100644 --- a/new-luxc/source/luxc/lang/translation/ruby/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/ruby/runtime.jvm.lux @@ -178,63 +178,6 @@ (format @@bit//count @@bit//logical-right-shift)) -(def: high (-> Expression Expression) (bit//logical-right-shift (ruby.int 32))) -(def: low (-> Expression Expression) (ruby.bit-and "0xFFFFFFFF")) - -(runtime: (deg//* param subject) - (ruby.block! (list (ruby.set! (list "sL") (low subject)) - (ruby.set! (list "sH") (high subject)) - (ruby.set! (list "pL") (low param)) - (ruby.set! (list "pH") (high param)) - (ruby.set! (list "bottom") (bit//logical-right-shift (ruby.int 32) - (ruby.* "pL" "sL"))) - (ruby.set! (list "middle") (ruby.+ (ruby.* "pL" "sH") - (ruby.* "pH" "sL"))) - (ruby.set! (list "top") (ruby.* "pH" "sH")) - (ruby.return! (|> "bottom" - (ruby.+ "middle") - high - (ruby.+ "top")))))) - -(runtime: (deg//leading-zeroes input) - (ruby.block! (list (ruby.set! (list "zeroes") (ruby.int 64)) - (ruby.while! (ruby.not (ruby.= (ruby.int 0) input)) - (ruby.block! (list (ruby.set! (list "zeroes") (ruby.- (ruby.int 1) "zeroes")) - (ruby.set! (list input) (bit//logical-right-shift (ruby.int 1) input))))) - (ruby.return! "zeroes")))) - -(runtime: (deg/// param subject) - (ruby.if! (ruby.= param subject) - (ruby.return! (ruby.int -1)) - (ruby.block! (list (ruby.set! (list "min_shift") - (ruby.send "min" (list) - (ruby.array (list (deg//leading-zeroes param) - (deg//leading-zeroes subject))))) - (ruby.return! (|> (ruby.bit-shl "min_shift" subject) - (ruby./ (|> param (ruby.bit-shl "min_shift") low)) - (ruby.bit-shl (ruby.int 32)))))))) - -(runtime: (deg//from-frac input) - (let [->int (ruby.send "floor" (list))] - (ruby.block! (list (ruby.set! (list "two32") (ruby.pow (ruby.float 32.0) (ruby.float 2.0))) - (ruby.set! (list "shifted") (|> input - (ruby.% (ruby.float 1.0)) - (ruby.* "two32"))) - (ruby.set! (list "low") (|> "shifted" - (ruby.% (ruby.float 1.0)) - (ruby.* "two32") - ->int)) - (ruby.set! (list "high") (|> "shifted" ->int)) - (ruby.return! (ruby.+ (ruby.bit-shl (ruby.int 32) "high") - "low")))))) - -(def: runtime//deg - Runtime - (format @@deg//* - @@deg//leading-zeroes - @@deg/// - @@deg//from-frac)) - (runtime: (text//index subject param start) (ruby.block! (list (ruby.set! (list "idx") (ruby.send "index" (list param start) subject)) (ruby.if! (ruby.= ruby.nil "idx") @@ -332,7 +275,6 @@ (format runtime//lux "\n" runtime//adt "\n" runtime//bit "\n" - runtime//deg "\n" runtime//text "\n" runtime//array "\n" runtime//atom "\n" diff --git a/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux index 67ec0e95c..81d753b7b 100644 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux @@ -237,9 +237,6 @@ [int//min ("lux int min")] [int//max ("lux int max")] - - [deg//min 0] - [deg//max -1] ) (do-template [<name> <frac>] @@ -262,14 +259,6 @@ [int//mul _.*] [int//div _.quotient] [int//rem _.remainder] - - [deg//add _.+] - [deg//sub _.-] - [deg//rem _.-] - [deg//scale _.*] - [deg//mul _.*] - [deg//div _.quotient] - [deg//reciprocal _.quotient] ) (do-template [<name> <op>] @@ -296,19 +285,8 @@ [int//= _.=] [int//< _.<] - - [deg//= _.=] - [deg//< _.<] ) -(def: deg//to-frac - Unary - (let [f2^32 (_.arithmetic-shift (_.int 32) (_.int 1))] - (|>> (_.arithmetic-shift (_.int -32)) - (_.bit-and (_.int (hex "7FFFFFFFFFFFFFFF"))) - (_./ f2^32) - (_./ (_.float 1.0))))) - (def: int//char (|>> (_.apply1 (_.global "integer->char")) (_.apply1 (_.global "string")))) @@ -328,23 +306,6 @@ (install "to-frac" (unary (|>> (_./ (_.float 1.0))))) (install "char" (unary int//char))))) -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash<Text>) - (install "+" (binary deg//add)) - (install "-" (binary deg//sub)) - (install "*" (binary deg//mul)) - (install "/" (binary deg//div)) - (install "%" (binary deg//rem)) - (install "=" (binary deg//=)) - (install "<" (binary deg//<)) - (install "scale" (binary deg//scale)) - (install "reciprocal" (binary deg//reciprocal)) - (install "min" (nullary deg//min)) - (install "max" (nullary deg//max)) - (install "to-frac" (unary deg//to-frac))))) - (def: frac-procs Bundle (<| (prefix "frac") @@ -362,7 +323,6 @@ (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-deg" (unary runtimeT.frac//to-deg)) (install "to-int" (unary (_.apply1 (_.global "exact")))) (install "encode" (unary (_.apply1 (_.global "number->string")))) (install "decode" (unary runtimeT.frac//decode))))) @@ -492,7 +452,6 @@ (|> lux-procs (dict.merge bit-procs) (dict.merge int-procs) - (dict.merge deg-procs) (dict.merge frac-procs) (dict.merge text-procs) (dict.merge array-procs) diff --git a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux index e8016eb0a..c4cd0a909 100644 --- a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux @@ -236,19 +236,6 @@ Runtime (_.begin (list @@bit//logical-right-shift))) -(def: int-high (bit//logical-right-shift (_.int 32))) -(def: int-low (_.bit-and (_.int (hex "FFFFFFFF")))) - -(runtime: (frac//to-deg input) - (with-vars [two32 shifted] - (_.let* (list [two32 (|> (_.float 2.0) (_.expt (_.float 32.0)))] - [shifted (|> (@@ input) (_.mod (_.float 1.0)) (_.* (@@ two32)))]) - (let [low (|> (@@ shifted) (_.mod (_.float 1.0)) (_.* (@@ two32)) as-integer) - high (|> (@@ shifted) as-integer)] - (|> high - (_.arithmetic-shift (_.int 32)) - (_.+ low)))))) - (runtime: (frac//decode input) (with-vars [output] (_.let (list [output ((_.apply1 (_.global "string->number")) (@@ input))]) @@ -260,8 +247,7 @@ (def: runtime//frac Runtime (_.begin - (list @@frac//to-deg - @@frac//decode))) + (list @@frac//decode))) ## (def: runtime//text ## Runtime diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux index 632a798e3..a482c4265 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux @@ -112,39 +112,6 @@ (check-success+ "lux int char" (list subjectC) Text)) )))) -(context: "Deg procedures" - (<| (times +100) - (do @ - [subjectC (|> r.deg (:: @ map code.deg)) - paramC (|> r.deg (:: @ map code.deg)) - natC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can add degrees." - (check-success+ "lux deg +" (list subjectC paramC) Deg)) - (test "Can subtract degrees." - (check-success+ "lux deg -" (list subjectC paramC) Deg)) - (test "Can multiply degrees." - (check-success+ "lux deg *" (list subjectC paramC) Deg)) - (test "Can divide degrees." - (check-success+ "lux deg /" (list subjectC paramC) Deg)) - (test "Can calculate remainder of degrees." - (check-success+ "lux deg %" (list subjectC paramC) Deg)) - (test "Can test equality of degrees." - (check-success+ "lux deg =" (list subjectC paramC) Bool)) - (test "Can compare degrees." - (check-success+ "lux deg <" (list subjectC paramC) Bool)) - (test "Can obtain minimum degree." - (check-success+ "lux deg min" (list) Deg)) - (test "Can obtain maximum degree." - (check-success+ "lux deg max" (list) Deg)) - (test "Can convert degree to frac number." - (check-success+ "lux deg to-frac" (list subjectC) Frac)) - (test "Can scale degree." - (check-success+ "lux deg scale" (list subjectC natC) Deg)) - (test "Can calculate the reciprocal of a natural number." - (check-success+ "lux deg reciprocal" (list subjectC natC) Deg)) - )))) - (context: "Frac procedures" (<| (times +100) (do @ @@ -180,8 +147,6 @@ (check-success+ "lux frac negative-infinity" (list) Frac)) (test "Can convert frac number to integer." (check-success+ "lux frac to-int" (list subjectC) Int)) - (test "Can convert frac number to degree." - (check-success+ "lux frac to-deg" (list subjectC) Deg)) (test "Can convert frac number to text." (check-success+ "lux frac encode" (list subjectC) Text)) (test "Can convert text to frac number." diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux index 2da309f34..25d3c4dc9 100644 --- a/new-luxc/test/test/luxc/lang/translation/common.lux +++ b/new-luxc/test/test/luxc/lang/translation/common.lux @@ -8,7 +8,7 @@ ["e" error] [bool "bool/" Eq<Bool>] [text "text/" Eq<Text>] - [number "nat/" Interval<Nat> "int/" Number<Int> Interval<Int> "frac/" Number<Frac> Interval<Frac> "deg/" Interval<Deg>] + [number "int/" Number<Int> Interval<Int> "frac/" Number<Frac> Interval<Frac>] (coll ["a" array] [list])) ["r" math/random] diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 6e6397eeb..6270d0b47 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2295,6 +2295,48 @@ _ (fail "Wrong syntax for do-template")})) +(def:''' #export (d/= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) equality.")]) + (-> Deg Deg Bool) + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test))) + +(def:''' #export (d/< test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) less-than.")]) + (-> Deg Deg Bool) + (n/< ("lux coerce" Nat test) + ("lux coerce" Nat subject))) + +(def:''' #export (d/<= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) less-than-equal.")]) + (-> Deg Deg Bool) + (if (n/< ("lux coerce" Nat test) + ("lux coerce" Nat subject)) + true + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test)))) + +(def:''' #export (d/> test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) greater-than.")]) + (-> Deg Deg Bool) + (d/< subject test)) + +(def:''' #export (d/>= test subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) greater-than-equal.")]) + (-> Deg Deg Bool) + (if (d/< subject test) + true + ("lux int =" + ("lux coerce" Int subject) + ("lux coerce" Int test)))) + (do-template [<type> <eq-proc> <lt-proc> <eq-name> <lt-name> <lte-name> <gt-name> <gte-name> <eq-doc> <<-doc> <<=-doc> <>-doc> <>=-doc>] @@ -2335,9 +2377,6 @@ [ Int "lux int =" "lux int <" i/= i/< i/<= i/> i/>= "Int(eger) equality." "Int(eger) less-than." "Int(eger) less-than-equal." "Int(eger) greater-than." "Int(eger) greater-than-equal."] - [ Deg "lux deg =" "lux deg <" d/= d/< d/<= d/> d/>= - "Deg(ree) equality." "Deg(ree) less-than." "Deg(ree) less-than-equal." "Deg(ree) greater-than." "Deg(ree) greater-than-equal."] - [Frac "lux frac =" "lux frac <" f/= f/< f/<= f/> f/>= "Frac(tion) equality." "Frac(tion) less-than." "Frac(tion) less-than-equal." "Frac(tion) greater-than." "Frac(tion) greater-than-equal."] ) @@ -2389,6 +2428,88 @@ (list [(tag$ ["lux" "doc"]) (text$ <doc>)]) (-> <type> <type> <type>) + ("lux coerce" Deg + (<op> ("lux coerce" Int subject) + ("lux coerce" Int param))))] + + [ Deg d/+ "lux int +" "Deg(ree) addition."] + [ Deg d/- "lux int -" "Deg(ree) substraction."] + ) + +(def:''' #export (d/* param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) multiplication.")]) + (-> Deg Deg Deg) + (let' [subjectH (high-bits ("lux coerce" Nat subject)) + subjectL (low-bits ("lux coerce" Nat subject)) + paramH (high-bits ("lux coerce" Nat param)) + paramL (low-bits ("lux coerce" Nat param)) + bottom ("lux coerce" Int + ("lux bit logical-right-shift" + ("lux coerce" Nat ("lux int *" subjectL paramL)) + +32)) + middle ("lux int +" + ("lux int *" subjectH paramL) + ("lux int *" subjectL paramH)) + top ("lux int *" subjectH paramH)] + ("lux coerce" Deg + ("lux int +" + (high-bits + ("lux coerce" Nat + ("lux int +" + bottom + middle))) + top)))) + +(def:''' least-significant-bit-mask (list) Nat +1) + +(def:''' #export (d// param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) division.")]) + (-> Deg Deg Deg) + (if (|> param ("lux coerce" Int) ("lux int =" 0)) + ("lux io error" "Cannot divide Deg by zero!") + (let' [[trailing-zeroes remaining] (("lux check" (-> Nat Nat (#Product Nat Nat)) + (function' recur [count remaining] + (if (|> remaining + ("lux bit and" least-significant-bit-mask) + ("lux coerce" Int) + ("lux int =" 0)) + (recur (|> count + ("lux coerce" Int) + ("lux int +" 1) + ("lux coerce" Nat)) + ("lux bit logical-right-shift" remaining +1)) + [count remaining]))) + +0 ("lux coerce" Nat param)) + [trailing-zeroes denominator] (if (|> trailing-zeroes ("lux coerce" Int) ("lux int =" 0)) + [+1 ("lux bit logical-right-shift" remaining +1)] + [trailing-zeroes remaining]) + shift ("lux coerce" Nat + ("lux int -" + 64 + ("lux coerce" Int trailing-zeroes))) + numerator ("lux bit left-shift" +1 shift)] + ("lux coerce" Deg + ("lux int /" + ("lux int *" + ("lux coerce" Int subject) + ("lux coerce" Int numerator)) + ("lux coerce" Int denominator)))))) + +(def:''' #export (d/% param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) remainder.")]) + (-> Deg Deg Deg) + ("lux coerce" Deg + (n/% ("lux coerce" Nat subject) + ("lux coerce" Nat param)))) + +(do-template [<type> <name> <op> <doc>] + [(def:''' #export (<name> param subject) + (list [(tag$ ["lux" "doc"]) + (text$ <doc>)]) + (-> <type> <type> <type>) (<op> subject param))] [ Int i/+ "lux int +" "Int(eger) addition."] @@ -2397,12 +2518,6 @@ [ Int i// "lux int /" "Int(eger) division."] [ Int i/% "lux int %" "Int(eger) remainder."] - [ Deg d/+ "lux deg +" "Deg(ree) addition."] - [ Deg d/- "lux deg -" "Deg(ree) substraction."] - [ Deg d/* "lux deg *" "Deg(ree) multiplication."] - [ Deg d// "lux deg /" "Deg(ree) division."] - [ Deg d/% "lux deg %" "Deg(ree) remainder."] - [Frac f/+ "lux frac +" "Frac(tion) addition."] [Frac f/- "lux frac -" "Frac(tion) substraction."] [Frac f/* "lux frac *" "Frac(tion) multiplication."] @@ -2410,16 +2525,14 @@ [Frac f/% "lux frac %" "Frac(tion) remainder."] ) -(do-template [<type> <name> <op> <doc>] - [(def:''' #export (<name> param subject) - (list [(tag$ ["lux" "doc"]) - (text$ <doc>)]) - (-> Nat <type> <type>) - (<op> subject param))] - - [ Deg d/scale "lux deg scale" "Deg(ree) scale."] - [ Deg d/reciprocal "lux deg reciprocal" "Deg(ree) reciprocal."] - ) +(def:''' #export (d/scale param subject) + (list [(tag$ ["lux" "doc"]) + (text$ "Deg(ree) scale.")]) + (-> Nat Deg Deg) + ("lux coerce" Deg + ("lux int *" + ("lux coerce" Int subject) + ("lux coerce" Int param)))) (do-template [<name> <type> <test> <doc>] [(def:''' #export (<name> left right) @@ -5212,15 +5325,6 @@ [nat-to-int Nat Int] ) -(do-template [<name> <op> <from> <to>] - [(def: #export (<name> input) - (-> <from> <to>) - (<op> input))] - - [frac-to-deg "lux frac to-deg" Frac Deg] - [deg-to-frac "lux deg to-frac" Deg Frac] - ) - (def: #export frac-to-nat (|>> frac-to-int int-to-nat)) (def: #export nat-to-frac (|>> nat-to-int int-to-frac)) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index bd1d34cad..eb712d046 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -80,10 +80,10 @@ (def: * d/*) (def: / d//) (def: % d/%) - (def: (negate x) (d/- x ("lux deg max"))) + (def: (negate x) (d/- x (:! Deg -1))) (def: abs id) (def: (signum x) - ("lux deg max"))) + (:! Deg -1))) (do-template [<type> <order> <succ> <pred>] [(struct: #export _ (Enum <type>) @@ -94,7 +94,7 @@ [Nat Order<Nat> n/inc n/dec] [Int Order<Int> i/inc i/dec] [Frac Order<Frac> (f/+ ("lux frac smallest")) (f/- ("lux frac smallest"))] - [Deg Order<Deg> (d/+ ("lux deg min")) (d/- ("lux deg min"))] + [Deg Order<Deg> (d/+ (:! Deg +1)) (d/- (:! Deg +1))] ) (do-template [<type> <enum> <top> <bottom>] @@ -103,10 +103,10 @@ (def: top <top>) (def: bottom <bottom>))] - [ Nat Enum<Nat> ("lux coerce" Nat -1) +0] + [ Nat Enum<Nat> (:! Nat -1) +0] [ Int Enum<Int> ("lux int max") ("lux int min")] [Frac Enum<Frac> ("lux frac max") ("lux frac min")] - [ Deg Enum<Deg> ("lux deg max") ("lux deg min")] + [ Deg Enum<Deg> (:! Deg -1) (:! Deg +0)] ) (do-template [<name> <type> <identity> <compose>] diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux index 7933027c9..7c5ee4150 100644 --- a/stdlib/source/lux/math/logic/fuzzy.lux +++ b/stdlib/source/lux/math/logic/fuzzy.lux @@ -48,81 +48,57 @@ (All [a] (-> (Set a) (Fuzzy a))) (from-predicate (set.member? set))) -(do-template [<ascending> <descending> <gradient> <type> <lt> <gt> <lte> <gte> <sub> <div> <post>] - [(def: (<ascending> from to) - (-> <type> <type> (Fuzzy <type>)) - (function (_ elem) - (cond (<lte> from elem) - &.~false - - (<gte> to elem) - &.~true - - ## in the middle... - (<post> (<div> (<sub> from to) - (<sub> from elem)))))) - - (def: (<descending> from to) - (-> <type> <type> (Fuzzy <type>)) - (function (_ elem) - (cond (<lte> from elem) - &.~true - - (<gte> to elem) - &.~false - - ## in the middle... - (<post> (<div> (<sub> from to) - (<sub> elem to)))))) - - (def: #export (<gradient> from to) - (-> <type> <type> (Fuzzy <type>)) - (if (<lt> to from) - (<ascending> from to) - (<descending> from to)))] - - [d/ascending d/descending d/gradient Deg d/< d/> d/<= d/>= d/- d// id] - [f/ascending f/descending f/gradient Frac f/< f/> f/<= f/>= f/- f// frac-to-deg] - ) - -(do-template [<triangle> <trapezoid> <type> <ascending> <descending> <lt>] - [(def: #export (<triangle> bottom middle top) - (-> <type> <type> <type> (Fuzzy <type>)) - (case (list.sort <lt> (list bottom middle top)) - (^ (list bottom middle top)) - (intersection (<ascending> bottom middle) - (<descending> middle top)) - - _ - (undefined))) - - (def: #export (<trapezoid> bottom middle-bottom middle-top top) - (-> <type> <type> <type> <type> (Fuzzy <type>)) - (case (list.sort <lt> (list bottom middle-bottom middle-top top)) - (^ (list bottom middle-bottom middle-top top)) - (intersection (<ascending> bottom middle-bottom) - (<descending> middle-top top)) - - _ - (undefined)))] - - [d/triangle d/trapezoid Deg d/ascending d/descending d/<] - [f/triangle f/trapezoid Frac f/ascending f/descending f/<] - ) - -(def: #export (gaussian deviation center) - (-> Frac Frac (Fuzzy Frac)) +(def: (ascending from to) + (-> Deg Deg (Fuzzy Deg)) (function (_ elem) - (let [scale (|> deviation (math.pow 2.0) (f/* 2.0)) - membership (|> elem - (f/- center) - (math.pow 2.0) - (f/* -1.0) - (f// scale) - math.exp)] - (if (f/= 1.0 membership) - &.~true - (frac-to-deg membership))))) + (cond (d/<= from elem) + &.~false + + (d/>= to elem) + &.~true + + ## in the middle... + (d// (d/- from to) + (d/- from elem))))) + +(def: (descending from to) + (-> Deg Deg (Fuzzy Deg)) + (function (_ elem) + (cond (d/<= from elem) + &.~true + + (d/>= to elem) + &.~false + + ## in the middle... + (d// (d/- from to) + (d/- elem to))))) + +(def: #export (gradient from to) + (-> Deg Deg (Fuzzy Deg)) + (if (d/< to from) + (ascending from to) + (descending from to))) + +(def: #export (triangle bottom middle top) + (-> Deg Deg Deg (Fuzzy Deg)) + (case (list.sort d/< (list bottom middle top)) + (^ (list bottom middle top)) + (intersection (ascending bottom middle) + (descending middle top)) + + _ + (undefined))) + +(def: #export (trapezoid bottom middle-bottom middle-top top) + (-> Deg Deg Deg Deg (Fuzzy Deg)) + (case (list.sort d/< (list bottom middle-bottom middle-top top)) + (^ (list bottom middle-bottom middle-top top)) + (intersection (ascending bottom middle-bottom) + (descending middle-top top)) + + _ + (undefined))) (def: #export (cut treshold set) (All [a] (-> Deg (Fuzzy a) (Fuzzy a))) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 39d7d880d..695323c98 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -74,11 +74,7 @@ (def: #export int (Random Int) - (function (_ prng) - (let [[prng left] (prng []) - [prng right] (prng [])] - [prng (nat-to-int (n/+ (bit.left-shift +32 left) - right))]))) + (:: Monad<Random> map nat-to-int nat)) (def: #export bool (Random Bool) @@ -105,7 +101,7 @@ (def: #export deg (Random Deg) - (:: Monad<Random> map frac-to-deg frac)) + (:: Monad<Random> map (|>> (:! Deg)) nat)) (def: #export (text' char-gen size) (-> (Random Nat) Nat (Random Text)) diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index b8861eab6..a089f7cee 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -135,10 +135,10 @@ (|> x' (/ y) (* y) (= x')))) ))))] - ["Nat" r.nat n/= n/+ n/- n/* n// n/% n/> +0 +1 +1000000 %n (n/% +1000) id] - ["Int" r.int i/= i/+ i/- i/* i// i/% i/> 0 1 1000000 %i (i/% 1000) id] - ["Frac" r.frac f/= f/+ f/- f/* f// f/% f/> 0.0 1.0 1000000.0 %r id math.floor] - ["Deg" r.deg d/= d/+ d/- d/* d// d/% d/> .0 ("lux deg max") ("lux deg max") %f id id] + ["Nat" r.nat n/= n/+ n/- n/* n// n/% n/> +0 +1 +1000000 %n (n/% +1000) id] + ["Int" r.int i/= i/+ i/- i/* i// i/% i/> 0 1 1000000 %i (i/% 1000) id] + ["Frac" r.frac f/= f/+ f/- f/* f// f/% f/> 0.0 1.0 1000000.0 %r id math.floor] + ["Deg" r.deg d/= d/+ d/- d/* d// d/% d/> .0 (:! Deg -1) (:! Deg -1) %f id id] ) (do-template [category rand-gen -> <- = <cap> %a %z] diff --git a/stdlib/test/test/lux/math/logic/fuzzy.lux b/stdlib/test/test/lux/math/logic/fuzzy.lux index 068e00523..6530fcb4a 100644 --- a/stdlib/test/test/lux/math/logic/fuzzy.lux +++ b/stdlib/test/test/lux/math/logic/fuzzy.lux @@ -50,8 +50,7 @@ (<gte> top sample)))) ))))] - ["Frac" number.Hash<Frac> r.frac &.f/triangle f/< f/<= f/> f/>=] - ["Deg" number.Hash<Deg> r.deg &.d/triangle d/< d/<= d/> d/>=] + ["Deg" number.Hash<Deg> r.deg &.triangle d/< d/<= d/> d/>=] ) (do-template [<desc> <hash> <gen> <trapezoid> <lt> <lte> <gt> <gte>] @@ -98,33 +97,23 @@ (<gte> top sample)))) ))))] - ["Frac" number.Hash<Frac> r.frac &.f/trapezoid f/< f/<= f/> f/>=] - ["Deg" number.Hash<Deg> r.deg &.d/trapezoid d/< d/<= d/> d/>=] + ["Deg" number.Hash<Deg> r.deg &.trapezoid d/< d/<= d/> d/>=] ) -(context: "Gaussian" - (<| (times +100) - (do @ - [deviation (|> r.frac (r.filter (f/> 0.0))) - center r.frac - #let [gaussian (&.gaussian deviation center)]] - (test "The center value will always have maximum membership." - (d/= ~true (&.membership center gaussian)))))) - (def: gen-triangle - (r.Random (&.Fuzzy Frac)) + (r.Random (&.Fuzzy Deg)) (do r.Monad<Random> - [x r.frac - y r.frac - z r.frac] - (wrap (&.f/triangle x y z)))) + [x r.deg + y r.deg + z r.deg] + (wrap (&.triangle x y z)))) (context: "Combinators" (<| (times +100) (do @ [left gen-triangle right gen-triangle - sample r.frac] + sample r.deg] ($_ seq (test "Union membership as as high as membership in any of its members." (let [combined (&.union left right) @@ -174,7 +163,7 @@ (<| (times +100) (do @ [fuzzy gen-triangle - sample r.frac + sample r.deg threshold r.deg #let [vip-fuzzy (&.cut threshold fuzzy) member? (&.to-predicate threshold fuzzy)]] |