sicp 2.93

sicp_2_93

;; ================error=================================================
(define (error . l)
  (display l)
  )
;; ======================================================================
(define (install-polynomial-package)
  ;; internal procedures
  ;; representation of poly
  (define (tag p) (attach-tag 'polynomial p)) 
  
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))
  (define variable? symbol?)
  
  ;; representation of terms and term lists
  (define (make-term order coeff) (list order coeff))
  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (equal? term-list (the-empty-termlist)))
  (define (order term) (car term))
  (define (coeff term) (cadr term))
  
  
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  
  (define (terms-zero? terms)
    (if (empty-termlist? terms)
        #t
        (and (=zero? (coeff (first-term terms)))
             (terms-zero? (rest-terms terms)))))
  
    (define (negate-terms L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((term (first-term L)))
          (adjoin-term (make-term (order term)
                                  (negate (coeff term)))
                       (negate-terms (rest-terms L))))))
  
  (define (negate-poly p)
    (make-poly (variable p)
               (negate-terms (term-list p))))
  
  (define (add-terms L1 L2) 
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term
                     t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term
                     t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1)
                                (rest-terms L2)))))))))

  
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  
  (define (div-terms L1 L2)
  (if (empty-termlist? L1)
      (list (the-empty-termlist) (the-empty-termlist))
      (let ((t1 (first-term L1))
            (t2 (first-term L2)))
        (if (> (order t2) (order t1))
            (list (the-empty-termlist) L1)
            (let ((new-c (div (coeff t1) (coeff t2)))
                  (new-o (- (order t1) (order t2))))
              (let ((rest-of-result
                     (div-terms 
                      (add-terms L1 
                                 (negate-terms 
                                  (mul-term-by-all-terms 
                                   (make-term new-o new-c) L2))) 
                      L2)))
                (cons (adjoin-term (make-term new-o new-c)
                                   (car rest-of-result))
                      (cdr rest-of-result))))))))
  
  (define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))
  (define (sub-poly p1 p2)
        (add-poly p1 (negate-poly p2)))
  
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))
  
  (define (div-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
      (make-poly (variable p1)
                 (div-terms (term-list p1)
                      (term-list p2)))
      (error "Polys not in same var -- DIV-POLY"
             (list p1 p2))))
  
  (define (poly-zero? p)
    (terms-zero? (term-list p)))
  
  
  ;; interface to rest of the system
  (put 'make       'term                    (lambda (order coeff) (make-term order coeff)))
  (put 'make       'polynomial              (lambda (var terms)   (tag (make-poly var terms))))
  (put 'add        '(polynomial polynomial) (lambda (p1 p2)       (tag (add-poly p1 p2))))
  (put 'sub        '(polynomial polynomial) (lambda (p1 p2)       (tag (sub-poly p1 p2))))
  (put 'mul        '(polynomial polynomial) (lambda (p1 p2)       (tag (mul-poly p1 p2))))
  (put 'div        '(polynomial polynomial) (lambda (p1 p2)       (tag (div-poly p1 p2))))
  (put '=zero?     '(polynomial)            (lambda (p1)          (poly-zero? p1)))
  (put 'negate     '(polynomial)            (lambda (p) (tag (negate-poly p))))
  'done)


(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (if proc 
        (apply proc (map contents args))
        (error "procedure not installed -- APPLY-GENERIC" op args))))

