;; -*-theme-d-*-

;; Copyright (C) 2018 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(define-body (standard-library rational)

  (import (standard-library basic-math)
	  (standard-library bitwise-arithmetic)
	  (standard-library string-utilities))

  (define-simple-proc rational (((i-numer <integer>) (i-denom <integer>))
				<rational> pure)
    (cond
     ((equal? i-denom 0)
      (raise-numerical-overflow 'rational))
     ((equal? i-numer 0)
      (make <rational> 0 1))
     (else
      (let* ((i-gcd (gcd i-numer i-denom))
	     (i-numer1 (quotient i-numer i-gcd))
	     (i-denom1 (quotient i-denom i-gcd))
	     (i-numer2 (if (> i-denom1 0) i-numer1 (- i-numer1)))
	     (i-denom2 (i-abs i-denom1)))
	(make <rational> i-numer2 i-denom2)))))

  (define-simple-proc numerator (((rat <rational>)) <integer> pure)
    (field-ref rat 'i-numer))

  (define-simple-proc denominator (((rat <rational>)) <integer> pure)
    (field-ref rat 'i-denom))

  (define-simple-proc rational=? (((rat1 <rational>) (rat2 <rational>))
				  <boolean> pure)
    (integer=? (* (field-ref rat1 'i-numer) (field-ref rat2 'i-denom))
	       (* (field-ref rat2 'i-numer) (field-ref rat1 'i-denom))))

  ;; Procedures integer= and integer=? should work identically.

  (define-simple-proc rational= (((rat1 <rational>) (rat2 <rational>))
				 <boolean> pure)
    (integer= (* (field-ref rat1 'i-numer) (field-ref rat2 'i-denom))
	      (* (field-ref rat2 'i-numer) (field-ref rat1 'i-denom))))
  
  (define-simple-proc rational-integer= (((rat <rational>) (i <integer>))
					  <boolean> pure)
    (integer= (field-ref rat 'i-numer)
	      (* (field-ref rat 'i-denom) i)))

  (define-simple-proc integer-rational= (((i <integer>) (rat <rational>))
					  <boolean> pure)
    (integer= (field-ref rat 'i-numer)
	      (* i (field-ref rat 'i-denom))))

  (define-simple-proc rational< (((rat1 <rational>) (rat2 <rational>))
				  <boolean> pure)
    (let ((i-numer1 (* (i-sign (field-ref rat1 'i-denom))
		       (field-ref rat1 'i-numer)))
	  (i-numer2 (* (i-sign (field-ref rat2 'i-denom))
		       (field-ref rat2 'i-numer)))
	  (i-denom1 (abs (field-ref rat1 'i-denom)))
	  (i-denom2 (abs (field-ref rat2 'i-denom))))
      (< (* i-denom2 i-numer1) (* i-denom1 i-numer2))))

  (define-simple-proc rational-integer< (((rat <rational>) (i <integer>))
					 <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (< i-numer (* i-denom i))))

  (define-simple-proc integer-rational< (((i <integer>) (rat <rational>))
					 <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (< (* i i-denom) i-numer)))

  (define-simple-proc rational<= (((rat1 <rational>) (rat2 <rational>))
				  <boolean> pure)
    (let ((i-numer1 (* (i-sign (field-ref rat1 'i-denom))
		       (field-ref rat1 'i-numer)))
	  (i-numer2 (* (i-sign (field-ref rat2 'i-denom))
		       (field-ref rat2 'i-numer)))
	  (i-denom1 (abs (field-ref rat1 'i-denom)))
	  (i-denom2 (abs (field-ref rat2 'i-denom))))
      (<= (* i-denom2 i-numer1) (* i-denom1 i-numer2))))

  (define-simple-proc rational-integer<= (((rat <rational>) (i <integer>))
					 <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (<= i-numer (* i-denom i))))

  (define-simple-proc integer-rational<= (((i <integer>) (rat <rational>))
					 <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (<= (* i i-denom) i-numer)))

  (define-simple-proc rational> (((rat1 <rational>) (rat2 <rational>))
				  <boolean> pure)
    (let ((i-numer1 (* (i-sign (field-ref rat1 'i-denom))
		       (field-ref rat1 'i-numer)))
	  (i-numer2 (* (i-sign (field-ref rat2 'i-denom))
		       (field-ref rat2 'i-numer)))
	  (i-denom1 (abs (field-ref rat1 'i-denom)))
	  (i-denom2 (abs (field-ref rat2 'i-denom))))
      (> (* i-denom2 i-numer1) (* i-denom1 i-numer2))))

  (define-simple-proc rational-integer> (((rat <rational>) (i <integer>))
					 <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (> i-numer (* i-denom i))))

  (define-simple-proc integer-rational> (((i <integer>) (rat <rational>))
					 <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (> (* i i-denom) i-numer)))

  (define-simple-proc rational>= (((rat1 <rational>) (rat2 <rational>))
				  <boolean> pure)
    (let ((i-numer1 (* (i-sign (field-ref rat1 'i-denom))
		       (field-ref rat1 'i-numer)))
	  (i-numer2 (* (i-sign (field-ref rat2 'i-denom))
		       (field-ref rat2 'i-numer)))
	  (i-denom1 (abs (field-ref rat1 'i-denom)))
	  (i-denom2 (abs (field-ref rat2 'i-denom))))
      (>= (* i-denom2 i-numer1) (* i-denom1 i-numer2))))

  (define-simple-proc rational-integer>= (((rat <rational>) (i <integer>))
					  <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (>= i-numer (* i-denom i))))

  (define-simple-proc integer-rational>= (((i <integer>) (rat <rational>))
					  <boolean> pure)
    (let ((i-numer (* (i-sign (field-ref rat 'i-denom))
		      (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (>= (* i i-denom) i-numer)))

  (define-simple-proc simplify-rational (((rat <rational>)) <rational> pure)
    (let ((i-numer (field-ref rat 'i-numer))
	  (i-denom (field-ref rat 'i-denom)))
      (cond
       ((= i-numer 0) (make <rational> 0 1))
       ((= i-denom 0) (raise-numerical-overflow 'simplify-rational))
       (else
	(let* ((i-gcd (i-abs (gcd i-numer i-denom)))
	       ;; The call to i-abs may be unnecessary.
	       (i-numer1 (* (i-sign i-denom) (quotient i-numer i-gcd)))
	       (i-denom1 (quotient (i-abs i-denom) i-gcd)))
	  (make <rational> i-numer1 i-denom1))))))

  (define-simple-proc rat-integer-valued? (((rat <rational>)) <boolean> pure)
    (let ((rat1 (simplify-rational rat)))
      (equal? (field-ref rat1 'i-denom) 1)))

  (define-simple-proc rat-sign (((rat <rational>)) <integer> pure)
    (* (i-sign (field-ref rat 'i-numer)) (i-sign (field-ref rat 'i-denom))))

  (define-simple-proc integer->rational (((i <integer>)) <rational> pure)
    (make <rational> i 1))

  (define-simple-proc rational->integer (((rat <rational>)) <integer> pure)
    (let ((rat1 (simplify-rational rat)))
      (if (equal? (field-ref rat1 'i-denom) 1)
	  (field-ref rat1 'i-numer)
	  (raise-simple 'rational->integer:not-an-integer))))

  (define-simple-proc rat-zero (() <rational> pure)
    (make <rational> 0 1))

  (define-simple-proc rat-one (() <rational> pure)
    (make <rational> 1 1))

  (define-simple-proc rat-zero? (((rat <rational>)) <boolean> pure)
    (let ((i-numer (field-ref rat 'i-numer))
	  (i-denom (field-ref rat 'i-denom)))
      (if (equal? i-denom 0)
	  (raise-numerical-overflow 'rat-zero?)
	  (equal? i-numer 0))))

  (define-simple-proc rat-one? (((rat <rational>)) <boolean> pure)
    (let ((i-numer (field-ref rat 'i-numer))
	  (i-denom (field-ref rat 'i-denom)))
      (if (equal? i-denom 0)
	  (raise-numerical-overflow 'rat-one?)
	  (equal? i-numer i-denom))))

  (define-simple-proc rational+ (((rat1 <rational>) (rat2 <rational>))
				 <rational> pure)
    (let ((i-numer1 (field-ref rat1 'i-numer))
	  (i-denom1 (field-ref rat1 'i-denom))
	  (i-numer2 (field-ref rat2 'i-numer))
	  (i-denom2 (field-ref rat2 'i-denom)))
      (rational (+ (* i-numer1 i-denom2) (* i-numer2 i-denom1))
		(* i-denom1 i-denom2))))

  (define-simple-proc rational-integer+ (((rat <rational>) (i <integer>))
					 <rational> pure)
    (rational (+ (field-ref rat 'i-numer) (* i (field-ref rat 'i-denom)))
	      (field-ref rat 'i-denom)))

  (define-simple-proc integer-rational+ (((i <integer>) (rat <rational>))
					 <rational> pure)
    (rational (+ (* i (field-ref rat 'i-denom)) (field-ref rat 'i-numer))
	      (field-ref rat 'i-denom)))

  (define-simple-proc rational- (((rat1 <rational>) (rat2 <rational>))
				 <rational> pure)
    (let ((i-numer1 (field-ref rat1 'i-numer))
	  (i-denom1 (field-ref rat1 'i-denom))
	  (i-numer2 (field-ref rat2 'i-numer))
	  (i-denom2 (field-ref rat2 'i-denom)))
      (rational (- (* i-numer1 i-denom2) (* i-numer2 i-denom1))
		(* i-denom1 i-denom2))))

  (define-simple-proc rational-integer- (((rat <rational>) (i <integer>))
					 <rational> pure)
    (rational (- (field-ref rat 'i-numer) (* i (field-ref rat 'i-denom)))
	      (field-ref rat 'i-denom)))

  (define-simple-proc integer-rational- (((i <integer>) (rat <rational>))
					 <rational> pure)
    (rational (- (* i (field-ref rat 'i-denom)) (field-ref rat 'i-numer))
	      (field-ref rat 'i-denom)))

  (define-simple-proc rational* (((rat1 <rational>) (rat2 <rational>))
				 <rational> pure)
    (rational (* (field-ref rat1 'i-numer) (field-ref rat2 'i-numer))
	      (* (field-ref rat1 'i-denom) (field-ref rat2 'i-denom))))

  (define-simple-proc rational-integer* (((rat <rational>) (i <integer>))
					 <rational> pure)
    (rational (* (field-ref rat 'i-numer) i)
	      (field-ref rat 'i-denom)))

  (define-simple-proc integer-rational* (((i <integer>) (rat <rational>))
					 <rational> pure)
    (rational (* i (field-ref rat 'i-numer))
	      (field-ref rat 'i-denom)))

  (define-simple-proc rational/ (((rat1 <rational>) (rat2 <rational>))
				 <rational> pure)
    (rational (* (field-ref rat1 'i-numer) (field-ref rat2 'i-denom))
	      (* (field-ref rat1 'i-denom) (field-ref rat2 'i-numer))))

  (define-simple-proc rational-integer/ (((rat <rational>) (i <integer>))
					 <rational> pure)
    (rational (field-ref rat 'i-numer)
	      (* (field-ref rat 'i-denom) i)))

  (define-simple-proc integer-rational/ (((i <integer>) (rat <rational>))
					 <rational> pure)
    (rational (* i (field-ref rat 'i-denom))
	      (field-ref rat 'i-numer)))

  (define-simple-proc rat-neg (((rat <rational>)) <rational> pure)
    (make <rational> (- (field-ref rat 'i-numer)) (field-ref rat 'i-denom)))

  (define-simple-proc rat-abs (((rat <rational>)) <rational> pure)
    (make <rational>
	  (abs (field-ref rat 'i-numer))
	  (abs (field-ref rat 'i-denom))))

  (define-simple-proc rat-square (((rat <rational>)) <rational> pure)
    ;; If the gcd of the numerator and the denominator is 1 also
    ;; the gcd of the squares is 1.
    (make <rational>
	  (square (field-ref rat 'i-numer))
	  (square (field-ref rat 'i-denom))))

  (define-simple-proc rat-inverse (((rat <rational>)) <rational> pure)
    (if (equal? (field-ref rat 'i-numer) 0)
	(raise-numerical-overflow 'rat-inverse)
	(make <rational>
	      (* (rat-sign rat) (field-ref rat 'i-denom))
	      (abs (field-ref rat 'i-numer)))))

  (define-simple-proc rat-nonneg-int-expt
      (((rat-base <rational>) (i-exponent <integer>)) <rational> pure)
    (assert (>= i-exponent 0))
    (let-mutable ((i-cur-exponent <integer> i-exponent)
		  (rat-cur-base <rational> rat-base)
		  (rat-sum <rational> (rat-one)))
      (until ((or (equal? i-cur-exponent 0) (equal? i-cur-exponent 1)))
	(if (not (equal? (bitwise-and i-cur-exponent 1) 0))
	    (set! rat-sum (* rat-sum rat-cur-base)))
	(set! rat-cur-base (square rat-cur-base))
	(set! i-cur-exponent (ash i-cur-exponent -1)))
      (cond
       ((= i-cur-exponent 0) rat-sum)
       ((= i-cur-exponent 1) (* rat-sum rat-cur-base))
       (else (raise-simple 'rat-nonneg-int-expt:internal-error)))))

  (define-simple-proc rat-int-expt
      (((rat-base <rational>) (i-exponent <integer>)) <rational> pure)
    (if (>= i-exponent 0)
	(rat-nonneg-int-expt rat-base i-exponent)
	(rat-nonneg-int-expt (rat-inverse rat-base) (- i-exponent))))

  (define-simple-proc i-expt
      (((i-base <integer>) (i-exponent <integer>)) <rational-number> pure)
    (if (>= i-exponent 0)
	(i-nonneg-expt i-base i-exponent)
	(if (equal? i-base 0)
	    (raise-numerical-overflow 'i-expt)
	    (make <rational> 1 (i-nonneg-expt i-base (i-abs i-exponent))))))

  (define-simple-proc rat-log10-exact (((rat <rational>)) (:maybe <integer>)
				       pure)
    (let* ((rat-s (simplify-rational rat))
	   (i-numer (numerator rat-s))
	   (i-denom (denominator rat-s)))
      (cond
       ((equal? i-denom 1)
	(if (>= i-numer 1)
	    (i-log10-exact i-numer)
	    null))
       ((equal? i-numer 1)
	;; The following test is unnecessary since rat-s is simplified.
	(if (>= i-denom 1)
	    (let ((i1 (i-log10-exact i-denom)))
	      (match-type-strong i1
		((<null>) null)
		((i2 <integer>) (- i2))))
	    null))
       (else null))))
  
  (define-simple-proc rat-log2-exact (((rat <rational>)) (:maybe <integer>)
				      pure)
    (let* ((rat-s (simplify-rational rat))
	   (i-numer (numerator rat-s))
	   (i-denom (denominator rat-s)))
      (cond
       ((equal? i-denom 1)
	(if (>= i-numer 1)
	    (i-log2-exact i-numer)
	    null))
       ((equal? i-numer 1)
	;; The following test is unnecessary since rat-s is simplified.
	(if (>= i-denom 1)
	    (let ((i1 (i-log2-exact i-denom)))
	      (match-type-strong i1
		((<null>) null)
		((i2 <integer>) (- i2))))
	    null))
       (else null))))

  (add-method equal? rational=?)
  (add-method = rational=)
  (add-method = rational-integer=)
  (add-method = integer-rational=)

  (define-simple-method < (((rat1 <rational-number>) (rat2 <rational-number>))
			   <boolean> pure)
    (raise-simple '<:dispatch-error))

  (add-method < rational<)
  (add-method < rational-integer<)
  (add-method < integer-rational<)

  (define-simple-method <= (((rat1 <rational-number>) (rat2 <rational-number>))
			    <boolean> pure)
    (raise-simple '<=:dispatch-error))

  (add-method <= rational<=)
  (add-method <= rational-integer<=)
  (add-method <= integer-rational<=)

  (define-simple-method > (((rat1 <rational-number>) (rat2 <rational-number>))
			   <boolean> pure)
    (raise-simple '>:dispatch-error))

  (add-method > rational>)
  (add-method > rational-integer>)
  (add-method > integer-rational>)

  (define-simple-method >= (((rat1 <rational-number>) (rat2 <rational-number>))
			    <boolean> pure)
    (raise-simple '>=:dispatch-error))

  (add-method >= rational>=)
  (add-method >= rational-integer>=)
  (add-method >= integer-rational>=)

  (define-simple-method + (((rat1 <rational-number>) (rat2 <rational-number>))
			   <rational-number> pure)
    (raise-simple '+:dispatch-error))

  (add-method + rational+)
  (add-method + rational-integer+)
  (add-method + integer-rational+)

  (define-simple-method - (((rat1 <rational-number>) (rat2 <rational-number>))
			   <rational-number> pure)
    (raise-simple '-:dispatch-error))

  (add-method - rational-)
  (add-method - rational-integer-)
  (add-method - integer-rational-)

  (define-simple-method * (((rat1 <rational-number>) (rat2 <rational-number>))
			   <rational-number> pure)
    (raise-simple '*:dispatch-error))

  (add-method * rational*)
  (add-method * rational-integer*)
  (add-method * integer-rational*)

  (define-simple-method / (((rat1 <rational-number>) (rat2 <rational-number>))
			   <rational-number> pure)
    (raise-simple '/:dispatch-error))

  (add-method / rational/)
  (add-method / rational-integer/)
  (add-method / integer-rational/)

  ;; Division of two integer numbers resulting a rational value.
  (add-method / rational)

  (define-simple-method - (((rat <rational-number>)) <rational-number> pure)
    (raise-simple 'unary-:dispatch-error))

  (add-method - rat-neg)

  (define-simple-method abs (((rat <rational-number>)) <rational-number> pure)
    (raise-simple 'abs:dispatch-error))

  (add-method abs rat-abs)

  (define-simple-method square (((rat <rational-number>)) <rational-number>
				pure)
    (raise-simple 'square:dispatch-error))

  (add-method square rat-square)

  (define-simple-method sign (((rat <rational-number>)) <integer>
			      pure)
    (raise-simple 'sign:dispatch-error))

  (add-method sign rat-sign)

  (define-simple-proc rational->string
      (((rat <rational>)) <string> pure)
    (let ((i-sign (rat-sign rat))
	  (i-numer (abs (field-ref rat 'i-numer)))
	  (i-denom (abs (field-ref rat 'i-denom))))
      (string-append
       (if (equal? i-sign -1) "-" "")
       (integer->string i-numer)
       "/"
       (integer->string i-denom))))

  (add-method object->string rational->string))
