arithmetic-generic-drop.rkt

#lang racket

(provide add sub mul div)

;(require "numerical.rkt")
(require "getput.rkt")
(require "generic-drop.rkt")
(require "tagged-obj-original.rkt")
(require racket/trace)

(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (raise x) (apply-generic 'raise x))
(define (project x) (apply-generic 'project x))
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (square x) (apply-generic 'square x))
(define (atangent x y) (apply-generic 'atangent x y))

(define (install-scheme-number-package)
  (define (tag x) (attach-tag 'scheme-number x))
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))
  (put 'exp '(scheme-number scheme-number)
       (lambda (x y) (tag (expt x y))))
  (put '=zero? '(scheme-number) (lambda (x) (= x 0)))
  (put 'make 'scheme-number (lambda (x) (tag x)))
  (put 'raise '(scheme-number) (lambda (x) (make-rational x 1)))
  (put 'project '(scheme-number) (lambda (x) #f))
  (put 'sine '(scheme-number) (compose make-real sin))
  (put 'cosine '(scheme-number) (compose make-real cos))
  (put 'square-root '(scheme-number) (compose make-real sqrt))
  (put 'square '(scheme-number) (lambda (x) (make-scheme-number (* x x))))
  (put 'atangent '(scheme-number scheme-number) (lambda (x y) (make-real (atan x y))))
  'done)

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

(define (install-rational-package)
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y)) (* (denom x) (numer y))))
  (define (equ? x y)
    (= (* (numer x) (denom y))
       (* (numer y) (denom x))))
  (define (=zero? x) (= (numer x) 0))
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))
  (put 'equ? '(rational rational) equ?)
  (put '=zero? '(rational) =zero?)
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  (put 'raise '(rational) (lambda (r) (make-real (exact->inexact (/ (numer r) (denom r))))))
  (put 'project '(rational) (lambda (r) (make-scheme-number (floor (/ (numer r) (denom r))))))
  (put 'sine '(rational) (lambda (r) (make-real (sin (/ (numer r) (denom r))))))
  (put 'cosine '(rational) (lambda (r) (make-real (cos (/ (numer r) (denom r))))))
  (put 'square '(rational) (lambda (r) (make-real (* (/ (numer r) (denom r))
                                                     (/ (numer r) (denom r))))))
  (put 'square-root '(rational) (lambda (r) (make-real (sqrt (/ (numer r) (denom r))))))
  (put 'atangent '(rational rational) (lambda (r s) (make-real (atan (/ (numer r) (denom r))
                                                                     (/ (numer s) (denom s))))))
  'done)

(define (make-rational n d)
  ((get 'make 'rational) n d))

(define (install-real-package)
  (define (tag x) (attach-tag 'real x))
  (put 'add '(real real) (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real) (lambda (x y) (tag (- x y))))
  (put 'mul '(real real) (lambda (x y) (tag (* x y))))
  (put 'div '(real real) (lambda (x y) (tag (/ x y))))
  (put 'equ? '(real real) (lambda (x y) (= x y)))
  (put '=zero? '(real) (lambda (x) (= x 0.0)))
  (put 'make 'real (lambda (r) (tag r)))
  (put 'raise '(real) (lambda (r) (make-complex-from-real-imag (make-real r) (make-real 0.0))))
  (put 'project '(real) (lambda (r)
                          (let ((q (inexact->exact r)))
                            (make-rational (numerator q) (denominator q)))))
  (put 'sine '(real) (lambda (r) (compose make-real sin)))
  (put 'cosine '(real) (lambda (r) (compose make-real cos)))
  (put 'square-root '(real) (compose make-real sqrt))
  (put 'square '(real) (lambda (x) (make-real (* x x))))
  (put 'atangent '(real real) (lambda (x y) (make-real (atan x y))))
  'done)

(define (make-real r)
  ((get 'make 'real) r))

(define (install-complex-package)
  (define (install-rect-package)
    (define (real-part z) (car z))
    (define (imag-part z) (cdr z))
    (define (make-from-real-imag x y) (cons x y))
    (define (magnitude z)
      (square-root (add (square (real-part z))
                        (square (imag-part z)))))
    (define (angle z)
      (atangent (imag-part z) (real-part z)))
    (define (make-from-mag-ang r a)
      (cons (mul r (cosine a)) (mul r (sine a))))
    (define (=zero? x) (and (equ? (make-scheme-number 0) (real-part x))
                            (equ? (make-scheme-number 0) (imag-part x))))

    (define (tag x) (attach-tag 'rect x))
    (put 'real-part '(rect) real-part)
    (put 'imag-part '(rect) imag-part)
    (put 'magnitude '(rect) magnitude)
    (put 'angle '(rect) angle)
    (put 'make-from-real-imag 'rect (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'rect (lambda (r a) (tag (make-from-mag-ang r a))))
    (put '=zero? '(rect) =zero?)
    'done)

  (define (install-polar-package)
    (define (magnitude z) (car z))
    (define (angle z) (cdr z))
    (define (make-from-mag-ang r a) (cons r a))
    (define (real-part z) (mul (magnitude z) (sine (angle z))))
    (define (imag-part z) (mul (magnitude z) (cosine (angle z))))
    (define (make-from-real-imag x y)
      (cons (square-root (add (square x) (square y)))
            (atangent y x)))
    (define (=zero? x) (equ? (make-scheme-number 0) (magnitude x)))

    (define (tag x) (attach-tag 'polar x))
    (put 'real-part '(polar) real-part)
    (put 'imag-part '(polar) imag-part)
    (put 'magnitude '(polar) magnitude)
    (put 'angle '(polar) angle)
    (put 'make-from-real-imag 'polar (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'polar (lambda (r a) (tag (make-from-mag-ang r a))))
    (put '=zero? '(polar) =zero?)
    'done)

  (install-rect-package)
  (install-polar-package)

  (define (real-part z) (apply-generic 'real-part z))
  (define (imag-part z) (apply-generic 'imag-part z))
  (define (magnitude z) (apply-generic 'magnitude z))
  (define (angle z) (apply-generic 'angle z))
  (define (complex-equ? x y) (and (equ? (real-part x) (real-part y))
                          (equ? (imag-part x) (imag-part y))))
  (define (=zero? x) (apply-generic '=zero? x))

  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rect) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))

  (define (add-complex z1 z2)
    (make-from-real-imag (add (real-part z1) (real-part z2))
                         (add (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (sub (real-part z1) (real-part z2))
                         (sub (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
                       (add (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (div (magnitude z1) (magnitude z2))
                       (sub (angle z1) (angle z2))))

  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'equ? '(complex complex) complex-equ?)
  (put '=zero? '(complex) =zero?)
  (put 'raise '(complex) (lambda (c) #f))
  (put 'project '(complex) (lambda (c) (real-part c)))
  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
  ((get 'make-from-mag-ang 'complex) r a))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))

(for-each (lambda (x) (x)) (list install-scheme-number-package install-rational-package install-real-package install-complex-package))

(define complex-rect (make-complex-from-real-imag (make-scheme-number 3) (make-scheme-number 4)))
(define complex-polar (make-complex-from-mag-ang (make-real 4) (make-rational 0 1)))
(magnitude complex-rect)
(magnitude complex-polar)
(angle complex-rect)
(real-part complex-polar)
(add (make-scheme-number 4) (make-scheme-number 5))
(equ? (make-scheme-number 4) (make-scheme-number 4))
(sub complex-rect (make-complex-from-real-imag (make-scheme-number 4) (make-real 5)))
(equ? (make-rational 3 4) (make-rational 6 8))
(equ? complex-rect complex-rect)
(equ? complex-rect complex-polar)
(=zero? (make-scheme-number 4))
(=zero? (make-scheme-number 0))
(=zero? (make-rational 0 4))
(=zero? (make-rational 1 4))
(=zero? complex-rect)
(=zero? complex-polar)
(=zero? (make-complex-from-real-imag (make-rational 0 1) (make-scheme-number 0)))
(exp (make-scheme-number 4) (make-scheme-number 5))

(define tr (make-scheme-number 4))
(raise tr)
(raise (raise tr))
(raise (raise (raise tr)))
(raise (raise (raise (raise tr))))

((get 'raise (list (type-tag (make-scheme-number 3)))) (contents (make-scheme-number 3)))
(add (make-scheme-number 3) (make-rational 4 5))
(add (make-rational 3 1) (make-rational 4 5))

(mul (make-rational 3 4) (make-real .8))
(div (make-real 10) (make-rational 5 2))
(sub (make-scheme-number 2) (make-real 4.0))
(define complex (make-complex-from-real-imag (make-real 10) (make-scheme-number 20)))
(div complex (make-real 10))
(div complex (make-complex-from-real-imag (make-real 10) (make-rational 0 1)))
(div complex (make-rational 20 2))

(project complex)
(project (make-real 4.0))
(project (make-rational 4 2))
(project (make-scheme-number 3))

(drop (make-scheme-number 3))
(drop (make-rational 4 2))
(drop (make-real 4.0))
(drop complex)