Commit 581ce163 authored by bbguimaraes's avatar bbguimaraes
Browse files

sicp: section 2.4

parent 3d80c9ac
(define (t)
(let ((x (make-from-real-imag 3 4))
(y (make-from-mag-ang 3 4)))
(display x)
(newline)
(display (magnitude x))
(newline)
(display y)
(newline)
(display (magnitude y))
(newline)))
(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)
(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))))
(t)
(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)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (make-from-mag-ang r a) (cons r a))
(t)
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part-rectangular z) (car z))
(define (imag-part-rectangular z) (cdr z))
(define (magnitude-rectangular z)
(sqrt (+ (square (real-part-rectangular z))
(square (imag-part-rectangular z)))))
(define (angle-rectangular z)
(atan (imag-part-rectangular z)
(real-part-rectangular z)))
(define (make-from-real-imag-rectangular x y)
(attach-tag 'rectangular (cons x y)))
(define (make-from-mag-ang-rectangular r a)
(attach-tag 'rectangular
(cons (* r (cos a)) (* r (sin a)))))
(define (real-part-polar z)
(* (magnitude-polar z) (cos (angle-polar z))))
(define (imag-part-polar z)
(* (magnitude-polar z) (sin (angle-polar z))))
(define (magnitude-polar z) (car z))
(define (angle-polar z) (cdr z))
(define (make-from-real-imag-polar x y)
(attach-tag 'polar
(cons (sqrt (+ (square x) (square y)))
(atan y x))))
(define (make-from-mag-ang-polar r a)
(attach-tag 'polar
(cons r a)))
(define (real-part z)
(cond ((rectangular? z)
(real-part-rectangular (contents z)))
((polar? z)
(real-part-polar (contents z)))
(else (error "Unknown type -- REAL-PART" z))))
(define (imag-part z)
(cond ((rectangular? z)
(imag-part-rectangular (contents z)))
((polar? z)
(imag-part-polar (contents z)))
(else (error "Unknown type -- IMAG-PART" z))))
(define (magnitude z)
(cond ((rectangular? z)
(magnitude-rectangular (contents z)))
((polar? z)
(magnitude-polar (contents z)))
(else (error "Unknown type -- MAGNITUDE" z))))
(define (angle z)
(cond ((rectangular? z)
(angle-rectangular (contents z)))
((polar? z)
(angle-polar (contents z)))
(else (error "Unknown type -- ANGLE" z))))
(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 (make-from-real-imag x y)
(make-from-real-imag-rectangular x y))
(define (make-from-mag-ang r a)
(make-from-mag-ang-polar r a))
(let ((x (make-from-real-imag 3 4))
(y (make-from-mag-ang 3 4)))
(display x)
(newline)
(display (magnitude x))
(newline)
(display y)
(newline)
(display (magnitude y))
(newline))
(define (list-eq? x y)
(cond
((null? x) (null? y))
((null? y) (null? x))
((not (eq? (car x) (car y))) #f)
(else (list-eq? (cdr x) (cdr y)))))
(define (get dispatch-table op type-tags)
(if (null? dispatch-table)
#f
(let ((x (car dispatch-table)))
(if (and
(eq? (car x) op)
(if (pair? type-tags)
(list-eq? (cadr x) type-tags)
(eq? (cadr x) type-tags)))
(caddr x)
(get (cdr dispatch-table) op type-tags)))))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (install-rectangular-package dispatch-table)
;; internal procedures
(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 (+ (square (real-part z))
(square (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))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(append
dispatch-table
(list
(list 'real-part '(rectangular) real-part)
(list 'imag-part '(rectangular) imag-part)
(list 'magnitude '(rectangular) magnitude)
(list 'angle '(rectangular) angle)
(list 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(list 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a)))))))
(define (install-polar-package dispatch-table)
;; internal procedures
(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-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan x y)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(append
dispatch-table
(list
(list 'real-part '(polar) real-part)
(list 'imag-part '(polar) imag-part)
(list 'magnitude '(polar) magnitude)
(list 'angle '(polar) angle)
(list 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(list 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a)))))))
(define (apply-generic dispatch-table op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get dispatch-table op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (real-part dispatch-table z)
(apply-generic dispatch-table 'real-part z))
(define (imag-part dispatch-table z)
(apply-generic dispatch-table 'imag-part z))
(define (magnitude dispatch-table z)
(apply-generic dispatch-table 'magnitude z))
(define (angle dispatch-table z)
(apply-generic dispatch-table 'angle z))
(define (make-from-real-imag dispatch-table x y)
((get dispatch-table 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang dispatch-table r a)
((get dispatch-table 'make-from-mag-ang 'polar) r a))
(define (t dispatch-table)
(let ((x (make-from-real-imag dispatch-table 3 4))
(y (make-from-mag-ang dispatch-table 3 4)))
(display x)
(newline)
(display (real-part dispatch-table x))
(newline)
(display (magnitude dispatch-table x))
(newline)
(display y)
(newline)
(display (real-part dispatch-table y))
(newline)
(display (magnitude dispatch-table y))
(newline)))
(let
((dispatch-table (install-rectangular-package '())))
(let ((dispatch-table (install-polar-package dispatch-table)))
(t dispatch-table)))
(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 (+ (square x) (square y))))
((eq? op 'angle) (atan y x))
(else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
dispatch)
(define (apply-generic op arg) (arg op))
(define (real-part z) (apply-generic 'real-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(newline)
(let ((x (make-from-real-imag 3 4)))
(display x)
(newline)
(display (real-part x))
(newline)
(display (magnitude x))
(newline))
(define (variable? e) (symbol? e))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (addend e) (cadr e))
(define (augend e) (caddr e))
(define (make-sum a1 a2) (list '+ a1 a2))
(define (multiplier e) (cadr e))
(define (multiplicand e) (caddr e))
(define (make-product m1 m2) (list '* m1 m2))
(define (base e) (cadr e))
(define (exponent e) (caddr e))
(define (make-exponentiation b e) (list '** b e))
(define (get dispatch-table op type-tags)
(if (null? dispatch-table)
#f
(let ((x (car dispatch-table)))
(if (and
(eq? (car x) op)
(eq? (cadr x) type-tags))
(caddr x)
(get (cdr dispatch-table) op type-tags)))))
(define (deriv-sum dispatch-table exp var)
(make-sum (deriv dispatch-table (addend exp) var)
(deriv dispatch-table (augend exp) var)))
(define (deriv-product dispatch-table exp var)
(make-sum
(make-product (multiplier exp)
(deriv dispatch-table (multiplicand exp) var))
(make-product (deriv dispatch-table (multiplier exp) var)
(multiplicand exp))))
(define (deriv-exponentiation dispatch-table exp var)
(make-product
(make-product
(exponent exp)
(make-exponentiation
(base exp)
(make-sum (exponent exp) '-1)))
(deriv dispatch-table (base exp) var)))
(define (install-deriv-package dispatch-table)
(append
dispatch-table
(list
(list 'deriv '+ deriv-sum)
(list 'deriv '* deriv-product)
(list 'deriv '** deriv-exponentiation))))
(define (deriv dispatch-table exp var)
(cond
((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
(else
(let ((proc (get dispatch-table 'deriv (operator exp))))
(if proc
(proc dispatch-table exp var)
(error "No method for these types -- DERIV" exp var))))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (t dispatch-table)
(define (deriv2 exp args) (deriv dispatch-table exp args))
(display (deriv2 '(+ x 3) 'x))
(newline)
(display (deriv2 '(* x y) 'x))
(newline)
(display (deriv2 '(* (* x y) (+ x 3)) 'x))
(newline)
(display (deriv2 '(** (+ x 2) 3) 'x))
(newline))
(define dispatch-table (install-deriv-package '()))
(t dispatch-table)
(define (make-sum a1 a2)
(cond ((=number? a1 0) a2)
((=number? a1 0) a1)
((and (number? a1) (number? a1)) (+ a1 a2))
(else (list '+ a1 a2))))
(define (make-product m1 m2)
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2)) (* m1 m2))
(else (list '* m1 m2))))
(define (make-exponentiation b e)
(cond ((=number? e 0) 1)
((and (number? b) (number? e)) (expt b e))
(else (list '** b e))))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(newline)
(t dispatch-table)
(define (deriv dispatch-table exp var)
(cond
((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
(else
(let ((proc (get dispatch-table (operator exp) 'deriv)))
(if proc
(proc dispatch-table exp var)
(error "No method for these types -- DERIV" exp var))))))
(define (install-deriv-package dispatch-table)
(append
dispatch-table
(list
(list '+ 'deriv deriv-sum)
(list '* 'deriv deriv-product)
(list '** 'deriv deriv-exponentiation))))
(newline)
(t (install-deriv-package '()))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (get dispatch-table op type-tags)
(if (null? dispatch-table)
#f
(let ((x (car dispatch-table)))
(if (and
(eq? (car x) op)
(eq? (cadr x) type-tags))
(caddr x)
(get (cdr dispatch-table) op type-tags)))))
(define (get-record file division name)
(if (null? file)
#f
(let ((x (car file)))
(if (equal? name (car x))
(attach-tag division x)
(get-record (cdr file) division name)))))
; name age occupation salary
(define file-a
(list
(list "Bob" 25 "programmer" 20)))
; name occupation_code 100-salary birth_timestamp
(define file-b
(list
(list "Jennifer" 5 60 94668401)
(list "Billy" 1 78 946684800)))
(display (get-record file-a 'division-a "Billy"))
(newline)
(display (get-record file-a 'division-a "Bob"))
(newline)
(display (get-record file-b 'division-b "Billy"))
(newline)
(display (get-record file-b 'division-b "Bob"))
(newline)
(define (get-salary dispatch-table record)
((get dispatch-table 'get-salary (type-tag record)) (contents record)))
(define (install-insatiable-package dispatch-table)
(define (get-salary-division-a record) (cadddr record))
(define (get-salary-division-b record) (- 100 (caddr record)))
(append
dispatch-table
(list
(list 'get-salary 'division-a get-salary-division-a)
(list 'get-salary 'division-b get-salary-division-b))))
(define dispatch-table (install-insatiable-package '()))
(newline)
(display (get-salary dispatch-table (get-record file-a 'division-a "Bob")))
(newline)
(display (get-salary dispatch-table (get-record file-b 'division-b "Billy")))
(newline)
(define (find-employee-record files name)
(if (null? files)
#f
(let ((division (caar files))
(records (cadar files)))
(let ((record (get-record records division name)))
(if record
record
(find-employee-record (cdr files) name))))))
(define files
(list
(list 'division-a file-a)
(list 'division-b file-b)))
(newline)
(display (get-salary dispatch-table (find-employee-record files "Bob")))
(newline)
(display (get-salary dispatch-table (find-employee-record files "Billy")))
(newline))
(define (make-from-mag-ang r a)
(define (dispatch 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 (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
dispatch)
(define (apply-generic op arg) (arg op))
(define (real-part z) (apply-generic 'real-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(newline)
(let ((x (make-from-mag-ang 3 4)))
(display x)
(newline)
(display (real-part x))
(newline)
(display (magnitude x))
(newline))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment