From ef8fd9c3e94f37ab4cdd73601cef9d35724ff79a Mon Sep 17 00:00:00 2001 From: Mike Vink Date: Sun, 7 May 2023 19:05:38 +0200 Subject: fix projecting with rationals? --- coding-exercises/2/83/install-rational.rkt | 17 +++++++++++++--- coding-exercises/2/83/install-real.rkt | 2 +- coding-exercises/2/83/install.rkt | 32 +++++++++++++++--------------- coding-exercises/2/93.rkt | 18 +++++++++-------- shared/data-directed-programming.rkt | 29 +++++++++++++++++---------- 5 files changed, 60 insertions(+), 38 deletions(-) diff --git a/coding-exercises/2/83/install-rational.rkt b/coding-exercises/2/83/install-rational.rkt index d1c94fc..334f802 100644 --- a/coding-exercises/2/83/install-rational.rkt +++ b/coding-exercises/2/83/install-rational.rkt @@ -69,8 +69,20 @@ (let ((g (gcd n d))) (cons (sign (/ n g)) (abs (/ d g))))) + (define (dropme rat) + (display (list (numer rat) (denom rat))) + (display (list (integer? (numer rat)) (integer? (denom rat)))) + (if (and (integer? (numer rat)) + (integer? (denom rat))) + ((get 'make 'integer) (/ (numer rat) (denom rat))) + (list 'undefined))) (define (raiseme rat) - ((get 'make 'real) (/ (numer rat) (denom rat)))) + (display (list (numer rat) (denom rat))) + (display (list (integer? (numer rat)) (integer? (denom rat)))) + (if (and (integer? (numer rat)) + (integer? (denom rat))) + ((get 'make 'real) (/ (numer rat) (denom rat))) + (list 'undefined))) ;; constructor (put 'make 'rational @@ -89,8 +101,7 @@ (put 'div '(rational rational) (lambda (x y) (tagme (div-rat x y)))) (put 'raise '(rational) raiseme) - (put 'project '(rational) (lambda (rat) - ((get 'make 'integer) (/ (numer rat) (denom rat))))) + (put 'project '(rational) dropme) ;; sqrt and trig methods for complex nums (put 'sqr '(rational) (lambda (r) (sqr (raiseme r)))) (put 'sqrt '(rational) (lambda (r) (sqrt (raiseme r)))) diff --git a/coding-exercises/2/83/install-real.rkt b/coding-exercises/2/83/install-real.rkt index 45b1a6c..d82d48a 100644 --- a/coding-exercises/2/83/install-real.rkt +++ b/coding-exercises/2/83/install-real.rkt @@ -24,7 +24,7 @@ (put 'div '(real real) (lambda (x y) (tagme (make (/ x y))))) (put 'raise '(real) raiseme) (put 'project '(real) (lambda (n) - ((get 'make 'rational) (round n) 1))) + ((get 'make 'rational) n 1.0))) ;; sqrt and trig methods for complex nums (put 'sqr '(real) sqr) (put 'sqrt '(real) sqrt) diff --git a/coding-exercises/2/83/install.rkt b/coding-exercises/2/83/install.rkt index 5a4f72a..fcaff0b 100644 --- a/coding-exercises/2/83/install.rkt +++ b/coding-exercises/2/83/install.rkt @@ -11,14 +11,14 @@ make-complex-rect test-complex-rect make-complex-polar - test-complex-polar + ;test-complex-polar term dense-termlist sparse-termlist make-polynomial - test-poly1 - test-poly2 - test-poly3 + ; test-poly1 + ; test-poly2 + ; test-poly3 =zero? equ? add @@ -82,8 +82,8 @@ ((get 'make-from-mag-ang 'complex) x y)) (define test-complex (make-complex 1 2)) (define test-complex-rect (make-complex-rect 1 2)) -(define test-complex-polar (make-complex-polar (apply-fn 'magnitude test-complex) - (apply-fn 'angle test-complex))) +(display (apply-fn 'magnitude test-complex)) +;; (define test-complex-polar (make-complex-polar (apply-fn 'magnitude test-complex) (apply-fn 'angle test-complex))) ;; polynomial (define (term order coeff) @@ -94,16 +94,16 @@ ((get 'make-from-terms 'dense-termlist) terms)) (define (make-polynomial var terms) ((get 'make 'polynomial) var terms)) -(define test-poly1 (make-polynomial 'x (sparse-termlist - (term 1 test-integer)))) -(define test-poly2 (make-polynomial 'x (sparse-termlist - (term 100 test-complex) - (term 2 test-real) - (term 1 test-rat) - (term 0 test-integer)))) -(define test-poly3 (make-polynomial 'x (sparse-termlist - (term 50 test-rat) - (term 0 2)))) +; (define test-poly1 (make-polynomial 'x (sparse-termlist +; (term 1 test-integer))) +; (define test-poly2 (make-polynomial 'x (sparse-termlist +; (term 100 test-complex) +; (term 2 test-real) +; (term 1 test-rat) +; (term 0 test-integer)))) +; (define test-poly3 (make-polynomial 'x (sparse-termlist +; (term 50 test-rat) +; (term 0 2)))) ;; generic methods (define (equ? a1 a2) diff --git a/coding-exercises/2/93.rkt b/coding-exercises/2/93.rkt index 4fe754e..a4067d1 100644 --- a/coding-exercises/2/93.rkt +++ b/coding-exercises/2/93.rkt @@ -8,13 +8,15 @@ (define apply-fn (caddr get-put-apply)) ;; something -(define p1 (make-polynomial 'x (sparse-termlist - (term 2 1) (term 0 1)))) -(define p2 (make-polynomial 'x (sparse-termlist - (term 3 1) (term 0 1)))) -(define rf (make-rat p2 p1)) +;; (define p1 (make-polynomial 'x (sparse-termlist +;; (term 2 1) (term 0 1))) +;; (define p2 (make-polynomial 'x (sparse-termlist +;; (term 3 1) (term 0 1)))) +;; (define rf (make-rat p2 p1)) ((lambda () (newline) - (display rf) - (newline) - (display (add rf rf)))) + (display (add 1 (make-rat 2 1))))) + ;; (newline) + ;; (display rf) + ;; (newline) + ;; (display (add rf rf)))) diff --git a/shared/data-directed-programming.rkt b/shared/data-directed-programming.rkt index 92a7e14..decdf0f 100644 --- a/shared/data-directed-programming.rkt +++ b/shared/data-directed-programming.rkt @@ -218,31 +218,40 @@ (error "Could not apply --" (list op args raised-args))))))))) (define (make-apply-with-raising-and-drop get) - (define apply-pred (make-apply get)) + (define local-apply (make-apply get)) + (define (raisetower datum) - (apply-pred 'raise datum)) + (local-apply 'raise datum)) (define (project datum) - (apply-pred 'project datum)) + (local-apply 'project datum)) (define (equ? d1 d2) - (apply-pred 'equ? d1 d2)) + (local-apply 'equ? d1 d2)) (define (can-drop? datum) - (equ? (raisetower (project datum)) - datum)) + (let ((dropped (project datum))) + (let ((raised (raisetower dropped))) + (and (get 'equ? (list (type-tag raised) (type-tag datum))) + (equ? raised datum))))) + (define (projectable? datum) + (get 'project (list (type-tag datum)))) (define (towerdrop datum) - (cond ((and (get 'project (list (type-tag datum))) - (can-drop? datum)) - (towerdrop (project datum))) - (else datum))) + (if (projectable? datum) + (cond ((can-drop? datum) + (towerdrop (project datum))) + (else datum)) + datum)) (lambda (op . args) (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))) + (newline) + (display (list "RAISED -- " raised-args)) + (newline) (let ((raised-proc (get op (map type-tag raised-args)))) (if raised-proc (towerdrop (apply raised-proc (map contents raised-args))) -- cgit v1.2.3