;;  A basis for rational arithmetic with infinities
;;  constructed by overloading generic arithmetic. 
;;  Richard Fateman, November, 2005

(defpackage :ra				;uses generic arithmetic
  (:use :ga :cl)
  (:shadowing-import-from 
   :ga
   "+" "-" "/" "*" "expt"		;binary arith
   "=" "/=" ">" "<" "<=" ">="		;binary comparisons
   "1-" "1+" "abs"
   )
    
  (:export "ri" "union" "intersection"))

(require "ga")
(in-package :ra)

(defstruct (ra (:constructor ra (n d )))n d ) ;structure for rational

(defun into(num  &optional (den  1 denp))
  ;; into takes 2 args, num and denom,  or just one, a number
  (if (not denp) (let ((r (rational num)))
		   (ra (numerator r)(denominator r)))
    ;; there is a denominator
    (let* ((a (rational num))
	   (b (rational den))
	   (n (* (numerator a)(denominator b)))
	   ( d (* (numerator b)(denominator a)))
	   ;(g (gcd n d))
	   )
      (reducera n d))))
 

;;; try (into -5 0) (into 5 0) (into 0 5) (into 1 2) (into 1/2) (into -6 3)
;;; should we make (into 2)  just 2?


      
      
    
  

(defmethod print-object ((a ra) stream)
  (format stream "[~a/~a]"  (ra-n a)(ra-d a)))


;; must figure out ra version of sin, cos, tan, etc.
;;  for infinity and nan.
;; must figure out =, >, <, 

;; from Graham, On Lisp, macro hackery
(defun mkstr (&rest args)
  (with-output-to-string (s)(dolist (a args) (princ a s))))

(defun symb (&rest args) (values (intern (apply #'mkstr args))))

(defmacro with-struct ((name . fields) struct &body body)
  (let ((gs (gensym)))
    `(let ((,gs ,struct))
      (let ,(mapcar #'(lambda (f)
			`(,f (,(symb name f) ,gs)))
		    fields)
	,@body))))
;;; based on...
;;;from Figure 18.3: Destructuring on structures. from On Lisp, P. Graham

;; take 2 rationals and grab their insides.

(defmacro with-ra2 (struct1 struct2 names1 names2 &body body)
  (let ((gs1 (gensym))
	(gs2 (gensym)))
    `(let ((,gs1 ,struct1)
	   (,gs2 ,struct2))
       (let ,(append 
	      (mapcar #'(lambda (f field)
			  `(,f (,(symb "ra-" field) ,gs1)))
		      names1
		      '(n d))
	      (mapcar #'(lambda (f field)
			  `(,f (,(symb "ra-" field) ,gs2)))
		      names2
		      '(n d)))
	 ,@body))))

(defmacro with-ra (struct1 names1 &body body)
  (let ((gs1 (gensym)))
    `(let ((,gs1 ,struct1))
       (let  ,(mapcar #'(lambda (f field)
			  `(,f (,(symb "ra-" field) ,gs1)))
		      names1
		      '(n d))
	 ,@body))))

(defmethod ga::two-arg-+ ((r ra)(s ra))
  ;; adding 2 rationals,  a/b+c/d --> (a*d+c*b)/(b*d), reduced
  (with-ra2 r s (a b)(c d) 
	    (reducera (+ (* a d)(* c b))
		      (* b d))))

(defmethod ga::two-arg-+ ((r ra)(s integer))
  ;; adding 2 rational+ number,  a/b+s --> (a+s*b)/b, reduced
  (with-ra r (a b)
	    (reducera (+ a(* s b))
		      b)))

(defmethod ga::two-arg-+ ((s integer)(r ra))
  ;; adding 2 rational+ number,  a/b+s --> (a+s*b)/b, reduced
  (with-ra r (a b)
	    (reducera (+ a (* s b))
		  b)))

(defun reducera (num den)
 (let  ((comfac (gcd num den))) ;common factor
   (cond ((= num 0) (if (= den 0) (ra 0 0) 0)) ;; or  (ra 0 1) ?
	 ((= den 0) (ra (signum num) 0))
	 ;;((= comfac 0) (ra (signum num) 0))

	 ((= comfac den) (/ num comfac)) ;; reduce to integer.
	 ((< den 0) (ra (/ (- num) comfac)(/ (- den) comfac)))
	 (t (ra (/  num comfac)(/ den comfac))))))
 
(defmethod ga::two-arg-* ((r ra)(s ra))
  (with-ra2 r s (a b)(c d)
	      (reducera (* a c)
			(* b d))))

(defmethod ga::two-arg-* ((r ra)(s integer))
  (with-ra r  (a b)
	      (reducera (* a s)
			b)))

(defmethod ga::two-arg-* ((s integer)(r ra))
  (with-ra r  (a b)
	      (reducera (* a s)
			b)))

(defmethod ga::two-arg-/ ((r ra) (s integer))
  (* r (ra 1 s)))

(defmethod ga::two-arg-/ ( (s integer)(r ra))
  (with-ra r (a b) (reducera (* s b) a)))

(defmethod ga::two-arg-/ ((r ra) (s ra))
   (with-ra2 r s (a b)(c d)
	      (reducera (* a d)
			(* b c))))


;; need two-arg-- 
;; need to do more stuff for sin cos etc.

(defmethod ga::sin ((s ra))
  (with-ra  s (n d)
	    (if (/= d 0) (cl::sin (/ n d))
	      (error "please fix program for */0 rational  sin ~s" s))))