;;  A basis for rational arithmetic with infinities
;;  constructed by overloading generic arithmetic. 
;;  Richard Fateman, November, 2005
;;
;; this is the PROJECTIVE model that has only ONE INFINITY.
;; Think of the numbers on a big wheel with 0 at the top, infinity
;; at the bottom.  Or since 0 has no sign, 1/0 has no sign.

;; It is kind of unfair to equate these rational numbers to their
;; corresponding names/concepts in floating point.  The float infinity
;; is used for numbers that are "too large" or overflow.  The rational
;; infinity is a limit.  The NaN (not a number) floating point name is
;; a misfit in the rational model, because in a symbolic system like
;; Lisp, MOST objects are not numbers. Calling the 0/0 undefined is
;; not fair either, because it is defined to some extent: (at least we
;; know it is not the same as some particular number, say 43). It is
;; indeterminate, perhaps.  But as a consideration for analogical
;; reasoning, we will use the name NaN, but let's let it stand for
;; something else. iNdetermiNAte.   I know that's NNA, but to
;; a dyslexic, ohw serac?

(defpackage :proj				;uses generic arithmetic
  (:use  :common-lisp :ga )
  (:shadowing-import-from 
   :ga
   "+" "-" "/" "*" "expt"		;binary arith
   "=" "/=" ">" "<" "<=" ">="		;binary comparisons
   "sin" "cos" "tan"			;... more trig
   "atan" "asin" "acos"			;... more inverse trig
   "sinh" "cosh" "atanh"		;... more hyperbolic
   "expt" "log" "exp" "sqrt"		;... more exponential, powers
   "1-" "1+" "abs"
 ;;  "tocl" "re-intern"
 ;;  "numerator" "denominator"
   )
  (:export    "proj" )
)
(eval-when (load eval) (require "ga"))				;generic arithmetic
(in-package :proj)			;package is projective rationals

(defstruct proj n)			;a projective rat. n is 0 or 1
;; the constructor for proj is just (/ a b)

(defvar NaN (make-proj :n 0))		; 0/0
(defvar inf (make-proj :n 1))		; 1/0

(defmethod print-object ((a proj) stream)  (format stream "~a/0"  (proj-n a)))

;; Non-rational operations on extended rationals are not very useful.
;; Here are some, anyway.
(defmethod ga::sin ((s proj)) NaN)
(defmethod ga::cos ((s proj)) NaN)
(defmethod ga::tan ((s proj)) NaN)
(defmethod ga::exp ((s proj)) NaN)
(defmethod ga::log ((s proj)) NaN)
(defmethod ga::two-arg-expt((s proj)(n t)) (if (zerop n) 1 s)) ;NaN^0=1
(defmethod ga::two-arg-expt((s t)(n proj)) (cond ((= s 1) 1) ;1^inf, 1^nan
						 ((= s 0) 0) ;0^inf, 0^nan
						 ;; maybe |x|<1 x^inf?
						 (t n))) ;x^inf, x^nan
(defmethod ga::atan ((s proj)) NaN) 

(defmethod ga::two-arg-+ ((r proj) (s proj)) NaN) ;checked 1/2/06
(defmethod ga::two-arg-+ ((r proj) (s t))  r) ; +-inf*norm, und*norm; 1/2/06
(defmethod ga::two-arg-+ ((s t) (r proj))  r)

(defmethod ga::two-arg-* ((r proj) (s proj))  
  (make-proj :n (* (proj-n r)(proj-n s)))) ;checked 1/2/06
(defmethod ga::two-arg-* ((r proj) (s t))  r) ; +-inf*norm, und*norm ;checked 1/2/06
(defmethod ga::two-arg-* ((s t) (r proj))  r)

(defmethod ga::two-arg-/ ((r rational) (s rational))  
  ;;norm/norm. check for norm/0 . This is how we construct INF and UND
  ;; for affine, look for sign of r
  (if(zerop s) (make-proj :n (if (zerop r) 0 1))(cl::/ r s)))

;;More could be done but IEEE float is affine not projective.
;;To do IEEE floats justice we need +inf -inf and signed zeros.
;;These are in the file affine-rat. The names for nan
;;are not standardized. These are the names for allegro cl.
;; At this time (1/5/06) the affine file has more details . RJF

#+allegro
(defmethod ga::two-arg-/ ((r number) (s (eql 0)))   ;; e.g. floats.
   (cond ((zerop r) #.excl::*nan-double*)  ;0/0
	 ((excl::nan-p r)  #.excl::*nan-double*) ; nan/0
	 (t #.excl::*infinity-double*)))

(defmethod ga::two-arg-/ ((r t) (s proj)) ; norm/inf=0 or norm/und ;checked 1/2/06
  (if (= 0 (proj-n s)) NaN 0))

(defmethod ga::two-arg-/ ((r proj) (s t)) ; inf/ norm, und/norm
  (if (= 0 s) NaN r))

;(defmethod numerator((s proj))(proj-n s))
;(defmethod numerator((s t))(cl::numerator s))
;(defmethod denominator((s proj))0)
;(defmethod denominator((s t))(cl::denominator s))

(defmacro defcomparison (op)
  (let ((two-arg (intern (concatenate 'string "two-arg-" 
				      (symbol-name op))    :ga )))
    `(progn ;; very few compares work. Just notequal. See below
       (defmethod ,two-arg ((arg1 proj) (arg2 number)) nil)
       (defmethod ,two-arg ((arg1 number) (arg2 proj)) nil)
       (defmethod ,two-arg ((arg1 proj) (arg2 proj)) nil)
      (compile ',two-arg)
      ',op)))
		      
(defcomparison >)
(defcomparison =)
(defcomparison <)
(defcomparison <=)
(defcomparison >=)

;; No regular OR extended number is equal to  1/0 or 0/0.
(defmethod ga::two-arg-/= ((arg1 proj) (arg2 number)) t)
(defmethod ga::two-arg-/= ((arg1 number) (arg2 proj)) t)
(defmethod ga::two-arg-/= ((arg1 proj) (arg2 proj)) t)