diff options
Diffstat (limited to 'coding-exercises')
| -rw-r--r-- | coding-exercises/2/30.rkt | 4 | ||||
| -rw-r--r-- | coding-exercises/2/73.rkt | 137 | ||||
| -rw-r--r-- | coding-exercises/2/74.rkt | 62 | ||||
| -rw-r--r-- | coding-exercises/2/75.rkt | 25 | ||||
| -rw-r--r-- | coding-exercises/2/76.rkt | 1 | ||||
| -rw-r--r-- | coding-exercises/2/77.rkt | 9 | ||||
| -rw-r--r-- | coding-exercises/2/78.rkt | 8 |
7 files changed, 189 insertions, 57 deletions
diff --git a/coding-exercises/2/30.rkt b/coding-exercises/2/30.rkt index 785a8dc..b9f079a 100644 --- a/coding-exercises/2/30.rkt +++ b/coding-exercises/2/30.rkt @@ -1,6 +1,6 @@ #lang racket (define (scale-tree tree factor) - (cond ((null? tree) nil) + (cond ((null? tree) '()) ((not (pair? tree)) (* tree factor)) (else (cons (scale-tree (car tree) factor) (scale-tree (cdr tree) factor))))) @@ -18,7 +18,7 @@ ;; (list) ;; (cons (square (car items)) (square-list (cdr items))))) (define (square-tree tree) - (cond ((null? tree) nil) + (cond ((null? tree) '()) ((not (pair? tree)) (* tree tree)) (else (cons (square-tree (car tree)) (square-tree (cdr tree)))))) diff --git a/coding-exercises/2/73.rkt b/coding-exercises/2/73.rkt index f8b4fad..26e456a 100644 --- a/coding-exercises/2/73.rkt +++ b/coding-exercises/2/73.rkt @@ -44,19 +44,20 @@ (error "Not found or bad entry -- GET" op type op-entry)))) (define (put op type item) (if (find-first (make-eq-type? op) dispatch-table) - (set! dispatch-table (map (lambda (op-entry) ;;just copy the table for now, don't want to mutate yet - (if (not (eq? (type-tag op-entry) op)) - op-entry - (attach-tag op - (let ((installed-types (map (lambda (type-entry) - (if (not (eq? (type-tag type-entry) type)) - type-entry - (attach-tag type item))) - (cdr op-entry)))) - (if (find-first (make-eq-type? type) installed-types) - installed-types - (cons (attach-tag type item) installed-types)))))) - dispatch-table)) + (set! dispatch-table + (map (lambda (op-entry) ;;just copy the table for now, don't want to mutate yet + (if (not (eq? (type-tag op-entry) op)) + op-entry + (attach-tag op + (let ((installed-types (map (lambda (type-entry) + (if (not (eq? (type-tag type-entry) type)) + type-entry + (attach-tag type item))) + (cdr op-entry)))) + (if (find-first (make-eq-type? type) installed-types) + installed-types + (cons (attach-tag type item) installed-types)))))) + dispatch-table)) (set! dispatch-table (cons (attach-tag op (list (attach-tag type item))) @@ -67,57 +68,83 @@ (define (putter t) (caddr t)) +(define t (make-dispatch-table)) +(define get (getter t)) +(define put (putter t)) + ;; prefix combination notation of expression? (+ a b) (define (operator ex) - (car ex)) - + (car ex)) (define (operands ex) (cdr ex)) - -(define t (make-dispatch-table)) -(define get (getter t)) -(define put (putter t)) (define (deriv ex var) (cond ((number? ex) 0) ((variable? ex) (if (same-variable? ex var) 1 0)) (else ((get 'deriv (operator ex)) (operands ex) var)))) -(define (=number? x num) - (and (number? x) (= x num))) -(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 (addend s) (car s)) -(define (augend s) - (cond ((null? (cddr s)) (cadr s)) - (else (cons '+ (cdr s))))) +(define (install-basic-deriv-rules) + + (define (=number? x num) + (and (number? x) (= x num))) + (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 (addend s) (car s)) + (define (augend s) + (cond ((null? (cddr s)) (cadr s)) + (else (cons '+ (cdr s))))) + + (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 (multiplier p) + (car p)) + (define (multiplicand p) + (cond ((null? (cddr p)) + (cadr p)) + (else (cons '* (cdr p))))) + + (define (make-exponent e p) + (cond ((=number? p 0) 1) + ((=number? p 1) e) + (else (list '** e p)))) + (define (base expo) + (car expo)) + (define (exponent expo) + (cadr expo)) -(put 'deriv '+ (lambda (ex var) - (make-sum - (deriv (addend ex) var) - (deriv (augend ex) var)))) -(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 (multiplier p) - (car p)) -(define (multiplicand p) - (cond ((null? (cddr p)) - (cadr p)) - (else (cons '* (cdr p))))) + ;;b + (put 'deriv '+ (lambda (ex var) + (make-sum + (deriv (addend ex) var) + (deriv (augend ex) var)))) + (put 'deriv '* (lambda (ex var) + (make-sum + (make-product + (multiplier ex) + (deriv (multiplicand ex) var)) + (make-product + (deriv (multiplier ex) var) + (multiplicand ex))))) + ;;c + (put 'deriv '** (lambda (ex var) + (make-product + (deriv (base ex) var) + (make-product + (exponent ex) + (make-exponent (base ex) (- (exponent ex) 1))))))) -(put 'deriv '* (lambda (ex var) - (make-sum - (make-product - (multiplier ex) - (deriv (multiplicand ex) var)) - (make-product - (deriv (multiplier ex) var) - (multiplicand ex))))) +(install-basic-deriv-rules) (deriv '(+ (* 3 x) (* 2 x)) 'x) +(deriv '(** x 2) 'x) +;;d +;; No changes to the derivative system are necessary so long as (op, 'deriv) points +;; to the same method as ('deriv, op) in the dispatch table of the consuming package. +;; I guess you could argue that the put arguments should be reversed in the derivative system. +;; But the actual items in the dispatch table don't have to change since the call signature is the same. diff --git a/coding-exercises/2/74.rkt b/coding-exercises/2/74.rkt new file mode 100644 index 0000000..c6bc137 --- /dev/null +++ b/coding-exercises/2/74.rkt @@ -0,0 +1,62 @@ +#lang racket +(require "../../shared/data-directed-programming.rkt") +(require "../../shared/lists.rkt") + +(define test-dispatch (make-dispatch-table)) +(define get (getter test-dispatch)) +(define put (putter test-dispatch)) + +;; Example implementations +(define test-division (attach-tag + 'division-a + (list (attach-tag + 'henk + (list (attach-tag 'salary 100)))))) +(put 'record 'division-a (lambda (file-set employee) + (let ((record (find-first + (make-eq-type? employee) + file-set))) + (if record + record + (error "Employee record not found -- GET-RECORD DIVISION-A" employee))))) +(put 'salary 'division-a (lambda (record) + (let ((salary (find-first + (make-eq-type? 'salary) + record))) + (if salary + salary + (error "Salary not found -- GET-SALARY DIVISION-A" record))))) + +;;a Each divisions file must be a datum tagged with the divisions name. +;; Together with the division type tag and an operation type tag +;; we can get a procedure that knows how to do that operation for the given employee. +(define (get-record file employee) + ((get 'record (type-tag file)) (contents file) employee)) + +(define test-record (get-record test-division 'henk)) + +;; b The record can have any structure that is handled by the salary procedure of the +;; division we dispatch the procedure from +(define (get-salary file record) + ((get 'salary (type-tag file)) (contents record))) + + +(get-salary test-division test-record) + +;;c +(define (find-employee-record files employee) + (define (search fi) + (if (null? fi) + false + (let ((result (with-handlers + ([exn:fail? (lambda (exn) + false)]) + (get-record (car fi) employee)))) + (if result + result + (search (cdr fi)))))) + (search files)) +(find-employee-record (list test-division test-division) 'henk) + +;;d +;; new implementations for the division representation for the existing operations on a type diff --git a/coding-exercises/2/75.rkt b/coding-exercises/2/75.rkt new file mode 100644 index 0000000..4a5cf23 --- /dev/null +++ b/coding-exercises/2/75.rkt @@ -0,0 +1,25 @@ +#lang racket + +(define (make-from-mag-ang mag ang) + (define (dispatch op) + (cond ((eq? op 'real-part) (* mag (cosine ang))) + ((eq? op 'imag-part) (* mag (sine ang))) + ((eq? op 'magnitude) mag) + ((eq? op 'angle) ang) + (else (error "Unknown op -- MAKE-FROM-MAG-ANG" op)))) + dispatch) + +;; Explicit dispatch +;; The logic for dispatching has to be repeated for every operation and every type. +;; If there are a number of representations for a type or multiple operations, this is not what you want. +;; +;; data dispatch +;; If new operations need to be added then we have to extend all existing type packages to support dispatching the operation to those types. +;; When adding new types we need to install a dispatchable procedure for every operation only in the new type package. +;; +;; message passing +;; If new operations need to be added then we have to add a message handling case to all data representations. +;; When adding new types we need to make a procedure that handles all operation messages. +;; +;; In general I think if the operation is less smart then it is easier to add to a system, that's why message passing is more appropriate if you often need to add operations. +;; The same goes for data dispatching, if the operations are smart, the data doesn't have to be. This makes adding more data representations more convenient. diff --git a/coding-exercises/2/76.rkt b/coding-exercises/2/76.rkt new file mode 100644 index 0000000..6f1f7b4 --- /dev/null +++ b/coding-exercises/2/76.rkt @@ -0,0 +1 @@ +#lang racket diff --git a/coding-exercises/2/77.rkt b/coding-exercises/2/77.rkt new file mode 100644 index 0000000..65feaf3 --- /dev/null +++ b/coding-exercises/2/77.rkt @@ -0,0 +1,9 @@ +#lang racket + +;; (apply-generic 'magnitude z) +;; This strips the complex type-tag from z and passes the contents to the generic magnitude procedure defined in the complex package. +;; The magnitude procedure is responsible for dispatching the operation to the magnitude procedure of either the rectangular or the polar form representation. +;; (apply-generic 'magnitude z) +;; This strips away the rectangular type tag of the args and passes the contents of the args to the corresponding 'magnitude '(rectangular) procedure. +;; In the end the rectangular magnitude procedure's return value is bubbled up to the calling function. +(print "hi") diff --git a/coding-exercises/2/78.rkt b/coding-exercises/2/78.rkt new file mode 100644 index 0000000..3a4b100 --- /dev/null +++ b/coding-exercises/2/78.rkt @@ -0,0 +1,8 @@ +#lang racket +(require "../../shared/data-directed-programming.rkt") +;; We are basically making a data directed framework for arithmethic operations in this module +(define pkg (make-dispatch-table)) +(define put (putter pkg)) +(define get (getter pkg)) +(define apply-generic (make-apply put get)) + |