From 0410f4d64a6845bcd7a2b2554c96deaa589a0c6a Mon Sep 17 00:00:00 2001 From: Mike Vink Date: Sun, 30 Apr 2023 18:03:38 +0200 Subject: 83 and 84 --- coding-exercises/2/81.rkt | 1 - coding-exercises/2/83.rkt | 243 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 243 insertions(+), 1 deletion(-) create mode 100644 coding-exercises/2/83.rkt (limited to 'coding-exercises') diff --git a/coding-exercises/2/81.rkt b/coding-exercises/2/81.rkt index c0af5ae..4b7a108 100644 --- a/coding-exercises/2/81.rkt +++ b/coding-exercises/2/81.rkt @@ -107,4 +107,3 @@ (if proc (apply proc (map contents args)) (try-coerce type-tags op args)))))) - diff --git a/coding-exercises/2/83.rkt b/coding-exercises/2/83.rkt new file mode 100644 index 0000000..26a8ea8 --- /dev/null +++ b/coding-exercises/2/83.rkt @@ -0,0 +1,243 @@ +#lang racket +(require "../../shared/data-directed-programming.rkt") +(require "../../shared/lists.rkt") +(require "./78/scheme-number.rkt") +(require "./78/install-rational-package.rkt") +(require "./78/install-complex-package.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 print-tbl (printer pkg)) + + +(define coercion (make-dispatch-table)) +(define put-coercion (putter coercion)) +(define get-coercion (getter coercion)) +(define print-coercion (printer coercion)) + +(define apply-generic (make-apply get)) +(define apply-coercion (make-apply-with-coercion get get-coercion)) + +;; stores integers as exact racket integers +(define (install-integer put get) + ;; local methods + (define (tagme datum) + (attach-tag 'integer datum)) + (define (make i) + (inexact->exact (round i))) + (define (raiseme i) + (if (equal? (type-tag i) 'integer) + ((get 'make 'rational) i 1) + (error "cannot raise non integer in integer package"))) + ;; constructor + (put 'make 'integer (lambda (x) (tagme (make x)))) + ;; methods + (put 'add '(integer integer) (lambda (x y) (tagme (make (+ x y))))) + (put 'sub '(integer integer) (lambda (x y) (tagme (make (- x y))))) + (put 'mul '(integer integer) (lambda (x y) (tagme (make (* x y))))) + (put 'div '(integer integer) (lambda (x y) (tagme (make (/ x y))))) + (put 'raise '(integer) raiseme) + ;; predicates + (put 'equ? '(integer integer) (lambda (x y) (= x y))) + (put '=zero? '(integer) (lambda (x) (= 0 x))) + 'done) + +;; stores rationals as custom data object +(define (install-rational put get) + ;; local methods + (define (tagme x) (attach-tag 'rational x)) + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (add-rat x y) + (make-rat (+ (* (numer x) (denom y)) + (* (numer y) (denom x))) + (* (denom x) (denom y)))) + (define (sub-rat x y) + (make-rat (- (* (numer x) (denom y)) + (* (numer y) (denom x))) + (* (denom x) (denom y)))) + (define (mul-rat x y) + (make-rat (* (numer x) (numer y)) + (* (denom x) (denom y)))) + (define (div-rat x y) + (make-rat (* (numer x) (denom y)) + (* (denom x) (numer y)))) + (define (equ? x y) + (and (equal? (numer x) (numer y)) + (equal? (denom x) (denom y)))) + (define (=zero? x) + (equal? (numer x) 0)) + + (define (make-rat n d) + (define (sign x) + (cond + ((and (< x 0) (< d 0)) (* -1 x)) + ((and (< 0 x) (< d 0)) (* -1 x)) + (else x))) + (let ((g (gcd n d))) + (cons (sign (/ n g)) (abs (/ d g))))) + + (define (raiseme rat) + ((get 'make 'real) (/ (numer rat) (denom rat)))) + + ;; constructor + (put 'make 'rational + (lambda (x y) (tagme (make-rat x y)))) + + ;; interface + (put 'add '(rational rational) + (lambda (x y) (tagme (add-rat x y)))) + (put 'sub '(rational rational) + (lambda (x y) (tagme (sub-rat x y)))) + (put 'mul '(rational rational) + (lambda (x y) (tagme (mul-rat x y)))) + (put 'div '(rational rational) + (lambda (x y) (tagme (div-rat x y)))) + (put 'raise '(rational) raiseme) + + ;; predicates + (put 'equ? '(rational rational) + (lambda (x y) (equ? x y))) + (put '=zero? '(rational) + (lambda (x) (=zero? x))) + 'done) + +;; stores reals as inexact racket numbers +(define (install-real put get) + ;; local methods + (define (tagme datum) + (attach-tag 'real datum)) + (define (make i) + (exact->inexact i)) + (define (raiseme r) + ((get 'make-from-real-imag 'complex) r 0)) + ;; constructor + (put 'make 'real (lambda (x) (tagme (make x)))) + ;; methods + (put 'add '(real real) (lambda (x y) (tagme (make (+ x y))))) + (put 'sub '(real real) (lambda (x y) (tagme (make (- x y))))) + (put 'mul '(real real) (lambda (x y) (tagme (make (* x y))))) + (put 'div '(real real) (lambda (x y) (tagme (make (/ x y))))) + (put 'raise '(real) raiseme) + ;; predicates + (put 'equ? '(real real) (lambda (x y) (= x y))) + (put '=zero? '(real) (lambda (x) (= 0 x))) + 'done) + +;; stores complex numbers as custom data type +(install-integer put get) +(install-rational put get) +(install-real put get) +;; use from previous exercise +(install-complex-package apply-generic get put) + +;; test running +;; integer +(define (make-integer n) + ((get 'make 'integer) n)) +(define test-num (make-integer 3)) + +;; rational +(define (make-rat n d) + ((get 'make 'rational) n d)) +(define test-rat (make-rat 1 2)) + +;; real +(define (make-real n) + ((get 'make 'real) n)) +(define test-real (make-real 1.5)) + +;; complex +(define (make-complex x y) + ((get 'make-from-real-imag 'complex) x y)) +(define test-complex (make-complex 1 2)) + +(define (raisetower datum) + (apply-coercion 'raise datum)) + +;; ((lambda () +;; (display test-num) +;; (newline) +;; (display test-rat) +;; (newline) +;; (display test-real) +;; (newline) +;; (display test-complex) +;; (newline) +;; (display (raisetower 1)) +;; (newline) +;; (display (raisetower test-rat)) +;; (newline) +;; (display (raisetower test-real)) +;; (newline))) + + +;; 84 +(define (type-match? args) + (not (find-first (lambda (x) + (not (equal? (type-tag x) + (type-tag (car args))))) + args))) +(define (count-raises-until-top apply-generic datum) + (define (iter i raised) + (let ((result (apply-generic 'raise raised))) + (if result + (iter (+ i 1) result) + i))) + (iter 0 datum)) + + + +(define (highest-type apply-generic items) + (cdr + (foldl + (lambda (raises item result) + (cond ((< (car result) 0) (cons raises item)) + ((< raises (car result)) (cons raises item)) + (else result))) + (cons -1 'nil) + (map (lambda (x) + (count-raises-until-top apply-generic x)) + items) + (map type-tag items)))) + +(define (raise-until apply-generic type datum) + (cond ((equal? type (type-tag datum)) datum) + (else (let ((result (apply-generic 'raise datum))) + (if result + (raise-until apply-generic type result) + false))))) + +(define (raise-until-type-match apply-generic type items) + (cond ((null? items) '()) + (else (let ((result (raise-until apply-generic type (car items)))) + (if result + (cons result (raise-until-type-match apply-generic type (cdr items))) + (error "Could not raise type --" (list type items))))))) + +; (raise-until-type-match (make-apply-pred get) +; (highest-type (make-apply-pred get) (list 1 test-complex)) +; (list 1 test-complex))))))) + + +(define (make-apply-with-raising apply-generic get) + (lambda (op . args) + (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-result (apply apply-generic (cons op raised-args)))) + (if raised-result + raised-result + (error "Could not apply --" (list op args raised-args))))))))) + +(define apply-with-raising (make-apply-with-raising (make-apply-pred get) get)) +((lambda () + (newline) + (apply-with-raising 'add 1 test-complex))) + +;; 85 +;; lowerable? +(define (project datum) + datum) -- cgit v1.2.3