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

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

(def: .public (= reference sample)
  (-> Frac Frac Bit)
  ("lux f64 =" reference sample))

(def: .public (< reference sample)
  (-> Frac Frac Bit)
  ("lux f64 <" reference sample))

(def: .public (<= reference sample)
  (-> Frac Frac Bit)
  (or ("lux f64 <" reference sample)
      ("lux f64 =" reference sample)))

(def: .public (> reference sample)
  (-> Frac Frac Bit)
  ("lux f64 <" sample reference))

(def: .public (>= reference sample)
  (-> Frac Frac Bit)
  (or ("lux f64 <" sample reference)
      ("lux f64 =" sample reference)))

(template [<comparison> <name>]
  [(def: .public <name>
     (Predicate Frac)
     (<comparison> +0.0))]

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

(template [<name> <op>]
  [(def: .public (<name> param subject)
     (-> Frac Frac Frac)
     (<op> param subject))]

  [+ "lux f64 +"]
  [- "lux f64 -"]
  [* "lux f64 *"]
  [/ "lux f64 /"]
  [% "lux f64 %"]
  )

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

(def: .public opposite
  (-> Frac Frac)
  (..* -1.0))

(def: .public (abs it)
  (-> Frac Frac)
  (if (..< +0.0 it)
    (..* -1.0 it)
    it))

(def: .public (signum it)
  (-> Frac Frac)
  (cond (..= +0.0 it) +0.0
        (..< +0.0 it) -1.0
        ... else
        +1.0))

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

(template [<name> <test>]
  [(def: .public (<name> left right)
     (-> Frac Frac Frac)
     (if (<test> right left)
       left
       right))]

  [min ..<]
  [max ..>]
  )

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

(def: .public 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: .public rev
  (-> Frac Rev)
  (|>> ..abs
       (..% +1.0)
       (..* ..frac_denominator)
       "lux f64 i64"
       ("lux i64 left-shift" ..exponent_size)))

(implementation: .public equivalence
  (Equivalence Frac)
  
  (def: = ..=))

(implementation: .public order
  (Order Frac)
  
  (def: &equivalence ..equivalence)
  (def: < ..<))

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

(def: .public 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> <composite> <identity>]
  [(implementation: .public <name>
     (Monoid Frac)
     
     (def: identity <identity>)
     (def: composite <composite>))]

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

(template [<name> <numerator>]
  [(def: .public <name>
     Frac
     (../ +0.0 <numerator>))]

  [not_a_number      +0.0]
  [positive_infinity +1.0]
  )

(def: .public negative_infinity
  Frac
  (..* -1.0 ..positive_infinity))

(def: .public (not_a_number? it)
  (-> Frac Bit)
  (not (..= it it)))

(def: .public (number? it)
  (-> Frac Bit)
  (not (or (..not_a_number? it)
           (..= ..positive_infinity it)
           (..= ..negative_infinity it))))

(implementation: .public decimal
  (Codec Text Frac)
  
  (def: (encoded 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: (decoded 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 decoded)
         try.trusted
         <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: .public (bits it)
  (-> Frac I64)
  (.i64 (cond (..not_a_number? it)
              ..not_a_number_bits

              (..= positive_infinity it)
              ..positive_infinity_bits

              (..= negative_infinity it)
              ..negative_infinity_bits

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

              ... else
              (let [sign_bit (if (..< -0.0 it)
                               1
                               0)
                    it (..abs it)
                    exponent (|> it
                                 ..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 (|> it
                                 (..* (///.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))
                                            --)
                                        (..int exponent))
                                      (//int.+ (.int ..double_bias))
                                      (//i64.and ..exponent_mask))
                    mantissa_bits (..int mantissa)]
                ($_ //i64.or
                    (//i64.left_shifted ..sign_offset sign_bit)
                    (//i64.left_shifted ..exponent_offset exponent_bits)
                    (//i64.zero ..mantissa_size mantissa_bits)))
              )))

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

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

(def: .public (of_bits it)
  (-> I64 Frac)
  (case [(: Nat (..exponent it))
         (: Nat (..mantissa it))
         (: Nat (..sign it))]
    (^ [(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.one ..mantissa_size M))
                              (|> E
                                  (//nat.- ..double_bias)
                                  .int
                                  (//int.max ..min_exponent)
                                  (//int.- (.int ..mantissa_size)))]
                             [(//i64.one ..mantissa_size M)
                              (|> E (//nat.- ..double_bias) (//nat.- ..mantissa_size) .int)])
          exponent (///.pow (//int.frac power) +2.0)]
      (|> (//nat.frac mantissa)
          (..* exponent)
          (..* sign)))))

(def: (representation_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
         [.let [after_offset (//nat.+ 2 split_index)
                after_length (//nat.- after_offset ("lux text size" representation))]
          exponent (|> representation
                       ("lux text clip" after_offset after_length)
                       (\ codec decoded))]
         (in [("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>]
  [(implementation: .public <struct>
     (Codec Text Frac)
     
     (def: (encoded value)
       (let [bits (..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> encoded (.nat mantissa))
             ".0E"
             (\ <int> encoded exponent))))

     (def: (decoded representation)
       (let [negative? (text.starts_with? "-" representation)
             positive? (text.starts_with? "+" representation)]
         (if (or negative? positive?)
           (do [! try.monad]
             [[mantissa exponent] (..representation_exponent <nat> representation)
              [whole decimal] (case ("lux text index" 0 "." mantissa)
                                (#.Some split_index)
                                (do !
                                  [.let [after_offset (++ split_index)
                                         after_length (//nat.- after_offset ("lux text size" mantissa))]
                                   decimal (|> mantissa
                                               ("lux text clip" after_offset after_length)
                                               (\ <nat> decoded))]
                                  (in [("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> decoded (case decimal
                                          0 whole
                                          _ ("lux text concat" whole (\ <nat> encoded decimal))))
              .let [sign (if negative? 1 0)]]
             (in (..of_bits
                  ($_ //i64.or
                      (//i64.left_shifted ..sign_offset (.i64 sign))
                      (//i64.left_shifted ..mantissa_size (.i64 (//int.+ (.int ..double_bias) exponent)))
                      (//i64.zero ..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: "]
  )

(implementation: .public hash
  (Hash Frac)
  
  (def: &equivalence ..equivalence)
  (def: hash ..bits))

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

(def: .public (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)))