diff options
| -rw-r--r-- | coding-exercises/2/78/install-complex-package.rkt | 2 | ||||
| -rw-r--r-- | coding-exercises/2/83/install.rkt | 50 | ||||
| -rw-r--r-- | coding-exercises/2/87.rkt | 90 | ||||
| -rw-r--r-- | shared/data-directed-programming.rkt | 55 |
4 files changed, 157 insertions, 40 deletions
diff --git a/coding-exercises/2/78/install-complex-package.rkt b/coding-exercises/2/78/install-complex-package.rkt index a99b7d5..e332351 100644 --- a/coding-exercises/2/78/install-complex-package.rkt +++ b/coding-exercises/2/78/install-complex-package.rkt @@ -42,7 +42,7 @@ (and (= (real-part z1) (real-part z2)) (= (imag-part z1) (imag-part z2)))) (define (=zero? z) - (and (= (real-part z)) (= (imag-part z)))) + (and (= (real-part z) 0) (= (imag-part z) 0))) ;; interface (define (typetag z) (attach-tag 'complex z)) diff --git a/coding-exercises/2/83/install.rkt b/coding-exercises/2/83/install.rkt index 109862e..0cd8bbf 100644 --- a/coding-exercises/2/83/install.rkt +++ b/coding-exercises/2/83/install.rkt @@ -11,7 +11,21 @@ make-complex-rect test-complex-rect make-complex-polar - test-complex-polar) + test-complex-polar + =zero? + equ? + add + sub + mul + div + sinme + cosme + atanme + sqrme + sqrtme + raiseme + dropme) + (require "./install-integer.rkt" "./install-rational.rkt" "./install-real.rkt" @@ -34,7 +48,7 @@ (define (install-arithmetic-package) (list get put apply-fn)) -;; test running +;; constructors ;; integer (define (make-integer n) ((get 'make 'integer) n)) @@ -60,3 +74,35 @@ (define test-complex (make-complex 1 2)) (define test-complex-rect (make-complex-rect 1 2)) (define test-complex-polar (make-complex-rect 1 2)) + +;; polynomial +(define (make-polynomial var terms) + ((get 'make 'polynomial) var terms)) + +;; generic methods +(define (equ? a1 a2) + (apply-fn 'equ? a2)) +(define (=zero? datum) + (apply-fn '=zero? datum)) +(define (add a1 a2) + (apply-fn 'add a1 a2)) +(define (sub a1 a2) + (apply-fn 'sub a1 a2)) +(define (mul a1 a2) + (apply-fn 'mul a1 a2)) +(define (div a1 a2) + (apply-fn 'div a1 a2)) +(define (raiseme datum) + (apply-fn 'raise datum)) +(define (dropme datum) + (apply-fn 'project datum)) +(define (sqrme datum) + (apply-fn 'sqr datum)) +(define (sqrtme datum) + (apply-fn 'sqrt datum)) +(define (cosme datum) + (apply-fn 'cos datum)) +(define (sinme datum) + (apply-fn 'sin datum)) +(define (atanme a1 a2) + (apply-fn 'atan a2)) diff --git a/coding-exercises/2/87.rkt b/coding-exercises/2/87.rkt index 6c2a3f6..d73093e 100644 --- a/coding-exercises/2/87.rkt +++ b/coding-exercises/2/87.rkt @@ -1,4 +1,5 @@ #lang racket +(require "../../shared/data-directed-programming.rkt") (require "./83/install.rkt") ;; arithmetic package (define get-put-apply (install-arithmetic-package)) @@ -10,35 +11,96 @@ ;; internal procedures (define (tagme p) (attach-tag 'polynomial p)) - ;;repr + (define (variable? x) (symbol? x)) + (define (same-variable? x y) (and (variable? x) (variable? y) (eq? x y))) + + ;; terms + (define (make-term order coeff) (list order coeff)) + (define (order term) (car term)) + (define (coeff term) (cadr term)) + + ;; termlists + (define (adjoin-term term term-list) + (if (=zero? (coeff term)) + term-list + (cons term term-list))) + (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) (null? term-list)) + + ;; polys (define (make-poly variable term-list) (cons variable term-list)) (define (variable p) (car p)) (define (term-list p) (cdr p)) - ;; preds - (define (variable? x) (symbol? x)) - (define (same-variable? x y) (and (variable? x) (variable? y) (eq? x y))) - ;; term list - (define (adjoin-term term-list term) - '()) - (define (coeff term) - '()) + ;; ops + (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 t2) + (order t1)) + (adjoin-term + t2 (add-terms L1 (rest-terms L2)))) + (else + (adjoin-term + (make-term + (order t1) + (apply-fn 'add (coeff t1) (coeff t2))) + (add-terms (rest-terms L1) + (rest-terms L2))))))))) (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 (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 (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-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))))) - ;; interface) - - - + (error "Polys not in same var -- MUL-POLY" (list p1 p2)))) + ;;interface + (put 'add '(polynomial polynomial) (lambda (p1 p2) (tagme (add-poly p1 p2)))) + (put 'mul '(polynomial polynomial) (lambda (p1 p2) (tagme (mul-poly p1 p2)))) + (put 'make 'polynomial + (lambda (var terms) (tagme (make-poly var terms)))) + 'done) +(install-polynomial-package put) +(define (make-polynomial var terms) + ((get 'make 'polynomial) var terms)) +(define test-poly1 (make-polynomial 'x (list + (list 1 test-integer)))) +(define test-poly2 (make-polynomial 'x (list + (list 100 test-complex) + (list 3 test-real) + (list 1 test-rat) + (list 0 test-integer)))) +((lambda () + (newline) + (display (add test-poly2 test-poly2)))) diff --git a/shared/data-directed-programming.rkt b/shared/data-directed-programming.rkt index abaa498..4b4762c 100644 --- a/shared/data-directed-programming.rkt +++ b/shared/data-directed-programming.rkt @@ -28,6 +28,7 @@ ((exact-integer? datum) 'integer) ((inexact-real? datum) 'real) ((number? datum) 'scheme-number) + ((boolean? datum) 'boolean) (else (error "Bad tagged datum -- TYPE-TAG" datum)))) (define (contents datum) (cond @@ -109,6 +110,14 @@ (apply proc (map contents args)) false))))) +(define (make-apply-pred-symbol get) + (lambda (op . args) + (let ((type-tags (map type-tag args))) + (let ((proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + false))))) + (define (make-apply-with-coercion get get-coercion) (define (make-apply get) (lambda (op . args) @@ -157,15 +166,15 @@ (not (equal? (type-tag x) (type-tag (car args))))) args))) -(define (count-raises-until-top apply-pred datum) +(define (count-raises-until-top get datum) (define (iter i raised) - (let ((result (apply-pred 'raise raised))) - (if result - (iter (+ i 1) result) + (let ((proc (get 'raise (list (type-tag raised))))) + (if proc + (iter (+ i 1) (proc (contents raised))) i))) (iter 0 datum)) -(define (highest-type apply-pred items) +(define (highest-type get items) (cdr (foldl (lambda (raises item result) @@ -174,22 +183,22 @@ (else result))) (cons -1 'nil) (map (lambda (x) - (count-raises-until-top apply-pred x)) + (count-raises-until-top get x)) items) (map type-tag items)))) -(define (raise-until apply-pred type datum) +(define (raise-until get type datum) (cond ((equal? type (type-tag datum)) datum) - (else (let ((result (apply-pred 'raise datum))) - (if result - (raise-until apply-pred type result) + (else (let ((proc (get 'raise (list (type-tag datum))))) + (if proc + (raise-until get type (proc (contents datum))) false))))) -(define (raise-until-type-match apply-pred type items) +(define (raise-until-type-match get type items) (cond ((null? items) '()) - (else (let ((result (raise-until apply-pred type (car items)))) + (else (let ((result (raise-until get type (car items)))) (if result - (cons result (raise-until-type-match apply-pred type (cdr items))) + (cons result (raise-until-type-match get type (cdr items))) (error "Could not raise type --" (list type items))))))) ; (raise-until-type-match (make-apply-pred get) @@ -202,15 +211,14 @@ (let ((result (apply apply-generic (cons op args)))) (if result result - (let ((raised-args (raise-until-type-match apply-generic (highest-type apply-generic args) args))) + (let ((raised-args (raise-until-type-match get (highest-type get args) args))) (let ((raised-result (apply apply-generic (cons op raised-args)))) (if raised-result raised-result (error "Could not apply --" (list op args raised-args))))))))) (define (make-apply-with-raising-and-drop get) - (define apply-pred (make-apply-pred get)) - + (define apply-pred (make-apply get)) (define (raisetower datum) (apply-pred 'raise datum)) @@ -223,6 +231,7 @@ (define (can-drop? datum) (equ? (raisetower (project datum)) datum)) + (define (towerdrop datum) (cond ((and (get 'project (list (type-tag datum))) (can-drop? datum)) @@ -230,11 +239,11 @@ (else datum))) (lambda (op . args) - (let ((result (apply apply-pred (cons op args)))) - (if result - (towerdrop result) - (let ((raised-args (raise-until-type-match apply-pred (highest-type apply-pred args) args))) - (let ((raised-result (apply apply-pred (cons op raised-args)))) - (if raised-result - (towerdrop raised-result) + (let ((proc (get op (map type-tag args)))) + (if proc + (towerdrop (apply proc (map contents args))) + (let ((raised-args (raise-until-type-match get (highest-type get args) args))) + (let ((raised-proc (get op (map type-tag raised-args)))) + (if raised-proc + (towerdrop (apply raised-proc (map contents raised-args))) (error "Could not apply --" (list op args raised-args))))))))) |