Permalink
Browse files

coercion

  • Loading branch information...
1 parent 7d14584 commit 5762299066fad53473c36d215bcad7858f47aa45 @sarabander committed Oct 14, 2011
Showing with 440 additions and 0 deletions.
  1. +95 −0 2.5/2.81.scm
  2. +73 −0 2.5/2.82.scm
  3. +34 −0 2.5/2.83.scm
  4. +79 −0 2.5/2.84.scm
  5. +121 −0 2.5/2.85.scm
  6. +38 −0 2.5/2.86.scm
View
@@ -0,0 +1,95 @@
+
+;; See setup.scm in subdirectory 'generic-arithmetic' for hash-table setup and
+;; arithmetic packages. The numbers num1, num2, r1, r2, c1, etc. are defined
+;; in the file tests.scm.
+
+;; Helper function
+(define (all-same? symbols)
+ (if (empty? (cdr symbols))
+ true
+ (and (eq? (car symbols) (cadr symbols))
+ (all-same? (cdr symbols)))))
+
+(all-same? '(complex complex complex)) ; true
+(all-same? '(integer rational complex)) ; false
+
+;; The original
+(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))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+;; Coersion of type to itself
+(define (scheme-number->scheme-number n) n)
+(define (complex->complex z) z)
+(put-coercion 'scheme-number 'scheme-number
+ scheme-number->scheme-number)
+(put-coercion 'complex 'complex complex->complex)
+
+;; a. This results in infinite loop.
+
+;; b. It works when an operation is found for these argument types.
+
+;; c. Infinite loop is prevented:
+
+(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))
+ (if (all-same? type-tags) ; added clause
+ (error "Matching types, but no operation available"
+ (list op type-tags))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags))))))))
+
+;; Tests
+(apply-generic 'add num1 num2) ; '(scheme-number . 16)
+
+(apply-generic 'add
+ (make-complex-from-real-imag -1 4)
+ (make-scheme-number 3))
+; '(complex rectangular 2 . 4)
+
+(apply-generic 'mod c1 c1)
+; Matching types, but no operation available (mod (complex complex))
+
+(div c1 c1) ; '(complex polar 1 . 0.0)
+
+(add (contents c2) (contents c2))
+; Matching types, but no operation available (add (polar polar))
+
+(get 'add '(polar polar)) ; false
+
+(sub r1 r2) ; '(rational -1 . 12)
View
@@ -0,0 +1,73 @@
+
+;; General version accepting arbitrary number of arguments
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (define (typecasts typelist) ; tries to find a typecast function for every
+ (if (empty? typelist) ; type recursively, returns list of functions
+ (error "Cannot coerce all arguments to same type")
+ (let* ((targettype (car typelist))
+ (proclist (map (λ (typepair) (apply get-coercion typepair))
+ (map (λ (type) (cons type (list targettype)))
+ type-tags))))
+ (if (empty? (filter false? proclist))
+ proclist
+ (typecasts (cdr typelist))))))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (all-same? type-tags) ; added clause
+ (error "Matching types, but no operation available"
+ (list op type-tags))
+ (apply apply-generic (cons op (map (λ (f arg)
+ (f arg))
+ (typecasts type-tags)
+ args))))))))
+
+;; This indeed attempts to apply the operation to arguments only when
+;; the arguments are all the same type. As an example of legal operation
+;; with different argument types would be exponentiating a real number
+;; with a complex number or vice versa. Current system remains blind
+;; to this possibility.
+
+;; Tests
+(define (install-3-argument-add)
+ (define (tag z) (attach-tag 'complex z))
+ (define (add-complex z1 z2 z3)
+ (make-from-real-imag (+ (real-part z1) (real-part z2) (real-part z3))
+ (+ (imag-part z1) (imag-part z2) (imag-part z3))))
+ (put 'add '(complex complex complex)
+ (lambda (z1 z2 z3) (tag (add-complex z1 z2 z3))))
+ 'done)
+
+(install-3-argument-add)
+
+(apply-generic 'add c2 c1 c1) ; '(complex rectangular 7.0 . 9.0)
+(apply-generic 'add c1 num1 num1) ; '(complex rectangular 27 . 4)
+(apply-generic 'add num1 num2 c1) ; '(complex rectangular 19 . 4)
+(apply-generic 'add num2 c2 c1) ; '(complex rectangular 8.0 . 5.0)
+
+((get-coercion 'scheme-number 'complex) num2)
+((get-coercion 'scheme-number 'scheme-number) num1)
+((get-coercion 'complex 'complex) c2)
+
+;; Debugging constructs
+(define (extract-types op . args)
+ (map type-tag args))
+
+(extract-types 'a num1 num2 c2)
+
+(define cproclist
+ (map (λ (typepair) (apply get-coercion typepair))
+ (map (λ (type) (cons type (list 'complex)))
+ (extract-types 'a num1 num2 c2))))
+
+
+(if (empty? (filter false? cproclist))
+ cproclist
+ 'nonempty)
+
+(apply apply-generic
+ (cons 'add (map (λ (coercionproc arg)
+ (coercionproc (eval arg)))
+ cproclist
+ '(num1 num2 c1))))
View
@@ -0,0 +1,34 @@
+
+;; integer → rational → real → complex
+
+;; See generic-arithmetic/setup.scm for coercion definitions.
+
+;; Raising functions
+(define raise-integer (get-coercion 'integer 'rational))
+(define raise-rational (get-coercion 'rational 'real))
+(define raise-real (get-coercion 'real 'complex))
+(define (raise-complex z) z)
+
+;; Generic raise
+(define (raise num)
+ ((get-coercion (type-tag num) 'raise) num))
+
+(define (install-raise-package)
+ (put-coercion 'integer 'raise raise-integer)
+ (put-coercion 'rational 'raise raise-rational)
+ (put-coercion 'real 'raise raise-real)
+ (put-coercion 'complex 'raise raise-complex)
+ 'done)
+
+(install-raise-package)
+
+;; Tests
+(raise-integer num2) ; '(rational 4 . 1)
+(raise-rational r1) ; '(real 0.75)
+(raise-real (make-real 6.2)) ; '(complex rectangular (6.2) . 0)
+(raise-complex c1) ; unchanged
+
+(raise (make-integer 7)) ; '(rational 7 . 1)
+(raise r1) ; '(real . 0.75)
+(raise (make-real 5.3)) ; '(complex rectangular 5.3 . 0)
+(raise c1) ; '(complex rectangular 3 . 4)
View
@@ -0,0 +1,79 @@
+
+;; First, we draw ourselves a clear picture of the current type tower.
+;; If the tower changes, we just need to call 'build-type-tower' again.
+
+;; testnum is typed number,
+;; rank is type's "floor number",
+;; tower is a hashmap
+(define (build-type-tower testnum rank tower)
+ (let ((next-up (raise testnum))
+ (type (type-tag testnum)))
+ (hash-set! tower type rank)
+ (if (eq? type (type-tag next-up))
+ tower
+ (build-type-tower next-up (add1 rank) tower))))
+
+;; This probes the type hierarchy by successively raising the given
+;; test number's type higher until top is reached. Highest type is
+;; it's own supertype, e.g. (raise 'complex) -> 'complex. The procedure
+;; returns a hashmap, where type is the key and height in type hierarchy
+;; is the value.
+
+(define type-tower
+ (build-type-tower (make-integer 2) 1 (make-hash)))
+
+type-tower ; '#hash((integer . 1) (rational . 2) (real . 3) (complex . 4))
+
+(hash-ref type-tower 'integer false) ; 1
+(hash-ref type-tower 'real false) ; 3
+
+;;
+(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))
+ (if (all-same? type-tags)
+ (error "Matching types, but no operation available"
+ (list op type-tags))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args))) ; major changes below this line
+ (let ((rank1 (hash-ref type-tower type1 false))
+ (rank2 (hash-ref type-tower type2 false)))
+ (cond
+ ((not rank1) (error "No such type" type1))
+ ((not rank2) (error "No such type" type2))
+ (else
+ (define (raise-until targettype num)
+ (if (eq? (type-tag num) targettype)
+ num
+ (raise-until targettype (raise num))))
+ (if (< rank1 rank2)
+ (let ((raised-a1 (raise-until type2 a1)))
+ (apply-generic op raised-a1 a2))
+ (let ((raised-a2 (raise-until type1 a2)))
+ (apply-generic op a1 raised-a2)))))))
+ (error "I need two arguments, given" (length args))))))))
+
+
+;; Tests
+
+;; Just checking a subprocedure from apply-generic:
+(let ((raisable (make-integer 7)))
+ (define (raise-until targettype num)
+ (if (eq? (type-tag num) targettype)
+ num
+ (raise-until targettype (raise num))))
+ (raise-until 'real raisable))
+; '(real . 7.0)
+
+(add r1 (make-real 14.6)) ; '(real . 15.35)
+(mul c2 c1 r2) ; procedure mul: expects 2 arguments, given 3
+(apply-generic 'add r1 c1) ; '(complex rectangular 3.75 . 4)
+(apply-generic 'sub (make-integer 9) r1) ; '(rational 33 . 4)
+(apply-generic 'div (make-real 4.8) (make-integer -2)) ; '(real . -2.4)
+(apply-generic 'add r1 c1 c2 r2) ; I need two arguments, given 4
+(apply-generic 'mul (make-integer 3) (make-integer 7)) ; '(integer . 21)
Oops, something went wrong.

0 comments on commit 5762299

Please sign in to comment.