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

(.module:
  [lux (#- nat int rev)
   ["@" target]
   [abstract
    [hash (#+ Hash)]
    [monoid (#+ Monoid)]
    [equivalence (#+ Equivalence)]
    [codec (#+ Codec)]
    [predicate (#+ Predicate)]
    [order (#+ Order)]
    [monad (#+ do)]]
   [control
    ["." try (#+ Try)]]
   [data
    ["." maybe]
    ["." text]]]
  ["." // #_
   ["#." i64]
   ["#." nat]
   ["#." int]
   ["#." rev]
   ["/#" //]])

(def: #export (= reference sample)
  {#.doc "Frac(tion) equivalence."}
  (-> Frac Frac Bit)
  ("lux f64 =" reference sample))

(def: #export (< reference sample)
  {#.doc "Frac(tion) less-than."}
  (-> Frac Frac Bit)
  ("lux f64 <" reference sample))

(def: #export (<= reference sample)
  {#.doc "Frac(tion) less-than or equal."}
  (-> Frac Frac Bit)
  (or ("lux f64 <" reference sample)
      ("lux f64 =" reference sample)))

(def: #export (> reference sample)
  {#.doc "Frac(tion) greater-than."}
  (-> Frac Frac Bit)
  ("lux f64 <" sample reference))

(def: #export (>= reference sample)
  {#.doc "Frac(tion) greater-than or equal."}
  (-> Frac Frac Bit)
  (or ("lux f64 <" sample reference)
      ("lux f64 =" sample reference)))

(template [<comparison> <name>]
  [(def: #export <name>
     (Predicate Frac)
     (<comparison> +0.0))]

  [..> positive?]
  [..< negative?]
  [..= zero?]
  )

(template [<name> <op> <doc>]
  [(def: #export (<name> param subject)
     {#.doc <doc>}
     (-> Frac Frac Frac)
     (<op> param subject))]

  [+ "lux f64 +" "Frac(tion) addition."]
  [- "lux f64 -" "Frac(tion) substraction."]
  [* "lux f64 *" "Frac(tion) multiplication."]
  [/ "lux f64 /" "Frac(tion) division."]
  [% "lux f64 %" "Frac(tion) remainder."]
  )

(def: #export (/% param subject)
  (-> Frac Frac [Frac Frac])
  [(../ param subject)
   (..% param subject)])

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

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

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

(def: min_exponent -1022)
(def: max_exponent (//int.frac +1023))

(template [<name> <test> <doc>]
  [(def: #export (<name> left right)
     {#.doc <doc>}
     (-> Frac Frac Frac)
     (if (<test> right left)
       left
       right))]

  [min ..< "Frac(tion) minimum."]
  [max ..> "Frac(tion) minimum."]
  )

(def: #export nat
  (-> Frac Nat)
  (|>> "lux f64 i64" .nat))

(def: #export int
  (-> Frac Int)
  (|>> "lux f64 i64"))

(def: mantissa_size Nat 52)
(def: exponent_size Nat 11)

(def: frac_denominator
  (|> -1
      ("lux i64 right-shift" ..exponent_size)
      "lux i64 f64"))

(def: #export rev
  (-> Frac Rev)
  (|>> ..abs
       (..% +1.0)
       (..* ..frac_denominator)
       "lux f64 i64"
       ("lux i64 left-shift" ..exponent_size)))

(structure: #export equivalence
  (Equivalence Frac)
  
  (def: = ..=))

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

(def: #export smallest
  Frac
  (///.pow (//int.frac (//int.- (.int ..mantissa_size) ..min_exponent))
           +2.0))

(def: #export biggest
  Frac
  (let [f2^-52 (///.pow (//nat.frac (//nat.- ..mantissa_size 0)) +2.0)
        f2^+1023 (///.pow ..max_exponent +2.0)]
    (|> +2.0
        (..- f2^-52)
        (..* f2^+1023))))

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

  [addition       ..+   +0.0]
  [multiplication ..*   +1.0]
  [minimum        ..min ..biggest]
  [maximum        ..max (..* -1.0 ..biggest)]
  )

(for {@.python
      (template [<name> <constant> <doc>]
        [(def: #export <name>
           {#.doc <doc>}
           (|> <constant>
               ("python apply" (:coerce Nothing ("python constant" "float")))
               (:coerce Frac)))]

        [not_a_number      "NaN" "Not a number."]
        [positive_infinity "inf" "Positive infinity."]
        )}
     
     (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."]
       ))

(def: #export negative_infinity
  {#.doc "Negative infinity."}
  Frac
  (..* -1.0 ..positive_infinity))

(def: #export (not_a_number? number)
  {#.doc "Tests whether a frac is actually not-a-number."}
  (-> Frac Bit)
  (not (..= number number)))

(def: #export (number? value)
  (-> Frac Bit)
  (not (or (..not_a_number? value)
           (..= ..positive_infinity value)
           (..= ..negative_infinity value))))

(structure: #export decimal
  (Codec Text Frac)
  
  (def: (encode x)
    (case x
      -0.0 (let [output ("lux f64 encode" x)]
             (if (text.starts_with? "-" output)
               output
               ("lux text concat" "+" output)))
      _ (if (..< +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"))))

(def: log/2
  (-> Frac Frac)
  (|>> ///.log
       (../ (///.log +2.0))))

(def: double_bias Nat 1023)

(def: exponent_mask (//i64.mask ..exponent_size))

(def: exponent_offset ..mantissa_size)
(def: sign_offset (//nat.+ ..exponent_size ..exponent_offset))

(template [<cast> <hex> <name>]
  [(def: <name> (|> <hex> (\ //nat.hex decode) try.assume <cast>))]

  [.i64 "FFF8000000000000" not_a_number_bits]
  [.i64 "7FF0000000000000" positive_infinity_bits]
  [.i64 "FFF0000000000000" negative_infinity_bits]
  [.i64 "0000000000000000" positive_zero_bits]
  [.i64 "8000000000000000" negative_zero_bits]
  [.nat "7FF"              special_exponent_bits]
  )

(def: smallest_exponent
  (..log/2 ..smallest))

(def: #export (to_bits input)
  (-> Frac I64)
  (.i64 (cond (..not_a_number? input)
              ..not_a_number_bits

              (..= positive_infinity input)
              ..positive_infinity_bits

              (..= negative_infinity input)
              ..negative_infinity_bits

              (..= +0.0 input)
              (let [reciprocal (../ input +1.0)]
                (if (..= positive_infinity reciprocal)
                  ## Positive zero
                  ..positive_zero_bits
                  ## Negative zero
                  ..negative_zero_bits))

              ## else
              (let [sign_bit (if (..< -0.0 input)
                               1
                               0)
                    input (..abs input)
                    exponent (|> input
                                 ..log/2
                                 ///.floor
                                 (..min ..max_exponent))
                    min_gap (..- (//int.frac ..min_exponent) exponent)
                    power (|> (//nat.frac ..mantissa_size)
                              (..+ (..min +0.0 min_gap))
                              (..- exponent))
                    max_gap (..- ..max_exponent power)
                    mantissa (|> input
                                 (..* (///.pow (..min ..max_exponent power) +2.0))
                                 (..* (if (..> +0.0 max_gap)
                                        (///.pow max_gap +2.0)
                                        +1.0)))
                    exponent_bits (|> (if (..< +0.0 min_gap)
                                        (|> (..int exponent)
                                            (//int.- (..int min_gap))
                                            dec)
                                        (..int exponent))
                                      (//int.+ (.int ..double_bias))
                                      (//i64.and ..exponent_mask))
                    mantissa_bits (..int mantissa)]
                ($_ //i64.or
                    (//i64.left_shift ..sign_offset sign_bit)
                    (//i64.left_shift ..exponent_offset exponent_bits)
                    (//i64.clear ..mantissa_size mantissa_bits)))
              )))

(template [<getter> <size> <offset>]
  [(def: <getter>
     (-> (I64 Any) I64)
     (let [mask (|> 1 (//i64.left_shift <size>) dec (//i64.left_shift <offset>))]
       (|>> (//i64.and mask) (//i64.right_shift <offset>) .i64)))]

  [mantissa ..mantissa_size 0]
  [exponent ..exponent_size ..mantissa_size]
  [sign     1               ..sign_offset]
  )

(def: #export (from_bits input)
  (-> I64 Frac)
  (case [(: Nat (..exponent input))
         (: Nat (..mantissa input))
         (: Nat (..sign input))]
    (^ [(static ..special_exponent_bits) 0 0])
    ..positive_infinity

    (^ [(static ..special_exponent_bits) 0 1])
    ..negative_infinity

    (^ [(static ..special_exponent_bits) _ _])
    ..not_a_number

    ## Positive zero
    [0 0 0] +0.0
    ## Negative zero
    [0 0 1] (..* -1.0 +0.0)

    [E M S]
    (let [sign (if (//nat.= 0 S)
                 +1.0
                 -1.0)
          [mantissa power] (if (//nat.< ..mantissa_size E)
                             [(if (//nat.= 0 E)
                                M
                                (//i64.set ..mantissa_size M))
                              (|> E
                                  (//nat.- ..double_bias)
                                  .int
                                  (//int.max ..min_exponent)
                                  (//int.- (.int ..mantissa_size)))]
                             [(//i64.set ..mantissa_size M)
                              (|> E (//nat.- ..double_bias) (//nat.- ..mantissa_size) .int)])
          exponent (///.pow (//int.frac power) +2.0)]
      (|> (//nat.frac mantissa)
          (..* exponent)
          (..* sign)))))

(def: (split_exponent codec representation)
  (-> (Codec Text Nat) Text (Try [Text Int]))
  (case [("lux text index" 0 "e+" representation)
         ("lux text index" 0 "E+" representation)
         ("lux text index" 0 "e-" representation)
         ("lux text index" 0 "E-" representation)]
    (^template [<factor> <patterns>]
      [<patterns>
       (do try.monad
         [exponent (|> representation
                       ("lux text clip" (//nat.+ 2 split_index) ("lux text size" representation))
                       (\ codec decode))]
         (wrap [("lux text clip" 0 split_index representation)
                (//int.* <factor> (.int exponent))]))])
    ([+1 (^or [(#.Some split_index) #.None #.None #.None]
              [#.None (#.Some split_index) #.None #.None])]
     [-1 (^or [#.None #.None (#.Some split_index) #.None]
              [#.None #.None #.None (#.Some split_index)])])
    
    _
    (#try.Success [representation +0])))

(template [<struct> <nat> <int> <error>]
  [(structure: #export <struct>
     (Codec Text Frac)
     
     (def: (encode value)
       (let [bits (..to_bits value)
             mantissa (..mantissa bits)
             exponent (//int.- (.int ..double_bias) (..exponent bits))
             sign (..sign bits)]
         ($_ "lux text concat"
             (case (.nat sign)
               1 "-"
               0 "+"
               _ (undefined))
             (\ <nat> encode (.nat mantissa))
             ".0E"
             (\ <int> encode exponent))))

     (def: (decode representation)
       (let [negative? (text.starts_with? "-" representation)
             positive? (text.starts_with? "+" representation)]
         (if (or negative? positive?)
           (do {! try.monad}
             [[mantissa exponent] (..split_exponent <nat> representation)
              [whole decimal] (case ("lux text index" 0 "." mantissa)
                                (#.Some split_index)
                                (do !
                                  [decimal (|> mantissa
                                               ("lux text clip" (inc split_index) ("lux text size" mantissa))
                                               (\ <nat> decode))]
                                  (wrap [("lux text clip" 0 split_index mantissa)
                                         decimal]))

                                #.None
                                (#try.Failure ("lux text concat" <error> representation)))
              #let [whole ("lux text clip" 1 ("lux text size" whole) whole)]
              mantissa (\ <nat> decode (case decimal
                                         0 whole
                                         _ ("lux text concat" whole (\ <nat> encode decimal))))
              #let [sign (if negative? 1 0)]]
             (wrap (..from_bits
                    ($_ //i64.or
                        (//i64.left_shift ..sign_offset (.i64 sign))
                        (//i64.left_shift ..mantissa_size (.i64 (//int.+ (.int ..double_bias) exponent)))
                        (//i64.clear ..mantissa_size (.i64 mantissa))))))
           (#try.Failure ("lux text concat" <error> representation))))))]

  [binary //nat.binary //int.binary "Invalid binary syntax: "]
  [octal //nat.octal //int.octal "Invalid octaladecimal syntax: "]
  [hex //nat.hex //int.hex "Invalid hexadecimal syntax: "]
  )

(structure: #export hash
  (Hash Frac)
  
  (def: &equivalence ..equivalence)
  (def: hash ..to_bits))

(def: #export (approximately? margin_of_error standard value)
  (-> Frac Frac Frac Bit)
  (|> value
      (..- standard)
      ..abs
      (..< margin_of_error)))

(def: #export (mod divisor dividend)
  (All [m] (-> Frac Frac Frac))
  (let [remainder (..% divisor dividend)]
    (if (or (and (..< +0.0 divisor)
                 (..> +0.0 remainder))
            (and (..> +0.0 divisor)
                 (..< +0.0 remainder)))
      (..+ divisor remainder)
      remainder)))