coercion

2.5/2.81.scm

@@ -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)

2.5/2.82.scm

@@ -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))))

2.5/2.83.scm

@@ -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)

2.5/2.84.scm

@@ -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)