;; ---
;; jupyter:
;;   jupytext:
;;     text_representation:
;;       extension: .scm
;;       format_name: light
;;       format_version: '1.5'
;;       jupytext_version: 1.14.4
;;   kernelspec:
;;     display_name: Calysto Scheme 3
;;     language: scheme
;;     name: calysto_scheme
;; ---

;; **Example**

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

(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (magnitude z)
  (define (square x)(* x x))
  (sqrt (+ (square (real-part z)) (square (imag-part z)))))
(define (angle z)
  (atan (imag-part z) (real-part z)))
(define (make-from-real-imag x y)(cons x y))
(define (make-from-mag-ang r a)
  (cons (* r (cos a)) (* r (sin a))))

(define (real-part z)
  (* (magnitude z)(cos (angle z))))
(define (imag-part z)
  (* (magnitude z)(sin (angle z))))
(define (magnitude z)(car z))
(define (angle z) (cdr z))
(define (make-from-real-imag x y)
  (define (square x)(* x x))
  (cons (sqrt (+ (square x)(square y))) (atan y x)))
(define (make-from-mag-ang r a)(cons r a))

;; **Example**

(define (attach-tag type-tag content)
  (cons type-tag content))

(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (display "bad Tagged datum")))

(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (display "bad tagged datum")))

(define (rectangular? z)
  (eq? (type-tag z) 'rectangular))
(define (polar? z)
  (eq? (type-tag z) 'polar))

(define (real-part-rectangle z)(car z))
(define (imag-part-rectangle z)(cdr z))

;; **Example**

(define (install-rectangular-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)
    (sqrt (+ (* (real-part z)(real-part z))
             (* (imag-part z)(imag-part z)))))
  (define (angle z)
    (atan (imag-part z)(real-part z)))
  (define (make-from-mag-ang r a)
    (cons (* r (cos a)) (* r (sin a))))
  (define (tag x)(attach-tag 'rectangular x))
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (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))))
  '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)
    (* (magnitude z)(cos (angle z))))
  (define (imag-part z)
    (* (magnitude z)(sin (angle z))))
  (define (make-from-real-image x y)
    (cons (sqrt (+ (* x x) (* y y)))
          (atan y 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))))
  'done)

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (display
           "no method for these type")))))

(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 (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))

;; **Exercise 2.73**

(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp)(if (same-variable? exp var) 1 0))
        ((sum? exp)
         (make-sum (deriv (addend exp) var)
                   (deriv (augend exp) var)))
        ((product? exp)
         (make-sum
          (make-product (multiplier exp)
                        (deriv (multiplicand exp) var))
          (make-product (derive (multiplier exp) var)
                        (multiplicand exp))))
        (else (display "unknown expression"))))

(define table (list )) 
(define (put op type proc) 
  (set! table (append table (list (list op type proc)))) 
) 
(define (get op type) 
  (define (search op type t) 
   (cond ((null? t) #f) 
    ((and (eqv? (caar t) op) (eqv? (cadar t) type)) 
         (caddar t) 
    ) 
    (else (search op type (cdr t))) 
   ) 
  ) 
  (search op type table) 
)

(define (install-sum-package) 
   (define (make-sum a1 a2) (cons a1 a2)) 
   (define (addend s) (cadr s)) 
   (define (augend s) (caddr s)) 
   (define (deriv-sum s) 
     (make-sum (deriv (addend s)) (deriv (augend s)))) 
  
   (define (tag x) (attach-tag '+ x)) 
   (put 'deriv '(+) deriv-sum) 
   (put 'make-sum '+ 
        (lambda (x y) (tag (make-sum x y)))) 
   'done) 
  
 (define (make-sum x y) 
   ((get 'make-sum '+) x y)) 
  
 (define (install-product-package) 
   (define (make-product m1 m2) (cons m1 m2)) 
   (define (multiplier p) (cadr p)) 
   (define (multiplicand p) (caddr p)) 
   (define (deriv-product p) 
     (make-sum 
      (make-product (multiplier exp) 
                    (deriv (multiplicand exp) var)) 
      (make-product (deriv (multiplier exp) var) 
                    (multiplicand exp)))) 
  
   (define (tag x) (attach-tag '* x)) 
   (put 'deriv '(*) deriv-product) 
   (put 'make-product '* 
        (lambda (x y) (tag (make-product x y)))) 
   'done) 
  
 (define (make-product x y) 
   ((get 'make-product '*) x y)) 
  
 (define (deriv x) (apply-generic 'deriv x)) 

;; **Example**

(define (make-from-real-imag x y)
  (define (dispatch op)
    (cond ((eq? op 'real-part) x)
          ((eq? op 'imag-part) y)
          ((eq? op 'magnitude)
           (sqrt (+ (* x x)(* y y))))
          ((eq? op 'angle)
           (atan y x))
          (else
           (display "unknown operation"))))
  dispatch)

(define (apply-generic op arg)(arg op))

(apply-generic 'real-part (make-from-real-imag 1 2))
(apply-generic 'imag-part (make-from-real-imag 1 2))
(apply-generic 'magnitude (make-from-real-imag 1 2))
;(apply-generic 'angle (make-from-real-imag 1 2))

;; **Exercise 2.75**

(define (make-from-mag-ang r a)
  (define (dispath op)
    (cond ((eq? op 'real-part) 
           (* r (cos a)))
          ((eq? op 'imag-part)
           (* r (sin a)))
          ((eq? op 'magnitude) r)
          ((eq? op 'angle) a)
          (else 
           (display "unknown oepration"))))
  dispath)

StarcoderdataJupyterScriptsDedupFiltered