path: root/stdlib/source/lux/data/number/frac.lux

(.module:
  [lux #*
   [abstract
    [hash (#+ Hash)]
    [monoid (#+ Monoid)]
    [equivalence (#+ Equivalence)]
    [codec (#+ Codec)]
    ["." order (#+ Order)]]
   [control
    ["." try (#+ Try)]]
   [data
    ["." maybe]]
   ["." math]]
  ["." // #_
   ["#." i64]
   ["#." nat]
   ["#." int]
   ["#." rev]])

(structure: #export equivalence (Equivalence Frac)
  (def: = f/=))

(structure: #export order (Order Frac)
  (def: &equivalence ..equivalence)
  (def: < f/<))

(def: #export + (-> Frac Frac Frac) f/+)

(def: #export - (-> Frac Frac Frac) f/-)

(def: #export * (-> Frac Frac Frac) f/*)

(def: #export / (-> Frac Frac Frac) f//)

(def: #export % (-> Frac Frac Frac) f/%)

(def: #export negate (-> Frac Frac) (f/* -1.0))

(def: #export (abs x)
  (-> Frac Frac)
  (if (f/< +0.0 x)
    (..* -1.0 x)
    x))

(def: #export (signum x)
  (-> Frac Frac)
  (cond (f/= +0.0 x) +0.0
        (f/< +0.0 x) -1.0
        ## else
        +1.0))


(template [<name> <compose> <identity>]
  [(structure: #export <name> (Monoid Frac)
     (def: identity <identity>)
     (def: compose <compose>))]

  [addition       ..+   +0.0]
  [multiplication ..*   +1.0]
  [maximum        f/max ("lux f64 min")]
  [minimum        f/min ("lux f64 max")]
  )

(template [<name> <numerator> <doc>]
  [(def: #export <name>
     {#.doc <doc>}
     Frac
     (../ +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)
    (if (f/< +0.0 x)
      ("lux f64 encode" x)
      ("lux text concat" "+" ("lux f64 encode" x))))

  (def: (decode input)
    (case ("lux f64 decode" [input])
      (#.Some value)
      (#try.Success value)

      #.None
      (#try.Failure "Could not decode Frac"))))

(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 (|> value (..% +1.0) ..abs)
             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 (..* <base> dec-left)
                                      digit-idx (|> shifted (..% <base>) frac-to-int .nat)]
                                  (recur (..% +1.0 shifted)
                                         ("lux text concat" output ("lux text clip" digit-idx (inc digit-idx) <char-set>)))))))]
         ("lux text concat" whole-part decimal-part)))

     (def: (decode repr)
       (case ("lux text index" 0 "." repr)
         (#.Some split-index)
         (let [whole-part ("lux text clip" 0 split-index repr)
               decimal-part ("lux text clip" (inc split-index) ("lux text size" repr) repr)]
           (case [(:: <int> decode whole-part)
                  (:: <int> decode ("lux text concat" "+" decimal-part))]
             (^multi [(#try.Success whole) (#try.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)
                                        (..* <base> output))))
                   adjusted-decimal (|> decimal int-to-frac (../ div-power))
                   dec-rev (case (:: //rev.hex decode ("lux text concat" "." decimal-part))
                             (#try.Success dec-rev)
                             dec-rev

                             (#try.Failure error)
                             (error! error))]
               (#try.Success (..+ (int-to-frac whole)
                                  (..* sign adjusted-decimal))))

             _
             (#try.Failure ("lux text concat" <error> repr))))

         _
         (#try.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" boundary num-digits digits)
              remaining ("lux text clip" 0 boundary digits)]
          (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'))))

(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]
  )

(template [<struct> <error> <from> <to>]
  [(structure: #export <struct> (Codec Text Frac)
     (def: (encode value)
       (let [sign (..signum value)
             raw-bin (:: ..binary encode value)
             dot-idx (maybe.assume ("lux text index" 0 "." raw-bin))
             whole-part ("lux text clip" (if (f/= -1.0 sign) 1 0) dot-idx raw-bin)
             decimal-part ("lux text clip" (inc dot-idx) ("lux text size" raw-bin) 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" 0 "-" repr)
                    (#.Some 0)
                    -1.0

                    _
                    +1.0)]
         (case ("lux text index" 0 "." repr)
           (#.Some split-index)
           (let [whole-part ("lux text clip" 1 split-index repr)
                 decimal-part ("lux text clip" (inc split-index) ("lux text size" repr) 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)
               (#try.Failure _)
               (#try.Failure ("lux text concat" <error> repr))

               output
               output))

           _
           (#try.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)
  (../ (math.log +2.0)
       (math.log input)))

(def: double-bias Nat 1023)

(def: mantissa-size Nat 52)
(def: exponent-size Nat 11)

(template [<hex> <name>]
  [(def: <name> (|> <hex> (:: //nat.hex decode) try.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 (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 (../ input +1.0)]
               (if (f/= positive-infinity reciprocal)
                 ## Positive zero
                 ..positive-zero-bits
                 ## Negative zero
                 ..negative-zero-bits))

             ## else
             (let [input (..abs input)
                   exponent (math.floor (log2 input))
                   exponent-mask (|> 1 (//i64.left-shift exponent-size) dec) 
                   mantissa (|> input
                                ## Normalize
                                (../ (math.pow exponent +2.0))
                                ## Make it int-equivalent
                                (..* (math.pow +52.0 +2.0)))
                   sign-bit (if (f/= -1.0 (..signum input))
                              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)))
             )))

(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.logic-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 (from-bits input)
  (-> I64 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
            (..* -1.0 +0.0))

          ## else
          (let [normalized (|> M (//i64.set mantissa-size)
                               .int int-to-frac
                               (../ (math.pow +52.0 +2.0)))
                power (math.pow (|> E (n/- double-bias)
                                    .int int-to-frac)
                                +2.0)
                shifted (..* power
                             normalized)]
            (if (n/= 0 S)
              shifted
              (..* -1.0 shifted))))))

(structure: #export hash (Hash Frac)
  (def: &equivalence ..equivalence)
  (def: hash ..to-bits))