meow〜ッ！

sicp

演習問題淡々と。面倒なので、実装しなさいみたいな問題の解答だけ：

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Exercise 2.65 implement the union-set, intersection-set for binary tree data

(define (union-set1 tree1 tree2)
  (if (null? tree2) tree1
      (adjoin-set1 (entry tree2)
		   (union-set1 (union-set1 tree1 (left-branch1 tree2))
			      (right-branch1 tree2)))))
(union-set1 (list->tree (list 1 3 5)) (list->tree (list 2 4 6)))
;;      3
;;   1     5
;;    2   4 6

;; O(nlogn) かかるので修正 ;;

;; including exercise 2.62
(define (union-set2 tree1 tree2)
  (define (union-set-list set1 set2)
    (cond ((null? set1) set2)
	  ((null? set2) set1)
	  ((= (car set1) (car set2)) (cons (car set1) (union-set-list (cdr set1) (cdr set2))))
	  ((< (car set1) (car set2)) (cons (car set1) (union-set-list (cdr set1) set2)))
	  ((> (car set1) (car set2)) (cons (car set2) (union-set-list set1 (cdr set2))))))
  (list->tree (union-set-list (tree->list-2 tree1) (tree->list-2 tree2))))

(define (intersection-set2 tree1 tree2)
  (define (intersection-set-list set1 set2)
    (if (or (null? set1) (null? set2))
	'()
	(let ((x1 (car set1)) (x2 (car set2)))
	  (cond ((= x1 x2)
		 (cons x1
		       (intersection-set-list (cdr set1)
					      (cdr set2))))
		((< x1 x2)
		 (intersection-set-list (cdr set1) set2))
		((< x2 x1)
		 (intersection-set-list set1 (cdr set2)))))))
  (list->tree (intersection-set-list (tree->list-2 tree1) (tree->list-2 tree2))))

(union-set2 bintree1 bintree2)
(intersection-set2 bintree1 bintree2)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Exercise 2.66 lookup procedure for ordered tree data in O(logn)

(define (lookup-tree given-key tree)
  (cond ((= given-key (key (entry tree))) (entry tree))
	((< given-key (key (entry tree))) (lookup-tree given-key (left-branch1 tree)))
	((> given-key (key (entry tree))) (lookup-tree given-key (right-branch1 tree)))))

;; Transformation: list-recodes -> tree-recodes
(define (recodes->tree recodes)
  (define (partial-tree elts n)
    (if (= n 0)
	(cons '() elts)
	(let ((left-size (quotient (- n 1) 2)))
	  (let ((left-result (partial-tree elts left-size)))
	    (let ((left-tree (car left-result))
		  (non-left-elts (cdr left-result))
		  (right-size (- n (+ left-size 1))))
	      (let ((this-entry (car non-left-elts))
		    (right-result (partial-tree (cdr non-left-elts)
						right-size)))
		(let ((right-tree (car right-result))
		      (remaining-elts (cdr right-result)))
		  (cons (make-tree1 this-entry left-tree right-tree)
			remaining-elts))))))))
  (car (partial-tree recodes (length recodes))))

(lookup-tree 1 (recodes->tree number-name-table))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Exercise 2.67 ;; A -> 0, B -> 10, C -> 111, D -> 110

(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))
(decode sample-message sample-tree) ;; ADABBCA

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Exercise 2.68, decribe the procedure encode-symbol

(define (encode message tree)
  (define (encode-symbol symbol tree)
    (cond ((and (leaf? (left-branch tree)) (eq? (symbol-leaf (left-branch tree)) symbol)) (list 0))
	  ((and (leaf? (right-branch tree)) (eq? (symbol-leaf (right-branch tree)) symbol)) (list 1))
	  ((and (not (leaf? (left-branch tree))) (elem? symbol (caddr (left-branch tree)))) (cons 0 (encode-symbol symbol (left-branch tree))))
	  ((and (not (leaf? (right-branch tree))) (elem? symbol (caddr (right-branch tree)))) (cons 1 (encode-symbol symbol (right-branch tree))))
	  (else (error "No Such Symbol:" symbol))))
  (if (null? message) '()
      (append (encode-symbol (car message) tree)
	      (encode (cdr message) tree))))

(encode '(A D A B B C A) sample-tree) ;; (0 1 1 0 0 1 0 1 0 1 1 1 0)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Exercise 2.69, generating huffman encoding tree from a given list of symbol-frequency pairs

(define (generate-huffman-tree pairs)
  (define (successive-merge leafset leftstack rightstack)
    (cond ((null? leafset) (make-code-tree leftstack rightstack))
	  ((null? rightstack) (successive-merge (cdr leafset) leftstack (car leafset)))
	  ((< (weight (car leafset)) (weight rightstack)) (successive-merge (cdr leafset) (make-code-tree (car leafset) leftstack) rightstack))
	  (else (successive-merge (cdr leafset) (car leafset) (make-code-tree leftstack rightstack)))))
  (successive-merge (make-leaf-set pairs) () ()))

(generate-huffman-tree (list (list 'A 4) (list 'B 2) (list 'D 1) (list 'C 1))) ;; == sample-tree

;;;;;;;;;;;;;;;;
;; Exercise 2.70
(define wordlist (list (list 'a 2) (list 'boom 1) (list 'Get 2) (list 'job 2) (list 'na 16) (list 'Sha 3) (list 'yip 9) (list 'Wah 1)))

;; What is the smallest number of bits to encode the following song,
;; Get a job
;; Sha na na na na na na na na
;; Get a job
;; Sha na na na na na na na na
;; Wah yip yip yip yip yip yip yip yip yip
;; Sha boom

(define song '(Get a job Sha na na na na na na na na Get a job Sha na na na na na na na na Wah yip yip yip yip yip yip yip yip yip Sha boom))
(encode song (generate-huffman-tree wordlist))

> (1 1 0 1 1 1 1 0 1 0 1 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 1 1 1 0 1 0 1 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 0 0 1 1 1 1 0)
;; Exercise 2.71 most: 0, least: 11..(n-times)..1
;; Exercise 2.72 encode a symbol: O(logn)~O(n). most:O(1), least:O(logn)~O(n) (n: number of symbols)
;; Note that the procedure (make-leaf-set (list of size n)) requires O(n^2)

そういえば Huffman-encoding tree の章のweightとかの定義に誤植あった気がするけど気のせいかにゃ？

にゃにゃにゃにゃにゃあ