;;;;;; ;;; ;;; Solution to Exercise 3 ;;; ;;; by Hongwei Xi ;;; ;;;;;; (define (fold-right f init xs) (if (null? xs) init (f (car xs) (fold-right f init (cdr xs))))) (define nil '()) (define ranull? null?) (define (raeven? xs) (eq? (car xs) 'even)) (define (raodd? xs) (eq? (car xs) 'odd)) (define (racons x xs) (cond ((ranull? xs) (list 'odd x xs)) ((raeven? xs) (list 'odd x (cadr xs))) ((raodd? xs) (list 'even (racons (cons x (cadr xs)) (caddr xs)))))) (define (rauncons xs) (cond ((ranull? xs) (error "rauncons: empty list" xs)) ((raeven? xs) (let ((xyxys (rauncons (cadr xs)))) (let ((xy (car xyxys)) (xys (cdr xyxys))) (cons (car xy) (racons (cdr xy) (list 'even xys)))))) ((raodd? xs) (cons (cadr xs) (list 'even (caddr xs)))))) ;;; make-ralist returns a random-access list that represents a usual list (define (make-ralist xs) (fold-right racons nil xs)) (define (ralookup n xs) (cond ((eq? n 0) (car (rauncons xs))) ((raeven? xs) (let ((qr (integer-divide n 2))) (if (eq? (cdr qr) 0) (car (ralookup (car qr) (cadr xs))) (cdr (ralookup (car qr) (cadr xs)))))) ((raodd? xs) (let ((qr (integer-divide (- n 1) 2))) (if (eq? (cdr qr) 0) (car (ralookup (car qr) (caddr xs))) (cdr (ralookup (car qr) (caddr xs)))))))) ;;; could you notice the use of continuation in the following program? (define (rafupdate n f xs) (cond ((eq? n 0) (let ((xxs (rauncons xs))) (racons (f (car xxs)) (cdr xxs)))) ((raeven? xs) (let ((qr (integer-divide n 2))) (if (eq? (cdr qr) 0) (list 'even (rafupdate (car qr) (lambda (xy) (cons (f (car xy)) (cdr xy))) (cadr xs))) (list 'even (rafupdate (car qr) (lambda (xy) (cons (car xy) (f (cdr xy)))) (cadr xs)))))) ((raodd? xs) (let ((qr (integer-divide (- n 1) 2))) (if (eq? (cdr qr) 0) (list 'odd (cadr xs) (rafupdate (car qr) (lambda (xy) (cons (f (car xy)) (cdr xy))) (caddr xs))) (list 'odd (cadr xs) (rafupdate (car qr) (lambda (xy) (cons (car xy) (f (cdr xy)))) (caddr xs)))))))) (define (raupdate n x xs) (rafupdate n (lambda (y) x) xs)) ; BU CAS CS320, Spring 2002 ; Solution of the problem 1 on the problem set 5 ; Provided by Nenad Dedic ; Most of this file is just the online code that supplements the textbook. ; The solution itself is at the bottom, right after the comment that ; begins with "HW5" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; STUFF FROM THE BOOK BEGINS: ;;;SECTION 2.3.3 ;; representing (define (make-leaf symbol weight) (list 'leaf symbol weight)) (define (leaf? object) (eq? (car object) 'leaf)) (define (symbol-leaf x) (cadr x)) (define (weight-leaf x) (caddr x)) (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) (cadr tree)) (define (symbols tree) (if (leaf? tree) (list (symbol-leaf tree)) (caddr tree))) (define (weight tree) (if (leaf? tree) (weight-leaf tree) (cadddr tree))) ;; decoding (define (decode bits tree) (define (decode-1 bits current-branch) (if (null? bits) '() (let ((next-branch (choose-branch (car bits) current-branch))) (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 branch) (cond ((= bit 0) (left-branch branch)) ((= bit 1) (right-branch branch)) (else (error "bad bit -- CHOOSE-BRANCH" bit)))) ;; sets (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)))))) ;; EXERCISE 2.67 ;: (define sample-tree ;: (make-code-tree (make-leaf 'A 4) ;: (make-code-tree ;: (make-leaf 'B 2) ;: (make-code-tree (make-leaf 'D 1) ;: (make-leaf 'C 1))))) ;: (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) ;; EXERCISE 2.68 (define (encode message tree) (if (null? message) '() (append (encode-symbol (car message) tree) (encode (cdr message) tree)))) ;; EXERCISE 2.69 (define (generate-huffman-tree pairs) (successive-merge (make-leaf-set pairs))) ; STUFF FROM THE BOOK ENDS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; HW5: this is what we are supposed to do (define (successive-merge set) (if (<= (length set) 1) (car set) (let ((e1 (car set)) (e2 (cadr set)) (rest (cddr set))) (successive-merge (adjoin-set (make-code-tree e1 e2) rest))))) ; just for testing: (define ght generate-huffman-tree) (define sm successive-merge) ; BU CAS CS320 Spring 2002 ; Solution of the second problem on the problem set 5 ; Provided by Nenad Dedic (define (list->brauntree l) ; element numbering starts from 0 (head of the list is at position 0) ; lsub returns the left sublist up to element n, exclusive (define (lsub n l) (if (= n 0) '() (cons (car l) (lsub (- n 1) (cdr l))))) ; rsub returns the right sublist, from element n, inclusive (define (rsub n l) (if (= n 0) l (rsub (- n 1) (cdr l)))) ; elt returns the n-th element of the list (define (elt n l) (if (= n 0) (car l) (elt (- n 1) (cdr l)))) ; aux - convert a sorted list into the corresponding Braun tree (define (aux l) (if (null? l) 'e (let ((mid (floor (/ (length l) 2)))) (list 'B (elt mid l) (aux (lsub mid l)) (aux (rsub (+ 1 mid) l)))))) ; so, just sort the list and call aux (aux (sort l <))) ; just for testing (define lb list->brauntree) ; BU CAS CS 320, Spring 2002 ; Solution of the problem 3 on the problem set 5 ; Provided by Nenad Dedic ; is the ra-list empty? (define (raempty? l) (eq? 'E l)) ; is it the list of form ('even ... ) ? (define (raeven? l) (eq? 'even (car l))) ; or ('odd ... ) ? (define (raodd? l) (eq? 'odd (car l))) ; the following two procedures assume that l is ('even ... ) ; get the first sublist (the one with elements with even indices) (define (esl1 l) (cadr l)) ; get the second sublist (the one with elements with odd indices) (define (esl2 l) (caddr l)) ; this one assumes that l is ('odd ... ) ; get the sublist (in this case that's exactly the "cdr" of the ra-list) (define (osl l) (caddr l)) ; assumes that l is odd ; get the first element (in this case, "car" of the ra-list) (define (elt l) (cadr l)) ; finally, implementations of important procedures: (define (racons e l) (cond ((raempty? l) (list 'odd e 'E)) ((raodd? l) (if (raempty? (osl l)) (list 'even (list 'odd e 'E) (list 'odd (elt l) 'E)) (list 'even (racons e (esl1 (osl l))) (racons (elt l) (esl2 (osl l)))))) ((raeven? l) (list 'odd e l)))) (define (rauncons l) (cond ((raodd? l) (cons (elt l) (osl l))) ((raeven? l) (if (and (raempty? (osl (esl1 l))) (raempty? (osl (esl2 l)))) (cons (elt (esl1 l)) (esl2 l)) (let ((r1 (rauncons (esl1 l))) (r2 (rauncons (esl2 l)))) (cons (car r1) (list 'odd (car r2) (list 'even (cdr r1) (cdr r2))))))))) ; why not have them, "racar" and "racdr" ? (define (racar l) (car (rauncons l))) (define (racdr l) (cdr (rauncons l))) (define (ralookup n l) (if (zero? n) (if (raodd? l) (elt l) (ralookup 0 (esl1 l))) (if (raeven? l) (if (even? n) (ralookup (/ n 2) (esl1 l)) (ralookup (/ (- n 1) 2) (esl2 l))) (ralookup (- n 1) (osl l))))) (define (raupdate n e l) (cond ((zero? n) (if (raodd? l) (list 'odd e (osl l)) (list 'even (raupdate n e (esl1 l)) (esl2 l)))) ((raeven? l) (let ((qr (integer-divide n 2))) (if (= 0 (cdr qr)) (list 'even (raupdate (car qr) e (esl1 l)) (esl2 l)) (list 'even (esl1 l) (raupdate (car qr) e (esl2 l)))))) ((raodd? l) (list 'odd (elt l) (raupdate (- n 1) e (osl l)))))) ; just two procedures for testing - ignore if you wish (define (ramake l) (fold-right racons 'e l)) (define (seq n) (if (zero? n) (list) (cons n (seq (- n 1))))) ;;; BU CAS CS 320, Spring 2002 ;;; Solution of the problem 4 on the problem set 5 ;;; Provided by Nenad Dedic ;;; This solution uses the online code that supplements the textbook. ;;; All modifications and additions are marked with comments that starts ;;; with "HW5", so search for these to see all the changes. ;;; The "tower of types" implemented in this solution is: ;;; complex ;;; real ;;; rational ;;; scheme-number ;;; "scheme-number" here has the role of the "integer" in the book ;;; I decided to keep "scheme-number" to facilitate easier ;;; comparisons to the code in the book. You can think of "scheme-number" ;;; as of "integer". ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; HW5 MODIFICATION STARTS: ;;; 'get' and 'put' as posted by prof. Xi to the class mailing list: (load-option 'hash-table) (define *opname-type-opcode-table* (make-equal-hash-table 23)) (define (put opname type opcode) (hash-table/put! *opname-type-opcode-table* (cons opname type) opcode)) (define (get opname type) (let ((opcode (hash-table/get *opname-type-opcode-table* (cons opname type) 'undefined))) (if (eq? opcode 'undefined) (error "undefined operation -- GET: " (cons opname type)) opcode))) ;;; 'get' and 'put' definitions end ;;; HW5 MODIFICATION ENDS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CODE FROM OTHER CHAPTERS OF STRUCTURE AND INTERPRETATION OF ;;; COMPUTER PROGRAMS NEEDED BY CHAPTER 2 ;;; ***not in book, but needed for code before quote is introduced*** (define nil '()) ;;;SECTION 2.4.3 (define (attach-tag type-tag contents) (cons type-tag contents)) (define (type-tag datum) (if (pair? datum) (car datum) (error "Bad tagged datum -- TYPE-TAG" datum))) (define (contents datum) (if (pair? datum) (cdr datum) (error "Bad tagged datum -- CONTENTS" datum))) ;;; HW5 ADDITION (define (istagged? x) (pair? x)) ;;; HW5 ADDITION ENDS ;; uses get/put (from 3.3.3) -- see ch2support.scm ;;; HW5 COMMENT: not really, uses get / put from the mailing list (define (install-rectangular-package) ;; internal procedures (define (real-part z) (car z)) (define (imag-part z) (cdr z)) (define (make-from-real-imag x y) (cons x y)) (define (magnitude z) (sqrt (+ (square (real-part z)) (square (imag-part z))))) (define (angle z) (atan (imag-part z) (real-part z))) (define (make-from-mag-ang r a) (cons (* r (cos a)) (* r (sin a)))) ;; interface to the rest of the system (define (tag x) (attach-tag 'rectangular x)) (put 'real-part '(rectangular) real-part) (put 'imag-part '(rectangular) imag-part) (put 'magnitude '(rectangular) magnitude) (put 'angle '(rectangular) angle) (put 'make-from-real-imag 'rectangular (lambda (x y) (tag (make-from-real-imag x y)))) (put 'make-from-mag-ang 'rectangular (lambda (r a) (tag (make-from-mag-ang r a)))) 'done) (define (install-polar-package) ;; internal procedures (define (magnitude z) (car z)) (define (angle z) (cdr z)) (define (make-from-mag-ang r a) (cons r a)) (define (real-part z) (* (magnitude z) (cos (angle z)))) (define (imag-part z) (* (magnitude z) (sin (angle z)))) (define (make-from-real-imag x y) (cons (sqrt (+ (square x) (square y))) (atan y x))) ;; interface to the rest of the system (define (tag x) (attach-tag 'polar x)) (put 'real-part '(polar) real-part) (put 'imag-part '(polar) imag-part) (put 'magnitude '(polar) magnitude) (put 'angle '(polar) angle) (put 'make-from-real-imag 'polar (lambda (x y) (tag (make-from-real-imag x y)))) (put 'make-from-mag-ang 'polar (lambda (r a) (tag (make-from-mag-ang r a)))) 'done) ;;footnote ;: (apply + (list 1 2 3 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; HW5 addition (new "apply-generic" that automatically drops ;;; its result) (define (apply-generic op . args) (let ((type-tags (map type-tag args))) (let ((proc (get op type-tags))) (if proc (let ((result (apply proc (map contents args)))) ;;; here, we define the local "drop" procedure (define (auxdrop x) (define a-nd apply-nodrop) (if (a-nd 'bottom? x) x (if (a-nd 'equ? (a-nd 'raise (a-nd 'project x)) x) (auxdrop (a-nd 'project x)) x))) ;;; but we try to drop only if the result is a tagged datum ;;; (for example, we should not drop the results of ;;; "real-part" and the like, since they are just plain ;;; numbers) (if (istagged? result) (auxdrop result) result)) (error "No method for these types -- APPLY-GENERIC" (list op type-tags)))))) ;;; we also need the application procedure that does NOT drop ;;; its result (exactly the same as the old "apply-generic") ;;; because we want to use it to invoke "raise" and "project" when ;;; dropping (define (apply-nodrop op . args) (let ((type-tags (map type-tag args))) (let ((proc (get op type-tags))) (if proc (apply proc (map contents args)) (error "No method for these types -- APPLY-NODROP" (list op type-tags)))))) ;;; HW5 ADDITION ENDS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Generic selectors (define (real-part z) (apply-generic 'real-part z)) (define (imag-part z) (apply-generic 'imag-part z)) (define (magnitude z) (apply-generic 'magnitude z)) (define (angle z) (apply-generic 'angle z)) ;; Constructors for complex numbers (define (make-from-real-imag x y) ((get 'make-from-real-imag 'rectangular) x y)) (define (make-from-mag-ang r a) ((get 'make-from-mag-ang 'polar) r a)) (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) (apply-generic 'div x y)) (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)))) (put 'sub '(scheme-number scheme-number) (lambda (x y) (tag (- x y)))) (put 'mul '(scheme-number scheme-number) (lambda (x y) (tag (* x y)))) (put 'div '(scheme-number scheme-number) (lambda (x y) (tag (/ x y)))) (put 'make 'scheme-number (lambda (x) (tag x))) ;;; HW5 MODIFICATION STARTS (put 'equ? '(scheme-number scheme-number) (lambda (x y) (= x y))) (put 'raise '(scheme-number) (lambda (x) (make-rational x 1))) (put 'bottom? '(scheme-number) (lambda (x) #t)) ;;; HW5 MODIFICATION ENDS 'done) (define (make-scheme-number n) ((get 'make 'scheme-number) n)) (define (install-rational-package) ;; internal procedures (define (numer x) (car x)) (define (denom x) (cdr x)) (define (make-rat n d) (let ((g (gcd n d))) (cons (/ n g) (/ d g)))) (define (add-rat x y) (make-rat (+ (* (numer x) (denom y)) (* (numer y) (denom x))) (* (denom x) (denom y)))) (define (sub-rat x y) (make-rat (- (* (numer x) (denom y)) (* (numer y) (denom x))) (* (denom x) (denom y)))) (define (mul-rat x y) (make-rat (* (numer x) (numer y)) (* (denom x) (denom y)))) (define (div-rat x y) (make-rat (* (numer x) (denom y)) (* (denom x) (numer y)))) ;;; HW5 MODIFICATION STARTS (define (raise-rat x) (make-real (/ (numer x) (denom x)))) (define (equ?-rat x y) (= (* (numer x) (denom y)) (* (numer y) (denom x)))) (define (project-rat x) (make-scheme-number (round (/ (numer x) (denom x))))) ;;; HW5 MODIFICATION ENDS ;; interface to rest of the system (define (tag x) (attach-tag 'rational x)) (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y)))) (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y)))) (put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y)))) (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y)))) (put 'make 'rational (lambda (n d) (tag (make-rat n d)))) ;;; HW5 MODIFICATION STARTS (put 'equ? '(rational rational) (lambda (x y) (equ?-rat x y))) (put 'raise '(rational) (lambda (x) (raise-rat x))) (put 'project '(rational) (lambda (x) (project-rat x))) (put 'bottom? '(rational) (lambda (x) #f)) ;;; HW5 MODIFICATION ENDS 'done) (define (make-rational n d) ((get 'make 'rational) n d)) (define (install-complex-package) ;; imported procedures from rectangular and polar packages (define (make-from-real-imag x y) ((get 'make-from-real-imag 'rectangular) x y)) (define (make-from-mag-ang r a) ((get 'make-from-mag-ang 'polar) r a)) ;; internal procedures (define (add-complex z1 z2) (make-from-real-imag (+ (real-part z1) (real-part z2)) (+ (imag-part z1) (imag-part z2)))) (define (sub-complex z1 z2) (make-from-real-imag (- (real-part z1) (real-part z2)) (- (imag-part z1) (imag-part z2)))) (define (mul-complex z1 z2) (make-from-mag-ang (* (magnitude z1) (magnitude z2)) (+ (angle z1) (angle z2)))) (define (div-complex z1 z2) (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) (- (angle z1) (angle z2)))) ;; interface to rest of the system (define (tag z) (attach-tag 'complex z)) (put 'add '(complex complex) (lambda (z1 z2) (tag (add-complex z1 z2)))) (put 'sub '(complex complex) (lambda (z1 z2) (tag (sub-complex z1 z2)))) (put 'mul '(complex complex) (lambda (z1 z2) (tag (mul-complex z1 z2)))) (put 'div '(complex complex) (lambda (z1 z2) (tag (div-complex z1 z2)))) (put 'make-from-real-imag 'complex (lambda (x y) (tag (make-from-real-imag x y)))) (put 'make-from-mag-ang 'complex (lambda (r a) (tag (make-from-mag-ang r a)))) ;;; HW5 MODIFICATION STARTS (put 'equ? '(complex complex) (lambda (x y) (and (= (real-part x) (real-part y)) (= (imag-part x) (imag-part y))))) (put 'project '(complex) (lambda (x) (make-real (real-part x)))) (put 'bottom? '(complex) (lambda (x) #f)) ;;; HW5 MODIFICATION ENDS 'done) (define (make-complex-from-real-imag x y) ((get 'make-from-real-imag 'complex) x y)) (define (make-complex-from-mag-ang r a) ((get 'make-from-mag-ang 'complex) r a)) ;;; HW5 ADDITION: a package for manipulating real numbers (define (install-real-package) (define (tag x) (attach-tag 'real x)) (put 'add '(real real) (lambda (x y) (tag (+ x y)))) (put 'sub '(real real) (lambda (x y) (tag (- x y)))) (put 'mul '(real real) (lambda (x y) (* x y))) (put 'div '(real real) (lambda (x y) (/ x y))) (put 'make 'real (lambda (x) (tag x))) (put 'equ? '(real real) (lambda (x y) (= x y))) (put 'raise '(real) (lambda (x) (make-complex-from-real-imag x 0))) (put 'project '(real) (lambda (x) (make-rational (numerator (inexact->exact x)) (denominator (inexact->exact x))))) (put 'bottom? '(real) (lambda (x) #f)) 'done) (define (make-real x) ((get 'make 'real) x)) ;;; HW5 ADDITION ENDS (implementation of the "real" package) ;;; HW5 ADDITION (providing easier access to the implemented functionality): (define (equ? x y) (apply-nodrop x y)) (define (raise x) (apply-nodrop 'raise x)) (define (project x) (apply-nodrop 'project x)) (define (bottom? x) (apply-nodrop 'bottom? x)) ;;; and the "drop" procedure ;;; note that "drop" need not be implemented for each type separately (define (drop x) (if (bottom? x) x (if (equ? x (raise (project x))) (drop (project x)) x))) ;;; HW5 ADDITION ENDS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; HW5: uncomment these if you want to run the program ;;; and experiment with it in the interpreter ; (install-scheme-number-package) ; (install-complex-package) ; (install-rational-package) ; (install-polar-package) ; (install-rectangular-package) ; (install-real-package) ; (define sa (make-scheme-number 10)) ; (define sb (make-scheme-number 15)) ; (define sc (make-scheme-number 10)) ; (define ra (make-rational 5 9)) ; (define rb (make-rational 5 9)) ; (define rc (make-rational 10 18)) ; (define rd (make-rational 105 88)) ; (define ea (make-real 4.234)) ; (define eb (make-real 4.234)) ; (define ec (make-real 5.3)) ; (define ca (make-complex-from-real-imag 1 0))