(context 'Q)

;; rational library functions written by Eddie Rucker September 24, 2004
;;
;; Updated on November 30, 2004. The relations were not working properly
;; major code cleanup
;; Updated on December 7th, 2006. Now uses built-in 'gcd' introduced in 9.0
;;
;; This library has no warranty of any kind
;;
;; include the library by adding (load "rational.lsp") before use
;;
;; rational numbers can have the form
;; a        :: integer
;; '(a)     :: integer
;; '(a b)   :: a = numerator, b = denominator
;; '(a b c) :: mixed number a = whole part, b = numerator, c = denominator
;; 
;; rational numbers must NOT be quoted
;; example
;; (Q:+ 1 '(-1 2) '(1 1 2)) => 2
;; (Q:+ '(1 2) '(1 3)) => (5 6)
;;
;; operators
;; Q:+  :: add rationals - multiple arguments
;; Q:-  :: subtract rationals - multiple arguments
;; Q:*  :: multiply rationals - multiple arguments
;; Q:/  :: divide rationals - multiple arguments
;; Q:neg :: take the opposite of a rational - single argument
;; Q:abs :: take the absolute value of a rational - single argument
;; Q:recip :: take the reciprical of a rational - single argument
;; Q:min :: return the smallest rational value - multiple arguments
;; Q:max :: return the largest rational value - multiple arguments
;;
;; relations
;; Q:=  :: compare rationals for equality (multiple arguments)
;; Q:!=  :: not equals with multiple arguments
;; Q:<  :: less than with multiple arguments
;; Q:>  :: greater than with multiple arguments
;; Q:<=  :: less than or equal to with multiple arguments
;; Q:>=  :: greater than or equal to with multiple arguments

(define (frac-form a b)
  ;; fix negatives so that -a/-b => a/b, a/-b => -a/b
  (if 
    (= a 0)  '(0 1)
    (= b 0)  (throw "rational-number-error")
    (and (< a 0) (< b 0))  (list (MAIN:abs a) (MAIN:abs b))
    (and (>= a 0) (< b 0))  (list (MAIN:abs a) (MAIN:abs b))
    (list a b)))

(define (improper A)
  ;; convert a -> a/1 and  a b/c -> (c*a+b)/c
  (apply frac-form
	 (if (integer? A)
	     (list A 1)
	   (case (length A)
	     (1 (list (first A) 1))
	     (2 A)
	     (3 (list (+ (nth 1 A) (* (first A) (last A))) (last A)))
	     (throw "rational-number-error")))))

(define (reduce-frac A)
  (letn (a (first A) b (last A) dd (gcd (MAIN:abs a) b))
    (if (= dd b)
	(/ a dd)
      (list (/ a dd) (/ b dd)))))

(define (neg_ A)
  (list (- 0 (first A)) (last A)))

(define (add_ A B)
  (let (n0 (first A) d0 (last A) n1 (first B) d1 (last B))
    (list (+ (* n0 d1) (* n1 d0)) (* d0 d1))))

(define (sub_ A B)
  (add_ A (neg_ B)))

(define (mul_ A B)
  (let (n0 (first A) d0 (last A) n1 (first B) d1 (last B))
    (list (* n0 n1) (* d0 d1))))

(define (recip_ A)
  (list (last A) (first A)))

(define (div_ A B)
  (mul_ A (recip_ B)))

(define (min_ A B)
  (if (< (* (first A) (last B)) (* (first B) (last A)))  A  B))

(define (max_ A B)
  (if (> (* (first A) (last B)) (* (first B) (last A)))  A  B))

(define (bop sm vals)
  ;; binary operator
  (reduce-frac (apply sm (map improper vals) 2)))

(define (uop sm val)
  ;; unary operator
  (reduce-frac (sm (improper val))))

(define (rel_ sm a b L tf)
  (if 
    (= tf nil) nil
    (= L '()) tf
    (let (n (first (first L)) d (last (first L)))
      (rel_ sm n d (rest L) (sm (* a d) (* b n))))))

(define (rel sm vals)
  (let (L (map improper vals))
    (rel_ sm (first (first L)) (last (first L)) (rest L) true)))

;; functions for use in  Q
(constant 'Q:+ (lambda-macro () (bop add_ (map eval (args)))))
(constant 'Q:- (lambda-macro () (bop sub_ (map eval (args)))))
(constant 'Q:* (lambda-macro () (bop mul_ (map eval (args)))))
(constant 'Q:/ (lambda-macro () (bop div_ (map eval (args)))))
(constant 'Q:min (lambda-macro () (bop min_ (map eval (args)))))
(constant 'Q:max (lambda-macro () (bop max_ (map eval (args)))))

(constant 'Q:= (lambda-macro () (rel MAIN:= (map eval (args)))))
(constant 'Q:!= (lambda-macro () (not (rel MAIN:= (map eval (args))))))
(constant 'Q:< (lambda-macro () (rel MAIN:< (map eval (args)))))
(constant 'Q:> (lambda-macro () (rel MAIN:> (map eval (args)))))
(constant 'Q:<= (lambda-macro () (rel MAIN:<= (map eval (args)))))
(constant 'Q:>= (lambda-macro () (rel MAIN:>= (map eval (args)))))

(constant 'Q:abs (fn (A) (list (MAIN:abs (first A)) (MAIN:abs (last A)))))
(constant 'Q:neg (fn (A) (uop neg_ A)))
(constant 'Q:recip (fn (A) (uop recip_ A)))

(context 'MAIN)