;; ========================put-get==============================================
(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)    
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            ((eq? m 'table) local-table)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))

(define (attach-tag type-tag contents)
  (if (eq? type-tag 'integer) 
      contents
      (cons type-tag contents)))

(define (type-tag datum)
  (cond ((pair? datum) (car datum))
        ((number? datum) 'integer)
        (else (error "Bad tagged datum -- TYPE-TAG" datum))))

(define (contents datum)
  (cond ((pair? datum) (cdr datum))
        ((number? datum) cdr datum)
        (else (error "Bad tagged datum -- CONTENTS" datum))))

;; ======================================================================
;;
;; The integer number package
;;
;; ======================================================================
(define (install-integer-package)
  ;; internal procedures 
  
  (define (tag x) (attach-tag 'integer x))
  
  (define (raise1 x)
    (cond ((integer? x)  (make-rational x 1))
          ((rational? x) (make-rational (numerator x) (denominator x)))
          ((real? x)     (raise1 (rationalize x 1/100000)))))
  
  ;; interface to rest of the system
  (put 'make       'integer           (lambda (x)   (tag x)))
  (put 'add        '(integer integer) (lambda (x y) (tag (+ x y))))
  (put 'sub        '(integer integer) (lambda (x y) (tag (- x y))))
  (put 'mul        '(integer integer) (lambda (x y) (tag (* x y))))
  (put 'div        '(integer integer) (lambda (x y) (tag (/ x y))))
  (put 'equ?       '(integer integer) (lambda (x y) (= x y)))
  (put '=zero?     '(integer)         (lambda (x)   (zero? x)))
  (put 'raise1     '(integer)        (lambda (x)   (make-rational x 1)))
  (put 'type-level '(integer)         (lambda (x)   1))
  (put 'sq-root    '(integer)         (lambda (x)   (make-real (sqrt x))))
  (put 'square     '(integer)         (lambda (x)   (tag (* x x))))
  (put 'sine       '(integer)         (lambda (x)   (make-real(sin x))))
  (put 'cosine     '(integer)         (lambda (x)   (make-real(cos x))))
  (put 'arctan     '(integer integer) (lambda (x y) (make-real(atan x y))))
  (put 'negate '(integer)             (lambda (x) (tag (- x))))
  
  'done)

;; ======================================================================
;;
;; The rational number package
;;
;; ======================================================================
(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (valid-component? c)
    (memq (type-tag c) '(integer polynomial)))
  (define (make-rat n d)
  (cond ((integer? n) (make-rat (make-integer n) d))
        ((integer? d) (make-rat n (make-integer d)))
        ((and (valid-component? n) (valid-component? d)) (cons n d))
        (else (error
               "numerator and denominator must both be integer or polynomial types"
               (list n d)))))
  
  (define (ratio x) (/ (numer x) (denom x)))
  
  (define (add-rat x y) (make-rat (add (mul (numer x) (denom y))
                                     (mul (numer y) (denom x)))
                                  (mul (denom x) (denom y))))
  (define (sub-rat x y) (make-rat (sub (mul (numer x) (denom y))
                                     (mul (numer y) (denom x)))
                                  (mul (denom x) (denom y))))
  (define (mul-rat x y) (make-rat (mul (numer x) (numer y))
                                  (mul (denom x) (denom y))))
  (define (div-rat x y) (make-rat (mul (numer x) (denom y))
                                  (mul (denom x) (numer y))))
  (define (equ-rat x y) (and (equ? (numer x) (numer y))
                             (equ? (denom x) (denom y))))
  (define (=zero-rat x) (zero? (numer x)))
  (define (rational->real r) (make-real (exact->inexact (ratio r)))) 
  (define (project r) 
    (make-integer (truncate (ratio r))))
  (define (negate-rat x)
    (make-rat (- (numer x)) (denom x)))
  
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'make       'rational             (lambda (n d) (tag (make-rat n d))))
  (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)  (lambda (x y) (equ-rat x y)))
  (put '=zero?     '(rational)           (lambda (x)   (=zero-rat x)))
  (put 'raise1      '(rational)           (lambda (x)   (rational->real x)))
  (put 'type-level '(rational)           (lambda (x)   2))
  (put 'project    '(rational)           (lambda (x)   (project x)))
  (put 'sq-root    '(rational)           (lambda (x)   (make-real (sqrt (ratio x)))))
  (put 'square     '(rational)           (lambda (x)   (tag (mul-rat x x))))
  (put 'sine       '(rational)           (lambda (x)   (make-real (sin (ratio x)))))
  (put 'cosine     '(rational)           (lambda (x)   (make-real (cos (ratio x)))))
  (put 'arctan     '(rational rational)  (lambda (x y) (make-real (atan (ratio x) (ratio y)))))
  (put 'negate     '(rational)           (lambda (x) (tag (negate-rat x))))
  
  'done)


;; ======================================================================
;;
;; The real number package
;;
;; ======================================================================
(define (install-real-package)
  ;; internal procedures
  (define (tag x) (attach-tag 'real x))
  
  (define (real->complex r)
    (make-complex-from-real-imag (make-real r) 
                                 (make-real 0)))
  
  (define (project r) 
    (cond ((integer? r) (make-rational r 1))
          (else (let ((rat (rationalize r 1/100000)))
                  (make-rational (numerator rat)
                                 (denominator rat))))))
  (define (make x)
    (let ((type (type-tag x))
          (val  (contents x)))
      (cond ((eq? type 'integer)  (tag x))
            ((eq? type 'rational) (tag (raise1 x)))
            ((eq? type 'real)     x)
            (else (error "MAKE-REAL : Bad type argument : " x)))))
  
  ;; interface to rest of the system
  (put 'make        'real        (lambda (x)   (make 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)   (zero? x)))
  (put 'raise1      '(real)       (lambda (x)   (real->complex x)))
  (put 'type-level '(real)       (lambda (x)   3))
  (put 'project    '(real)       (lambda (x)   (project x)))
  (put 'sq-root    '(real)       (lambda (x)   (tag (sqrt x))))
  (put 'square     '(real)       (lambda (x)   (tag (* x x))))
  (put 'sine       '(real)       (lambda (x)   (tag (sin x))))
  (put 'cosine     '(real)       (lambda (x)   (tag (cos x))))
  (put 'arctan     '(real real)  (lambda (x y) (tag (atan x y))))
  (put 'negate     '(real)       (lambda (x) (tag (- x))))
  'done)


;; ======================================================================
;;
;; The rectangular number package
;;
;; ======================================================================
(define (install-rectangular-package)
  ;; internal procedures
  (define (real-part1 z) (car z))
  (define (imag-part1 z) (cdr z))
  (define (make-from-real-imag x y) (cons x y))
  (define (magnitude1 z)
    (sq-root (add (square (real-part1 z))
                  (square (imag-part1 z)))))
  (define (angle1 z)
    (arctan (imag-part1 z) (real-part1 z)))
  (define (make-from-mag-ang r a) 
    (cons (mul r (cosine a)) (mul r (sine a))))
  
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'rectangular x))
  (put 'make-from-real-imag 'rectangular   (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang   'rectangular   (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'real-part1           '(rectangular) (lambda (x)   (real-part1 x)))
  (put 'imag-part1           '(rectangular) (lambda (x)   (imag-part1 x)))
  (put 'magnitude1           '(rectangular) (lambda (x)   (magnitude1 x)))
  (put 'angle1               '(rectangular) (lambda (x)   (angle1 x)))
  
  'done)

;; ======================================================================
;;
;; The polar number package
;;
;; ======================================================================
(define (install-polar-package)
  ;; internal procedures
  (define (magnitude1 z) (car z))
  (define (angle1 z) (cdr z))
  (define (make-from-mag-ang r a) (cons r a))
  
  (define (real-part1 z)
    (mul (magnitude1 z) (cosine (angle1 z))))
  (define (imag-part1 z)
    (mul (magnitude1 z) (sine (angle1 z))))
  (define (make-from-real-imag x y) 
    (make-from-mag-ang (sq-root (add (square x) (square y)))
                       (arctan y x)))
  
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'polar x))
  (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 'real-part1           '(polar) (lambda (x)   (real-part1 x)))
  (put 'imag-part1           '(polar) (lambda (x)   (imag-part1 x)))
  (put 'magnitude1           '(polar) (lambda (x)   (magnitude1 x)))
  (put 'angle1               '(polar) (lambda (x)   (angle1 x)))
  
  'done)


;; ======================================================================
;;
;; The complex number package
;;
;; ======================================================================
(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y) ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a) ((get 'make-from-mag-ang 'polar) r a))
  ;; internal procedures
  (define (tag z) (attach-tag 'complex z))
  (define (add-complex z1 z2) (make-from-real-imag (add (real-part1 z1) (real-part1 z2))
                                                   (add (imag-part1 z1) (imag-part1 z2))))
  (define (sub-complex z1 z2) (make-from-real-imag (sub (real-part1 z1) (real-part1 z2))
                                                   (sub (imag-part1 z1) (imag-part1 z2))))
  (define (mul-complex z1 z2) (make-from-mag-ang (mul (magnitude1 z1) (magnitude1 z2))
                                                 (add (angle1 z1) (angle1 z2))))
  (define (div-complex z1 z2) (make-from-mag-ang (div (magnitude1 z1) (magnitude1 z2))
                                                 (sub (angle1 z1) (angle1 z2))))
  (define (equ-complex z1 z2) (and (equ? (magnitude1 z1) (magnitude1 z2))
                                   (equ? (angle1 z1) (angle1 z2))))
  (define (=zero-complex z1) (zero? (magnitude1 z1)))
  (define (project z1)
    (make-real (real-part1 z1)))
  (define (negate-complex z)
    (make-from-real-imag (negate (complex-real-part z))
                         (negate (complex-imag-part z))))
  
  ;; interface to rest of the system
  (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 'add                 '(complex complex) (lambda (x y) (tag (add-complex x y))))
  (put 'sub                 '(complex complex) (lambda (x y) (tag (sub-complex x y))))
  (put 'mul                 '(complex complex) (lambda (x y) (tag (mul-complex x y))))
  (put 'div                 '(complex complex) (lambda (x y) (tag (div-complex x y))))
  (put 'equ?                '(complex complex) (lambda (x y) (equ-complex x y)))
  (put '=zero?              '(complex)         (lambda (x)   (=zero-complex x)))
  (put 'real-part1          '(complex)         (lambda (x)   (real-part1 x)))
  (put 'imag-part1          '(complex)         (lambda (x)   (imag-part1 x)))
  (put 'magnitude1          '(complex)         (lambda (x)   (magnitude1 x)))
  (put 'angle1              '(complex)         (lambda (x)   (angle1 x)))
  (put 'type-level          '(complex)         (lambda (x)   4))
  (put 'project             '(complex)         (lambda (x)   (project x)))
  (put 'negate              '(complex)         (lambda (z) (tag (negate-complex z))))
  
  'done)

;; ======================================================================
;;
;; Type handling
;;
;; ======================================================================
(define (raise1 x)      (apply-generic 'raise1 x))
(define (type-level z) (apply-generic 'type-level z))
(define (project z)    (apply-generic 'project z))
(define (drop z)
  (if (= (type-level z) 1) 
      z
      (let ((projected (project z)))
        (if (equ? z (raise1 projected))
            (drop projected)
            z))))

;; ======================================================================
;;
;; Generic procedures
;;
;; ======================================================================
; Constructors
(define (make-integer n)                  ((get 'make 'integer) n)) 
(define (make-real n)                     ((get 'make 'real) n)) 
(define (make-rational n d)               ((get 'make 'rational) n d))
(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 (make-polynomial var terms)       ((get 'make 'polynomial) var terms))
(define (make-term order coeff)           ((get 'make 'term) order coeff))

; Selectors
(define (real-part1 z) (apply-generic 'real-part1 z))
(define (imag-part1 z) (apply-generic 'imag-part1 z))
(define (magnitude1 z) (apply-generic 'magnitude1 z))
(define (angle1     z) (apply-generic 'angle1     z))

; Operators
(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 (square x)    (apply-generic 'square x))
(define (sq-root x)   (apply-generic 'sq-root x))
(define (sine x)      (apply-generic 'sine x))
(define (cosine x)    (apply-generic 'cosine x))
(define (arctan x y)  (apply-generic 'arctan x y))
(define (negate x)    (apply-generic 'negate x))

;; ======================================================================
;;
;; Package installation
;;
;; ======================================================================
(define (install-number-packages)
  (install-integer-package)
  (install-polar-package)
  (install-rectangular-package)
  (install-rational-package)
  (install-real-package)
  (install-complex-package)  
  (install-polynomial-package))
(install-number-packages)


(define zero-terms 
  (list (make-term 4 0) 
        (make-term 2 0)
        (make-term 0 0)))
(define +ve-terms 
  (list (make-term 100 1)
        (make-term   2 2)
        (make-term   0 1)))
(define -ve-terms 
  (list (make-term 100 -1)
        (make-term   2 -2)
        (make-term   0 -1)))
(define term-101 (make-term 101 3))

(define pt0  (make-polynomial 'x zero-terms))
(define pt1  (make-polynomial 'x +ve-terms))
(define pt2  (make-polynomial 'y +ve-terms))
(define pt3  (make-polynomial 'x (cons term-101 +ve-terms)))
(define -pt1 (make-polynomial 'x -ve-terms))
(define -pt2 (make-polynomial 'y -ve-terms))

(define poly-py1 (make-polynomial 'y (list (make-term 3 pt1) (make-term 1 pt2) (make-term 0 pt3))))
(define poly-py2 (make-polynomial 'y (list (make-term 3 pt3) (make-term 2 pt1))))

(define p1 (make-polynomial 'x '((2 1)(0 1))))
(define p2 (make-polynomial 'x '((3 1)(0 1))))
(define rf (make-rational p2 p1))
rf
(add rf rf)

;result
;(rational (polynomial x (3 1) (0 1)) polynomial x (2 1) (0 1))
;(rational (polynomial x (5 2) (3 2) (2 2) (0 2)) polynomial x (4 1) (2 2) (0 1))