;    Copyright (C) 2006  Will M. Farr <farr@mit.edu>
;
;    This program is free software; you can redistribute it and/or modify
;    it under the terms of the GNU General Public License as published by
;    the Free Software Foundation; either version 2 of the License, or
;    (at your option) any later version.
;
;    This program is distributed in the hope that it will be useful,
;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;    GNU General Public License for more details.
;
;    You should have received a copy of the GNU General Public License along
;    with this program; if not, write to the Free Software Foundation, Inc.,
;    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

;; generics.ss
;; Defines the arithmatic operations and mathematical functions of R5RS as swindle generic functions.  
;; The relevant arithmatic generic functions (unary first, then binary) are:
;; +: plus add
;; -: minus sub
;; *: times mul
;; /: invert div
;;
;; The n-ary mathematical operations work pairwise, left-to-right, applying these generic function
;;
;; The mathematical functions are simply made generic (the order of operations does not matter here).

(module generics (lib "swindle.ss" "swindle")
  (require (lib "math.ss"))
  
  (provide (all-from-except (lib "swindle.ss" "swindle") 
                            + - * / < <= > >= add exp log sin cos 
                            tan asin acos atan sqrt expt zero? memoize)
           recursive-make
           (rename my-+ +) (rename my-- -) (rename my-* *) (rename my-/ /)
           (rename my-< <) (rename my-> >) (rename my-<= <=) (rename my->= >=)
           plus (rename my-add add) minus sub times mul invert div
           greater-than greater-than-or-equal less-than less-than-or-equal
           (rename my-exp exp) (rename my-log log) (rename my-sin sin) (rename my-cos cos)
           (rename my-tan tan) (rename my-asin asin) (rename my-acos acos) (rename my-atan atan) atan1 atan2
           (rename my-sqrt sqrt) (rename my-expt expt) (rename my-zero? zero?)
           square cube sinc
           norm-squared norm
           pi)
  
  (define-syntax recursive-make
    (syntax-rules ()
      ((recursive-make (name class arg ...) ...)
       (letrec ((name (allocate-instance class '())) ...)
         (initialize name (list arg ...))
         ...
         (values name ...)))))  
  
  ;; Arithmatic functions: + - * /
  
  (define my-+ 
    (case-lambda
      ((x) (plus x))
      ((x y) (my-add x y))
      ((x y . ys) (apply my-+ (my-add x y) ys))))
  
  (define my--
    (case-lambda 
      ((x) (minus x))
      ((x y) (sub x y))
      ((x . ys) (sub x (apply my-+ ys)))))
  
  (define my-*
    (case-lambda 
      ((x) (times x))
      ((x y) (mul x y))
      ((x y . ys) (apply my-* (mul x y) ys))))
  
  (define my-/
    (case-lambda 
      ((x) (invert x))
      ((x y) (div x y))
      ((x . ys) (div x (apply my-* ys)))))
  
  (define my->
    (case-lambda
      ((x y) (greater-than x y))
      ((x y . zs)
       (and (greater-than x y)
            (apply my-> y zs)))))
  
  (define my->=
    (case-lambda
      ((x y) (greater-than-or-equal x y))
      ((x y . zs)
       (and (greater-than-or-equal x y)
            (apply my->= y zs)))))
  
  (define my-<
    (case-lambda
      ((x y) (less-than x y))
      ((x y . zs)
       (and (less-than x y)
            (apply my-< y zs)))))
  
  (define my-<=
    (case-lambda
     ((x y) (less-than-or-equal x y))
     ((x y . zs)
      (and (less-than-or-equal x y)
           (apply my-<= y zs)))))
  
  (defgeneric (plus x))
  (defgeneric (my-add x y))
  (defgeneric (minus x))
  (defgeneric (sub x y))
  (defgeneric (times x))
  (defgeneric (mul x y))
  (defgeneric (invert x))
  (defgeneric (div x y))
  
  (defgeneric (greater-than x y))
  (defgeneric (greater-than-or-equal x y))
  (defgeneric (less-than x y))
  (defgeneric (less-than-or-equal x y))
  
  ;; Methods for numbers
  (defmethod (plus (x <number>)) (+ x))
  (defmethod (my-add (x <number>) (y <number>)) (+ x y))
  (defmethod (minus (x <number>)) (- x))
  (defmethod (sub (x <number>) (y <number>)) (- x y))
  (defmethod (times (x <number>)) (* x))
  (defmethod (mul (x <number>) (y <number>)) (* x y))
  (defmethod (invert (x <number>)) (/ x))
  (defmethod (div (x <number>) (y <number>)) (/ x y))
  
  (defmethod (greater-than (x <number>) (y <number>)) (> x y))
  (defmethod (greater-than-or-equal (x <number>) (y <number>)) (>= x y))
  (defmethod (less-than (x <number>) (y <number>)) (< x y))
  (defmethod (less-than-or-equal (x <number>) (y <number>)) (<= x y))
  
  ;; Transcendental functions: exp log sin cos tan asin acos atan sqrt.
  ;; atan involves the two generic functions atan1 atan2 and sinc
  (define my-atan
    (case-lambda 
      ((x) (atan1 x))
      ((x y) (atan2 x y))))
  
  (defgeneric (my-exp x))
  (defgeneric (my-log x))
  (defgeneric (my-sin x))
  (defgeneric (my-cos x))
  (defgeneric (my-tan x))
  (defgeneric (my-asin x))
  (defgeneric (my-acos x))
  (defgeneric (atan1 x))
  (defgeneric (atan2 x y))
  (defgeneric (my-sqrt x))
  (defgeneric (my-expt x y))
  (defgeneric (sinc x))
    
  (defmethod (my-exp (x <number>)) (exp x))
  (defmethod (my-log (x <number>)) (log x))
  (defmethod (my-sin (x <number>)) (sin x))
  (defmethod (my-cos (x <number>)) (cos x))
  (defmethod (my-tan (x <number>)) (tan x))
  (defmethod (my-asin (x <number>)) (asin x))
  (defmethod (my-acos (x <number>)) (acos x))
  (defmethod (atan1 (x <number>)) (atan x))
  (defmethod (atan2 (x <number>) (y <number>)) (atan x y))
  (defmethod (my-sqrt (x <number>)) (sqrt x))
  (defmethod (my-expt (x <number>) (y <number>))
    (expt x y))
  (defmethod (sinc (x <number>))
    (if (= x 0)
        1
        (/ (sin x) x)))
  
  (defgeneric (my-zero? x))
  (defmethod (my-zero? x) (zero? x))
  
  (define (square x)
    (my-* x x))
  (define (cube x)
    (my-* x x x))
  
  (defgeneric (norm-squared v))
  (define (norm v) 
    (my-sqrt (norm-squared v))))