2013-01-28 SICP読書会 #gauche #sicp

.gitignore

.*
!.git*

2013-01-28.scm

;; 2.3.4  Example: Huffman Encoding Trees

; Representing Huffman trees
(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)))

; The decoding procedure
(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 of weighted elements
(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)   ; symbol
			       (cadr pair)) ; frequency
		    (make-leaf-set (cdr pairs))))))

; Exercise 2.67.

; Exercise 2.68.
(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
	      (encode (cdr message) tree))))

(define (encode-symbol letter tree)
  (define (encode-1 bits branch)
    (let ((left (left-branch branch))
	  (right (right-branch branch)))
      (cond ((leaf? branch)
	     (if (memq letter (symbols branch))
		 bits
		 (raise (string-join
			 (list "bad letter" (symbol->string letter))))))
	    ((memq letter (symbols left))
	     (encode-1 (cons 0 bits) left))
	    (else
	     (encode-1 (cons 1 bits) right)))))
    (reverse (encode-1 '() tree)))

; Exercise 2.69
(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

(define (successive-merge leafs)
    (if (= (length leafs) 1)
	(car leafs)
	(let ((leaf-1 (car leafs))
	      (leaf-2 (cadr leafs))
	      (rest (cddr leafs)))
	  (let ((next-leafs
		 (adjoin-set (make-code-tree leaf-1 leaf-2)
			     rest)))
		(successive-merge next-leafs)))))

; Exercise 2.70
(define frequencies '((A 2) (NA 16)
		      (BOOM 1) (SHA 3)
		      (GET 2) (YIP 9)
		      (JOB 2) (WAH 1)))
(define message "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")

  

2013-01-28_test.scm

(load "./2013-01-28.scm")

(let ((target (make-leaf 'A 1)))
  (assert (leaf? target) (is #t))
  (assert (symbol-leaf target) (is 'A))
  (assert (weight-leaf target) (is 1))
)

(let ((tree (make-code-tree (make-leaf 'A 1)
			    (make-leaf 'B 2))))
  (assert (symbols tree) (is '(A B)))
  (assert (weight tree) (is 3))
)

; 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))
(assert (decode sample-message sample-tree)
	(is '(A D A B B C A)))

; Exercise 2.68
(assert (encode '(A D A B B C A) sample-tree)
	(is sample-message))
(assert (encode (decode sample-message sample-tree) sample-tree)
	(is sample-message))

(assert (memq 2 '(1 2 3))
	(is '(2 3)))
(assert (if '(2 3) 'a 'b)
	(is 'a))

; Exercise 2.69
(let ((pairs '((A 4) (B 2) (C 1) (D 1))))
  #;(assert (separate-min-leaf (make-leaf-set pairs))
	  (is (list '(leaf C 1) '((leaf A 4) (leaf B 2) (leaf D 1)))))
  #;(assert (separate-min-leaf '((leaf A 4) (leaf B 2) (leaf D 1)))
	  (is (list '(leaf D 1) '((leaf B 2) (leaf A 4)))))
  #;(assert (separate-min-leaf (list '(leaf A 4) '(leaf B 2) (make-code-tree '(leaf D 1) '(leaf C 1))))
	  (is '(((leaf D 1) (leaf C 1) (D C) 2) ((leaf B 2) (leaf A 4)))))
  #;(assert (separate-min-leaf (list '(leaf A 4) '(leaf B 2)))
	  (is '((leaf B 2) ((leaf A 4)))))
  #;(let ((min-1 '((leaf C 1) ((leaf A 4) (leaf B 2) (leaf D 1)))))
    (let ((min-2 (separate-min-leaf (cadr min-1))))
      (let ((leafs (cons (make-code-tree (car min-1) (car min-2)) (cadr min-2))))
	(let ((min-1 (separate-min-leaf leafs)))
	  (let ((min-2 (separate-min-leaf (cadr min-1))))
	    (let ((leafs (cons (make-code-tree (car min-1) (car min-2)) (cadr min-2))))
	      (assert (null? (cdr leafs)) (is #f)) ;continue
	      (let ((min-1 (separate-min-leaf leafs)))
		(let ((min-2 (separate-min-leaf (cadr min-1))))
		  (let ((leafs (cons (make-code-tree (car min-1) (car min-2)) (cadr min-2))))
		    (assert (null? (cdr leafs)) (is #t))
		    (let ((expected-tree (car leafs))) ; 最後に取り出す
		      (assert (encode '(A D A B B C A) expected-tree)
			      (is '(0 1 1 1 0 1 0 1 0 1 1 0 0)))
		      (assert (decode '(0 1 1 1 0 1 0 1 0 1 1 0 0) expected-tree)
			      (is '(A D A B B C A)))
		      )
		    )
		  )
		)
	      )
	    )
	  )
	)
      )
    )

  (let ((tree (generate-huffman-tree pairs)))
    #;(assert tree (is sample-tree))
    #;(assert (length (encode '(A D A B B C A) tree)) 
	    (is (length sample-message)))
    (assert (length (encode '(A D A B B C A) tree)) (is 13))
    (assert (decode (encode '(A D A B B C A) tree) tree)
	    (is '(A D A B B C A))))
  )

; Exercise 2.70
(let ((normalized-message
       (map string->symbol
	    (map list->string
		 (map (lambda (c) (map char-upcase c))
		      (map string->list (string-split message " "))))))
      (tree (generate-huffman-tree frequencies)))
  (assert normalized-message
	  (is '(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)))
  (assert (length normalized-message) (is 36))
  (let ((code (encode normalized-message tree)))
    (assert (length code) (is 84))
    (assert (decode code tree) (is normalized-message))
    )
  )

; Exercise 2.72
(assert (lazy (encode '(HOGE) sample-tree))
	(raises "bad letter HOGE"))


(display 'ok)

README.md

test:

$ make test

from http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-16.html#%_sec_2.3.4

Makefile

GU_PATH=./.vender/gu
GU_REPO=https://gist.github.com/4251773.git

setup:
	test -d $(GU_PATH) || env git clone $(GU_REPO) $(GU_PATH)

clean:
	rm -rf ./.vender

test: setup
	env gosh -l $(GU_PATH)/gu.scm 2013-01-28_test.scm

新たな手続きを書くとき、
使用箇所の手前に書き足す癖があるな。

; で、1つのS式をコメントアウトできると知って、いろいろはかどる

2.69のtestは、思考過程としてこんな感じってのを残した。