#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))
--- /dev/null
+#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
--- /dev/null
+#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
--- /dev/null
+#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
-#lang racket
+#lang racket/load
(require "utils.rkt")
--- /dev/null
+#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
#lang racket
-(require "utils.rkt")
+(require "utils.rkt"
+ rackunit)
(define (accumulate-n op init seqs)
(if (null? (car seqs))
(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
--- /dev/null
+(define (foobar x)
+ (cond
+ ((= x 1) 1)
+ ((= x 2) 1)
+ (else (+ (foobar (- x 1))
+ (foobar (- x 2))))))
\ No newline at end of file
(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)))
((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
--- /dev/null
+#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
--- /dev/null
+#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
--- /dev/null
+#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))))
--- /dev/null
+#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)))))))
+
--- /dev/null
+#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
--- /dev/null
+#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
--- /dev/null
+#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))
--- /dev/null
+#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")))))))))))
--- /dev/null
+#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)))
+
+
--- /dev/null
+#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
projects / sicp.git / commitdiff