277 lines
9.0 KiB
Scheme
277 lines
9.0 KiB
Scheme
(load "util.scm")
|
|
|
|
(newline) (display "ex-2.73 - deriv data-directed") (newline)
|
|
|
|
(display "a. - see comments\n")
|
|
; a.
|
|
|
|
; When exp is an actual expression (and not a number or variable) get is used
|
|
; to retrieve the respective procedure from the table. We can't do this for a
|
|
; variable or number, because there is no operator that can be used to access
|
|
; the table.
|
|
|
|
; The new implementation of deriv selects the right procedure based on the
|
|
; operator of the expression. If the expression is a number or variable the
|
|
; procedure to get the operator will fail. Hence, those two cases are handled
|
|
; separately.
|
|
(display "\nb.\n")
|
|
|
|
(define (variable? x) (symbol? x))
|
|
(define (=number? exp num)
|
|
(and (number? exp) (= exp num)))
|
|
(define (same-variable? v1 v2)
|
|
(and (variable? v1) (variable? v2) (eq? v1 v2)))
|
|
(define (make-sum a1 a2)
|
|
(cond ((=number? a1 0) a2)
|
|
((=number? a2 0) a1)
|
|
((and (number? a1) (number? a2)) (+ 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 (deriv exp var)
|
|
(cond ((number? exp) 0)
|
|
((variable? exp) (if (same-variable? exp var) 1 0))
|
|
(else ((get 'deriv (operator exp)) (operands exp)
|
|
var))))
|
|
(define (operator exp) (car exp))
|
|
(define (operands exp) (cdr exp))
|
|
|
|
(define (install-deriv-package)
|
|
(define (multiplier operands) (car operands))
|
|
(define (addend operands) (car operands))
|
|
(define (get-remaining-operands operands operator)
|
|
(if (null? (cddr operands))
|
|
(cadr operands)
|
|
(cons operator (cdr operands))))
|
|
(define (multiplicand operands) (get-remaining-operands operands '*))
|
|
(define (augend operands) (get-remaining-operands operands '+))
|
|
(define (deriv-sum operands var)
|
|
(make-sum (deriv (addend operands) var)
|
|
(deriv (augend operands) var)))
|
|
(define (deriv-product operands var)
|
|
(make-sum
|
|
(make-product (multiplier operands)
|
|
(deriv (multiplicand operands) var))
|
|
(make-product (deriv (multiplier operands) var)
|
|
(multiplicand operands))))
|
|
;; interface to the rest of the system
|
|
(put 'deriv '+ deriv-sum)
|
|
(put 'deriv '* deriv-product)
|
|
(display "[installed deriv package]") (newline)
|
|
'done)
|
|
|
|
(install-deriv-package)
|
|
|
|
(display "tests:\n")
|
|
(assert (deriv '(+ x 3) 'x) 1)
|
|
(assert (deriv '(* x 3) 'x) 3)
|
|
(assert (deriv '(* x x) 'x) '(+ x x))
|
|
(assert (deriv '(* (* x y) (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
|
|
|
|
; c.
|
|
(display "\nc.\n")
|
|
|
|
(define (install-deriv-exp-package)
|
|
(define (make-exponentiation base exponent)
|
|
(cond ((=number? exponent 0) 1)
|
|
((=number? exponent 1) base)
|
|
(else (list '** base exponent))))
|
|
(define (base e) (car e))
|
|
(define (exponent e) (cadr e))
|
|
(define (deriv-exponentiation operands var)
|
|
(let ((u (base operands))
|
|
(n (exponent operands)))
|
|
(make-product
|
|
(make-product n (make-exponentiation u (make-sum n -1)))
|
|
(deriv u var))))
|
|
;; interface to the rest of the system
|
|
(put 'deriv '** deriv-exponentiation)
|
|
(display "[installed deriv exp package]") (newline)
|
|
'done)
|
|
|
|
(install-deriv-exp-package)
|
|
(display "exp test: ")
|
|
(assert (deriv '(** x 4) 'x) '(* 4 (** x 3)))
|
|
|
|
(display "multiple operands test: ")
|
|
(assert (deriv '(+ x 1 x x) 'x) 3)
|
|
|
|
; d.
|
|
(display "\nd.\n")
|
|
(define (deriv exp var)
|
|
(cond ((number? exp) 0)
|
|
((variable? exp) (if (same-variable? exp var) 1 0))
|
|
(else ((get (operator exp) 'deriv) (operands exp) var))))
|
|
|
|
; All we have to do is to add the procedures to the look-up table
|
|
; in reverse order:
|
|
(put '+ 'deriv (get 'deriv '+))
|
|
(put '* 'deriv (get 'deriv '*))
|
|
(put '** 'deriv (get 'deriv '**))
|
|
|
|
(assert (deriv '(+ x 3) 'x) 1)
|
|
(assert (deriv '(* x 3) 'x) 3)
|
|
(assert (deriv '(* x x) 'x) '(+ x x))
|
|
(assert (deriv '(* (* x y) (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
|
|
|
|
|
|
(newline) (display "ex-2.74") (newline)
|
|
|
|
(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))
|
|
(error
|
|
"No method for these types -- APPLY-GENERIC"
|
|
(list 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 (list-records recs)
|
|
(map (lambda (rec) (display rec) (newline)) (contents recs))
|
|
(newline))
|
|
|
|
(define div1-recs
|
|
(attach-tag
|
|
'div1-type
|
|
'(((family "Martin") (first "Felix") (salary 800)(city "Detroit") (number "+1 313-421-5203"))
|
|
((family "Linus") (first "Torvalds") (salary 120) (city "Helsinki") (number "+42 420-231-3242"))
|
|
((family "Helene") (first "Fischer") (salary 500) (city "Frankfurt") (number "+49 17670120304")))))
|
|
|
|
(define div2-recs
|
|
(attach-tag
|
|
'div2-type
|
|
'(("Barack Obama" (age 55))
|
|
("Tom Brady" (age 33))
|
|
("Michael Jordan" (age 58)))))
|
|
|
|
;(list-records div1-recs)
|
|
;(list-records div2-recs)
|
|
|
|
(define (install-div1-package)
|
|
(define (tag x) (list 'div1-type x))
|
|
(define (get-record key file)
|
|
(cond
|
|
((null? file) #f)
|
|
((equal? (cadr (car (car file))) key) (tag (car file)))
|
|
(else (get-record key (cdr file)))))
|
|
(define (get-salary record)
|
|
(cadr (caddr (car record))))
|
|
; interface to the rest of the system
|
|
(put 'get-record '(key div1-type) get-record)
|
|
(put 'get-salary '(div1-type) get-salary)
|
|
(display "[installed div1 package]") (newline)
|
|
'done)
|
|
|
|
(install-div1-package)
|
|
|
|
(display "a.") (newline)
|
|
; This is the whole function that the headquarter needs. The only things they
|
|
; need from the division is the get-record function and the type tag for the
|
|
; personnel file.
|
|
(define (get-record key division-file)
|
|
(apply-generic 'get-record key division-file))
|
|
|
|
(define martin-rec (get-record (attach-tag 'key "Martin") div1-recs))
|
|
(display martin-rec)
|
|
(newline)
|
|
|
|
(display "b.") (newline)
|
|
; Straight forward. Division has to know how to get the salary for their
|
|
; record.
|
|
(define (get-salary record)
|
|
(apply-generic 'get-salary record))
|
|
(assert (get-salary martin-rec) 800)
|
|
|
|
(display "c.") (newline)
|
|
; Add implementation for div2 so that we can run tests over multiple divisions'
|
|
; records.
|
|
(define (install-div2-package)
|
|
(define (tag x) (list 'div2-type x))
|
|
(define (get-record key file)
|
|
(cond
|
|
((null? file) #f)
|
|
((equal? (car (car file)) key) (tag (car file)))
|
|
(else (get-record key (cdr file)))))
|
|
(define (get-salary record) (error "Not implemented"))
|
|
(put 'get-record '(key div2-type) get-record)
|
|
(put 'get-salary '(div2-type) get-salary)
|
|
(display "[installed div2 package]") (newline)
|
|
'done)
|
|
(install-div2-package)
|
|
|
|
(define (find-employee-record key division-files)
|
|
(if (null? division-files)
|
|
#f
|
|
(let ((record (get-record key (car division-files))))
|
|
(if (not record)
|
|
(find-employee-record key (cdr division-files))
|
|
record))))
|
|
|
|
(assert (get-salary (find-employee-record (attach-tag 'key "Helene") (list div1-recs div2-recs))) 500)
|
|
(assert (find-employee-record (attach-tag 'key "Hilton") (list div1-recs div2-recs)) #f)
|
|
(display (find-employee-record (attach-tag 'key "Tom Brady") (list div1-recs div2-recs)))
|
|
|
|
(display "\nd. - see comments") (newline)
|
|
|
|
; No changes have to be made to the system. The new company only has to provide
|
|
; the defined proceedures and install them into the system.
|
|
|
|
(display "[ok]")
|
|
(newline)
|
|
|
|
(newline) (display "ex-2.75 - message passing") (newline)
|
|
|
|
(define (make-from-mag-ang m a)
|
|
(define (dispatch op)
|
|
(cond ((eq? op 'real-part) (* m (cos a)))
|
|
((eq? op 'imag-part) (* m (sin a)))
|
|
((eq? op 'magnitude) m)
|
|
((eq? op 'angle) a)
|
|
(else
|
|
(error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
|
|
dispatch)
|
|
|
|
(define (apply-generic op arg) (arg op))
|
|
|
|
(define img-num (make-from-mag-ang 1 45))
|
|
|
|
(assert (apply-generic 'magnitude img-num) 1)
|
|
(assert (apply-generic 'angle img-num) 45)
|
|
(display (apply-generic 'real-part img-num))
|
|
(newline)
|
|
(display (apply-generic 'imag-part img-num))
|
|
|
|
(newline) (display "ex-2.76 - see comments") (newline)
|
|
|
|
; Changes that have to be made for new type:
|
|
; explicit-dispatch: each selector has to check for the new type
|
|
; data-directed: all operations for the new type have to be implemented
|
|
; message-passing: all operations for the new type have to be implemented
|
|
|
|
; Changes that have to be made for new operation:
|
|
; explicit-dispatch: none
|
|
; data-directed: the operation has to be implemented for each type
|
|
; message-passing: the operation has to be implemented for each type
|
|
|
|
; For systems where new types are added regularly data-directed or message
|
|
; passing is the best system. When new operations have to be added explicit
|
|
; dispatch is the best system.
|
|
|
|
; I like the answer by torinmr: http://community.schemewiki.org/?sicp-ex-2.76
|
|
|