From: Ramakrishnan Muthukrishnan <vu3rdd@gmail.com>
Date: Wed, 22 Dec 2010 04:54:00 +0000 (+0530)
Subject: bunch of exercise solutions from sections 2.3, 2.4 and 2.5
X-Git-Url: https://git.rkrishnan.org/pf/content/%22news.html/frontends/status?a=commitdiff_plain;h=ccf01641182e264e51decf6c62650b1b6ad809c8;p=sicp.git

bunch of exercise solutions from sections 2.3, 2.4 and 2.5
---

diff --git a/src/sicp/ch2_3.rkt b/src/sicp/ch2_3.rkt
index fe94cf8..81e4dad 100644
--- a/src/sicp/ch2_3.rkt
+++ b/src/sicp/ch2_3.rkt
@@ -1,5 +1,10 @@
 #lang racket
 
+(define (memq item x)
+  (cond ((null? x) #f)
+        ((eq? item (car x)) x)
+        (else (memq item (cdr x)))))
+
 ;; leaf nodes
 (define (make-leaf leaf weight)
   (list 'leaf leaf weight))
diff --git a/src/sicp/ch2_3_3.rkt b/src/sicp/ch2_3_3.rkt
new file mode 100644
index 0000000..1975c48
--- /dev/null
+++ b/src/sicp/ch2_3_3.rkt
@@ -0,0 +1,78 @@
+#lang racket/load
+
+(define (element-of-set? x set)
+  (cond ((null? set) #f)
+        ((equal? x (car set)) #t)
+        (else (element-of-set? x (cdr set)))))
+
+(define (adjoin-set x set)
+  (cond ((element-of-set? x set) set)
+        (else (cons x set))))
+
+(define (intersection-set set1 set2)
+  (cond ((or (null? set1) (null set2)) '())
+        ((element-of-set? (car set1) set2) (cons (car set1) (intersection-set (cdr set1) set2)))
+        (else (intersection-set (cdr set1) set2))))
+
+;;; huffman tree
+(define (make-leaf symbol weight)
+  (list 'leaf symbol weight))
+(define (leaf? node)
+  (eq? (car node) 'leaf))
+(define (symbol-leaf node)
+  (car (cdr node)))
+(define (weight-leaf node)
+  (car (cdr (cdr node))))
+
+(define (make-code-tree left right)
+  (list left
+        right
+        (append (symbols left) (symbols right))
+        (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (car (cdr tree)))
+(define (symbols tree)
+  (if (leaf? tree)
+      (list (symbol-leaf tree))
+      (car (cdr (cdr tree)))))
+(define (weight tree)
+  (if (leaf? tree)
+      (weight-leaf tree)
+      (car (cdr (cdr (cdr tree))))))
+
+;; decoding
+(define (decode bits tree)
+  (define (decode-1 bits current-branch)
+    (if (null? bits)
+        '()
+        (let ((next-branch (choose-branch (car bits) tree)))
+          (if (leaf? next-branch)
+              (cons (symbol-leaf next-branch)
+                    (decode-1 (cdr bits) tree))
+              (decode-1 (cdr bits) next-branch)))))
+  (decode-1 bits tree))
+
+(define (choose-branch bit tree)
+  (cond ((= bit 0) (left-branch tree))
+        ((= bit 1) (right-branch tree))
+        (else (error "bad bit -- choose-branch" bit))))
+
+;; sets of weighted elements
+
+;; arrange items in the increasing order of weight
+(define (adjoin-set x set)
+  (cond ((null? set) (list x))
+        ((< (weight x) (weight (car set))) (cons x set))
+        (else (cons (car set)
+                    (adjoin-set x (cdr set))))))
+
+(define (make-leaf-set pairs)
+  (if (null? pairs)
+      '()
+      (let ((pair (car pairs)))
+        (adjoin-set (make-leaf (car pair)
+                               (cadr pair))
+                    (make-leaf-set (cdr pairs))))))
+
+;; (provide element-of-set? adjoin-set intersection-set)
\ No newline at end of file
diff --git a/src/sicp/ch2_3_3_ordered.rkt b/src/sicp/ch2_3_3_ordered.rkt
new file mode 100644
index 0000000..4b13e34
--- /dev/null
+++ b/src/sicp/ch2_3_3_ordered.rkt
@@ -0,0 +1,18 @@
+#lang racket
+;; sets as ordered lists.
+
+(define (element-of-set? x set)
+  (cond ((null? set) #f)
+        ((= (car set) x) #t)
+        ((> (car set) x) #f)
+        (else (element-of-set? x (cdr set)))))
+
+(define (intersection-set set1 set2)
+  (cond ((or (null? set1) 
+             (null? set2)) '())
+        ((= (car set1) 
+            (car set2)) 
+         (cons (car set1) (intersection-set (cdr set1) 
+                                            (cdr set2))))
+        ((< (car set1) (car set2)) (intersection-set (cdr set1) set2))
+        ((> (car set1) (car set2)) (intersection-set set1 (cdr set2)))))
\ No newline at end of file
diff --git a/src/sicp/ch2_3_3_sets_as_trees.rkt b/src/sicp/ch2_3_3_sets_as_trees.rkt
new file mode 100644
index 0000000..4eadaf0
--- /dev/null
+++ b/src/sicp/ch2_3_3_sets_as_trees.rkt
@@ -0,0 +1,30 @@
+#lang racket
+
+(require racket/trace)
+
+(define (entry tree) (car tree))
+(define (left-branch tree) (car (cdr tree)))
+(define (right-branch tree) (car (cdr (cdr tree))))
+
+(define (make-tree entry left right) (list entry left right))
+
+(define (element-of-set? x set)
+  (cond ((null? set) #f)
+        ((= x (entry set)) #t)
+        ((< x (entry set)) (element-of-set? x (left-branch set)))
+        ((> x (entry set)) (element-of-set? x (right-branch set)))
+        (else #f)))
+
+(define (adjoin-set x set)
+  (cond ((null? set) (make-tree x '() '()))
+        ((= x (entry set)) set)
+        ((< x (entry set)) (make-tree (entry set) 
+                                      (adjoin-set x (left-branch set))
+                                      (right-branch set)))
+        ((> x (entry set)) (make-tree (entry set)
+                                      (left-branch set)
+                                      (adjoin-set x (right-branch set))))))
+
+(trace make-tree)
+
+(provide entry left-branch right-branch make-tree)
\ No newline at end of file
diff --git a/src/sicp/ch2_4.rkt b/src/sicp/ch2_4.rkt
index 4f14ab5..7aedacd 100644
--- a/src/sicp/ch2_4.rkt
+++ b/src/sicp/ch2_4.rkt
@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/load
 
 (require "utils.rkt")
 
diff --git a/src/sicp/ch2_5.rkt b/src/sicp/ch2_5.rkt
new file mode 100644
index 0000000..7cc2e55
--- /dev/null
+++ b/src/sicp/ch2_5.rkt
@@ -0,0 +1,14 @@
+#lang racket
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply0generic 'div x y))
+
+;; install package for ordinary numbers
+(define (install-scheme-number-package)
+  (define (tag x)
+    (attach-tag 'scheme-number x))
+  (put 'add '(scheme-number scheme-number)
+       (lambda (x y) (tag (+ x y))))
+  
\ No newline at end of file
diff --git a/src/sicp/ex2_36.rkt b/src/sicp/ex2_36.rkt
index 658b860..94a276c 100644
--- a/src/sicp/ex2_36.rkt
+++ b/src/sicp/ex2_36.rkt
@@ -1,6 +1,7 @@
 #lang racket
 
-(require "utils.rkt")
+(require "utils.rkt"
+         rackunit)
 
 (define (accumulate-n op init seqs)
   (if (null? (car seqs))
@@ -8,6 +9,10 @@
       (cons (accumulate op init (map car seqs))
             (accumulate-n op init (map cdr seqs)))))
 
+(check equal? 
+       (accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))
+       '(22 26 30))
+       
+
 (provide accumulate-n)
 
-;; (accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))
\ No newline at end of file
diff --git a/src/sicp/ex2_36.scm b/src/sicp/ex2_36.scm
new file mode 100644
index 0000000..0002d77
--- /dev/null
+++ b/src/sicp/ex2_36.scm
@@ -0,0 +1,6 @@
+(define (foobar x)
+  (cond
+   ((= x 1) 1)
+   ((= x 2) 1)
+   (else (+ (foobar (- x 1))
+            (foobar (- x 2))))))
\ No newline at end of file
diff --git a/src/sicp/ex2_37.rkt b/src/sicp/ex2_37.rkt
index 841e6c2..a0c71f9 100644
--- a/src/sicp/ex2_37.rkt
+++ b/src/sicp/ex2_37.rkt
@@ -10,13 +10,14 @@
 (define (matrix-*-vector m v)
   (map (lambda (r) (dot-product r v)) m))
 
-;; (matrix-*-vector '((1 2 3 4) (4 5 6 6) (6 7 8 9)) '(1 2 3 4))
+(matrix-*-vector '((1 2 3 4) (4 5 6 6) (6 7 8 9)) '(1 2 3 4))
 
 (define (transpose m)
   (accumulate-n cons '() m))
 
 ;; (transpose '((1 2 3) (4 5 6) (7 8 9)))
 
+
 (define (matrix-*-matrix m n)
   (let ([cols (transpose n)])
     (map (lambda (v) (matrix-*-vector cols v)) m))) 
diff --git a/src/sicp/ex2_62.rkt b/src/sicp/ex2_62.rkt
index 47fb870..e10c3c4 100644
--- a/src/sicp/ex2_62.rkt
+++ b/src/sicp/ex2_62.rkt
@@ -5,4 +5,6 @@
         ((null? set2) set1)
         ((= (car set1) (car set2)) (cons (car set1) (union-set (cdr set1) (cdr set2))))
         ((< (car set1) (car set2)) (cons (car set1) (union-set (cdr set1) set2)))
-        ((> (car set1) (car set2)) (cons (car set2) (union-set set1 (cdr set2))))))
\ No newline at end of file
+        ((> (car set1) (car set2)) (cons (car set2) (union-set set1 (cdr set2))))))
+
+(provide union-set)
\ No newline at end of file
diff --git a/src/sicp/ex2_63.rkt b/src/sicp/ex2_63.rkt
new file mode 100644
index 0000000..128db2b
--- /dev/null
+++ b/src/sicp/ex2_63.rkt
@@ -0,0 +1,48 @@
+#lang racket
+
+(require "ch2_3_3_sets_as_trees.rkt")
+
+(define (tree->list-1 tree)
+  (if (null? tree)
+      '()
+      (append (tree->list-1 (left-branch tree))
+              (cons (entry tree)
+                    (tree->list-1 (right-branch tree))))))
+
+(define (tree->list-2 tree)
+  (define (copy-to-list tree result-list)
+    (if (null? tree)
+        result-list
+        (copy-to-list (left-branch tree)
+                      (cons (entry tree)
+                            (copy-to-list (right-branch tree)
+                                          result-list)))))
+  (copy-to-list tree '()))
+
+;; part a. Yes, both of them give the same results.
+
+(define l1 '(7 (3 (1 () ()) (5 () ())) (9 () (11 () ()))))
+(define l2 '(3 (1 () ()) (7 (5 () ()) (9 () (11 () ())))))
+(define l3 '(5 (3 (1 () ()) ()) (9 (7 () ()) (11 () ()))))
+
+(tree->list-1 l1)
+(tree->list-1 l2)
+(tree->list-1 l3)
+
+(tree->list-2 l1)
+(tree->list-2 l2)
+(tree->list-2 l3)
+
+(provide tree->list-1 tree->list-2)
+
+;; part b. 
+#|
+for tree->list-1, it does a cons and an append at each step. append needs to be done
+for each element of the first list. In this case the first list initially will have 
+n/2 elements, then n/4 and so on. So, it has about O(logn) steps. Now, it also does
+a cons on each element, so overall it takes O(n Log n) steps.
+
+for tree->list-2, it does a cons on each element, so steps is O(n).
+
+Order of growth for both the procedures is O(n).
+|#
\ No newline at end of file
diff --git a/src/sicp/ex2_64.rkt b/src/sicp/ex2_64.rkt
new file mode 100644
index 0000000..0edf4b8
--- /dev/null
+++ b/src/sicp/ex2_64.rkt
@@ -0,0 +1,75 @@
+#lang racket
+
+(require "ch2_3_3_sets_as_trees.rkt")
+(require racket/trace)
+
+(define (list->tree elements)
+  (car (partial-tree elements (length elements))))
+
+(define (partial-tree elts n)
+  (if (= n 0)
+      (cons '() elts)
+      (let ((left-size (quotient (- n 1) 2)))
+        (let ((left-results (partial-tree elts left-size)))
+          (let ((left-tree (car left-results))
+                (non-left-elements (cdr left-results))
+                (right-size (- n (+ left-size 1))))
+            (let ((this (car non-left-elements))
+                  (right-results (partial-tree (cdr non-left-elements) right-size)))
+              (let ((right-tree (car right-results))
+                    (remaining-elts (cdr right-results)))
+                (cons (make-tree this left-tree right-tree)
+                      remaining-elts))))))))
+
+;;(trace list->tree)
+;;(trace partial-tree)
+
+(provide list->tree)
+
+;; a
+#|
+Let us take an example:
+
+  (list->tree '(1 3 5 7 9 11))
+
+We do 
+(partial-tree '(1 3 5 7 9 11) 6) 
+  => (partial-tree '(1 3 5 7 9 11) 2)
+    => (partial-tree '(1 3 5 7 9 11) 0)
+
+At this point, we have found a leaf node. So, we push the null list,
+take the first element on the list as the parent and look for the 
+right tree. The call returns to the previous call to partial-tree
+(i.e. (partial-tree '(1 3 5 7 9 11) 2)) which means n is 2.
+
+The right-size = (- n (+ left-size 1)) => (- 2 (+ 0 1)) => 1
+So we invoke partial-tree for the right tree.
+
+(partial-tree '(3 5 7 9 11) 1)
+  => (partial-tree '(3 5 7 9 11) 0)
+
+This will push an empty list (as the left node) and look for right node.
+(partial-tree '(5 7 9 11) 0)
+ 
+this gives us the subtree (1 () (3 () ()))
+
+At every stage of making a subtree, we cons it with the remaining elements.
+The tree looks like this:
+
+               5
+              / \
+             /   \
+            1     9
+           / \    /\
+          /   \  7  11
+        ()     3
+              / \
+             /   \
+            ()   ()
+
+part b. For each node, we do a cons of the tree under the node with the remaining
+elements. So the order of growth is O(n).
+
+|#
+                
+          
\ No newline at end of file
diff --git a/src/sicp/ex2_65.rkt b/src/sicp/ex2_65.rkt
new file mode 100644
index 0000000..c09b02b
--- /dev/null
+++ b/src/sicp/ex2_65.rkt
@@ -0,0 +1,11 @@
+#lang racket
+
+(require "ch2_3_3_sets_as_trees.rkt")
+(require "ex2_63.rkt")
+(require "ex2_64.rkt")
+(require "ex2_62.rkt")
+
+(define (union-set-tree s1 s2)
+  (let ((ls1 (tree->list-1 s1))
+        (ls2 (tree->list-2 s2)))
+    (list->tree (union-set ls1 ls2))))
diff --git a/src/sicp/ex2_66.rkt b/src/sicp/ex2_66.rkt
new file mode 100644
index 0000000..1c27f21
--- /dev/null
+++ b/src/sicp/ex2_66.rkt
@@ -0,0 +1,11 @@
+#lang racket
+
+(define (lookup given-key set-of-records)
+  (if (null? set-of-records)
+      #f
+      (let* ((e (entry set-of-records))
+             (k (key e)))
+        (cond ((equal? given-key k) e)
+              ((< k given-key) (lookup given-key (left-branch set-of-records)))
+              ((> k given-key) (lookup given-key (right-branch set-of-records)))))))
+        
diff --git a/src/sicp/ex2_81.rkt b/src/sicp/ex2_81.rkt
new file mode 100644
index 0000000..8d227cf
--- /dev/null
+++ b/src/sicp/ex2_81.rkt
@@ -0,0 +1,83 @@
+#lang racket
+
+(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)))))))
+
+(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)
+
+(define (exp x y) (apply-generic 'exp x y))
+
+;; following added to Scheme-number package
+(put 'exp '(scheme-number scheme-number)
+     (lambda (x y) (tag (expt x y)))) ; using primitive expt
+
+#|
+
+2.81 a. The initial (get 'exp '(complex complex)) yield a false as the procedure
+to handle '(complex complex) was not installed into the table. So, it gets the coercion
+table:
+
+ (get-coersion 'complex 'complex) => complex->complex 
+
+ (apply-generic 'exp (complex->complex a1) a2) => (apply-generic 'exp a1 a2)
+
+So, we keep calling ourselves until stack overflows.
+ 
+|#
+
+#|
+
+b.
+
+As long as we install a procedure to handle same typed data in the main table and not
+do a same type to same type coercion, it is fine. So, Louis is wrong.
+
+|#
+
+;; c
+(define (apply-generic op . args)
+  (let ((type-tags (map type-tag args)))
+    (let ((proc (get op type-tags)))
+      (cond 
+        (proc (apply proc (map contents args)))
+        ((and (car type-tags) (cadr type-tags))
+         (error "No procedure to handle the type" (car type-tags)))
+        ((= (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)))))))
+        (else (error "No method for these types"
+                     (list op type-tags)))))))
\ No newline at end of file
diff --git a/src/sicp/ex2_82.rkt b/src/sicp/ex2_82.rkt
new file mode 100644
index 0000000..3357eb1
--- /dev/null
+++ b/src/sicp/ex2_82.rkt
@@ -0,0 +1,46 @@
+#lang racket
+
+;; get a list of coercions (t1->t t2->2 .... tn->t)
+;; if a type coercion does not exist, the 
+;; particular index will have #f
+(define (get-coercions type types)
+  (map (lambda (t) 
+         (if (eq? t type)
+             (lambda (x) x)
+             (get-coercion t type)))
+       types))
+
+(define (all-valid? coercions)
+  (cond 
+    ((null? coercions) #t)
+    ((car coercions) (all-valid? (cdr coercions)))
+    (else #f)))
+      
+(define (get-all-type-coercions types)
+  (map (lambda (t) 
+         (get-coercions t types))
+       types))
+                                  
+(define (apply-generic op . args)
+  (define (apply-generic-2 type-coercion-list)
+    (cond 
+      ((null? type-coercion-list) (error "cannot find a suitable type coercion"))
+      ((all-valid? (car type-coercion-list))
+       (let ((coerced-args (map (lambda (t a) (t a)) (car type-coercion-list) args)))
+         (apply-generic-1 coerced-args)))
+      (else (apply-generic-2 (cdr type-coercion-list)))))
+       
+  (define (apply-generic-1 args)
+    (let ((type-tags (map type-tag args)))
+      (let ((proc (get op type-tags)))
+        (if proc
+            (apply proc (map contents args))
+            (let ((tn->t1 (get-all-type-coercions types)))
+              (apply-generic-2 tn->t1))))))
+  
+  (apply-generic-1 args))
+
+#|
+The method will fail if say, t2, t3 and t4 can only be coreced into t1 but the call to apply-generic does not have an argument of type t1.
+Instead, if we have a way to figure out the relation between types and the hierarchy, then we can deal with it better.
+|#
\ No newline at end of file
diff --git a/src/sicp/ex2_83.rkt b/src/sicp/ex2_83.rkt
new file mode 100644
index 0000000..5f18aea
--- /dev/null
+++ b/src/sicp/ex2_83.rkt
@@ -0,0 +1,35 @@
+#lang racket
+
+(define (attach-tag tag contents)
+  (cons tag contents))
+
+(define (integer->rational x)
+  (if (integer? x)
+      (attach-tag 'rational (cons (contents x) 1))
+      (error "input is not an integer")))
+
+;; install in integer
+(put 'raise '(rational)
+     (lambda (x) (integer->rational x)))
+         
+(define (integer->real x) 
+  (* x 1.0))
+
+(define (rational->real r)
+  (let ((n (numer r))
+        (d (denom r)))
+    (make-real (/ (integer->real n) d))))
+
+;; install into rational package
+(put 'raise '(real)
+     (lambda (r) (rational->real r)))
+
+(define (real->complex r)
+  (make-complex-from-real-imag r 0))
+
+;; install into real package
+(put 'raise '(complex)
+     (lambda (r) (real->complex r)))
+
+(define (raise x)
+  (apply-generic 'raise x))
diff --git a/src/sicp/ex2_84.rkt b/src/sicp/ex2_84.rkt
new file mode 100644
index 0000000..bd7a4f3
--- /dev/null
+++ b/src/sicp/ex2_84.rkt
@@ -0,0 +1,41 @@
+#lang racket
+
+(define (type-height type)
+  (cond 
+    ((eq? type 'integer) 0)
+    ((eq? type 'rational) 1)
+    ((eq? type 'real) 2)
+    ((eq? type 'complex) 3)))
+
+(define (compose f g)
+  (lambda (x) (f (g x))))
+
+(define (identity x) (lambda (x) x))
+
+(define (raise-to type1 type2)
+  (if (eq? type1 type2)
+      identity
+      (let ((t1->upper (get 'raise (list type1))))
+        (compose t1->upper (raise-to t1->upper type2)))))
+
+(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 ((th1 (type-height type1))
+                      (th2 (type-height type2)))
+                  (if (> th1 th2)
+                      (let ((t2->t1 (raise-to type2 type1)))
+                        (if (t2->t1)
+                            (apply-generic op a1 (t2->t1 a2))
+                            (error "cannot coerce type2 to type1")))
+                      (let ((t1->t2 (raise-to type1 type2)))
+                        (if (t1->t2)
+                            (apply-generic op (t1->t2 a1) a2)
+                            (error "cannot coerce type1 to type2")))))))))))
diff --git a/src/sicp/ex2_85.rkt b/src/sicp/ex2_85.rkt
new file mode 100644
index 0000000..dd7aba7
--- /dev/null
+++ b/src/sicp/ex2_85.rkt
@@ -0,0 +1,25 @@
+#lang racket
+
+(put 'project '(complex)
+     (lambda (c) (real c)))
+
+(put 'project '(rational)
+     (lambda (r) (floor r)))
+
+(put 'project '(real)
+     (lambda (d)
+       (let ((rat (rationalize (inexact->exact d) 1/100)))
+         (make-rat (numerator rat)
+                   (denominator rat)))))
+     
+;; drop
+(define (drop x)
+  (let ((project-fn (get 'project (list (type-tag x)))))
+    (if (project-fn)
+        (let ((dropped-x (project-fn x)))
+          (if (equ? (raise dropped-x) x)
+              (drop dropped-x)
+              x))
+        x)))
+
+
diff --git a/src/sicp/ex2_86.rkt b/src/sicp/ex2_86.rkt
new file mode 100644
index 0000000..412243d
--- /dev/null
+++ b/src/sicp/ex2_86.rkt
@@ -0,0 +1,13 @@
+#lang racket
+
+;; for scheme-numbers
+(put 'cos '(scheme-number)
+     (lambda (x) (cos x)))
+
+(put 'cos '(real)
+     (lambda (x) (cos x)))
+
+(put 'cos '(rational)
+     (lambda (r) (exact->inexact r)))
+
+;; similarly define sin, atan, square