From: Ramakrishnan Muthukrishnan 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/%5B/%5D%20/uri/%22file:/frontends/about.html?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