2012-07-29

ｺﾞｺﾞｺﾞｺﾞｺﾞｯ

lambda

K(S(SI(K(S(K(S(S(KS)K)(S(S(KS)K)I)))(S(S(KS)K)I(S(S(KS)K)(SII(S(S(KS)K)I)))))))(K(S(SI(K(S(K(S(S(KS)K)(SII(S(S(KS)K)I))))(S(S(KS)K)(S(SII)I(S(S(KS)K)I))))))(K(S(SI(K(S(S(KS)K)(S(K(SII(S(S(KS)K)I)))(S(S(KS)K)(S(S(KS)K)(S(SII)I(S(S(KS)K)I))))))))(K(S(K(S(SI(K(S(SI(K(S(K(S(S(KS)K)(S(S(KS)K)I)))(S(S(KS)K)(S(S(KS)K)I(S(S(KS)K)(SII(S(S(KS)K)I))))))))(K(K(SII(SII(S(S(KS)K)I))))))))))K)))))))

kuin.

2012-07-28

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とかの定義に誤植あった気がするけど気のせいかにゃ？

にゃにゃにゃにゃにゃあ

2012-07-21

ぅ〜〜〜ッッ！

sicp

今週はお休みです。
代わりになんか書きます。
SICPも2.3章に入るわけなのですが、ここからシンボリックデータを扱えるようになります。
これを利用して、代数的な操作を実装してみようと思う。
これから上げる例は、１変数多項式の展開形を求めるもの。
たとえば、多項式として、 $(x^2 + 1)(x +2) = 2 + x + 2x^2 + x^3$ が成り立つわけですが、多項式の表現から一般に展開形： $a_0 + a_1x + a_2x^2 + \cdots + a_nx^n$ を求めるprocedure"show-poly"を書く。
まず、建前上、多項式の表現を定義します。

(define (variable? x) (symbol? x))
(define (constant? x) (number? x))
(define (polynomial? exp var)
  (cond ((eq? exp var) #t)
	((number? exp) #t)
	((or (eq? (car exp) '+) (eq? (car exp) '*)) (and (polynomial? (car (cdr exp)) var) (polynomial? (car (cdr (cdr exp))) var)))
	(else #f)))

つまりここで多項式は、一つの変数とその他の定数の二項の和と積を再帰的に繰り返して得られたものしか認めないものとしてます。
この時の、１変数多項式の展開は以下の通り：

(define (show-poly exp0 var0)
  (define (sum-seq x y)
    (cond ((null? x) y)
	  ((null? y) x)
	  (else (cons (+ (car x) (car y)) (sum-seq (cdr x) (cdr y))))))

  ;; Convolution, that is, a product rule for polynomials
  (define (conv-seq x y)
    (define (reverse s)
      (define (init-last s) (if (null? (cdr s)) (cons () (car s)) (cons (cons (car s) (car (init-last (cdr s)))) (cdr (init-last (cdr s))))))
      (if (null? s) () (cons (cdr (init-last s)) (reverse (car (init-last s))))))
    (define (convolution a b)
      (define (sum-prod s t)
	(if (and (null? s) (null? t)) 0
	    (+ (* (car s) (car t)) (sum-prod (cdr s) (cdr t)))))
	(sum-prod a (reverse b)))
    (define (conv-seq-itr s t memx memy result)
      (if (and (null? s) (null? t)) result
	  (conv-seq-itr (cdr s) (cdr t) (cons (car s) memx) (cons (car t) memy) (cons (convolution memx memy) result))))
    (cdr (reverse (cons 0 (conv-seq-itr x y () () ())))))

  ;; Calculate normal-form
  (define (normal-form0 exp var deg)
    (define (zero-seq n) (if (= n 0) (list 0) (cons 0 (zero-seq (- n 1)))))
    (define zero-d (zero-seq (+ deg 2)))
    (cond ((null? exp) zero-d)
	  ((number? exp) (sum-seq (list exp) zero-d))
	  ((eq? exp var) (sum-seq (list 0 1) zero-d))
	  ((eq? (car exp) '+) (sum-seq (normal-form0 (car (cdr exp)) var deg) (normal-form0 (car (cdr (cdr exp))) var deg)))
	  ((eq? (car exp) '*) (conv-seq (normal-form0 (car (cdr exp)) var deg) (normal-form0 (car (cdr (cdr exp))) var deg)))))
  (define (degree exp)
    (cond ((null? exp) 0)
	  ((constant? exp) 1)
	  ((variable? exp) 1)
	  ((eq? (car exp) '+) (max (degree (car (cdr exp))) (degree (car (cdr (cdr exp))))))
	  ((eq? (car exp) '*) (+ 1 (max (degree (car (cdr exp))) (degree (car (cdr (cdr exp)))))))))

  (define (normal-form exp var)
    (let ((b (reverse (normal-form0 exp var (degree exp)))))
      (define (whilezero x)
	(if (= (car x) 0) (whilezero (cdr x)) x))
      (reverse (whilezero b))))

  (define (show-normal-form s var)
    (define (all-append s)
      (if (null? s) () (append (car s) (all-append (cdr s)))))
    (define (zipfrom s n) (if (null? s) () (cons (list n (car s)) (zipfrom (cdr s) (+ n 1)))))
    (let ((t (map (lambda (p)
		    (cond  ((= (car (cdr p)) 0) ())
			   ((and (= (car (cdr p)) 1) (= (car p) 1)) (list var '+))
			   ((and (= (car (cdr p)) 1) (= (car p) (- (length s) 1))) (list var '^ (car p)))
			   ((= (car (cdr p)) 1) (list var '^ (car p) '+))
			   ((= (car p) 0) (list (car (cdr p)) '+))
			   ((= (car p) 1) (list (car (cdr p)) var '+))
			   ((= (car p) (- (length s) 1)) (list (car (cdr p)) var '^ (car p)))
			   (else (list (car (cdr p)) var '^ (car p) '+)))) (zipfrom s 0))))
      (for-each (lambda (x) (display x)) (all-append t))))

  (show-normal-form (normal-form exp0 var0) var0)
)

色々と冗長ですが、前回2.2章の分を少しサボっていた、その演習代わりみたいなものなのでお許しを
(reverse とか zip とかいかにもlist構造弄ってる感じしますなあ)。
show-polyは多項式のシンボリックデータとその変数名を受け取り、展開形にして返します：

gosh> (show-poly '(* t (+ (* t t) 1)) 't)
> t+t^3#<undef>
gosh> (show-poly '(+ (* x (* (+ x 1) (+ x 2))) 8) 'x)
> 8+2x+3x^2+x^3#<undef>

コード見るとそんなに綺麗な形ではないので改善の余地ありで、例外処理もしてないし、バグももしかしたら変なものが紛れ込んでいる可能性大です。
とりあえずこんなかんじで。

にゃんにゃんしてません

2012-07-12

らむにゃー

sicp

Schemeでλ計算とか。

;; Church-encoding of nat
(define zero (lambda (f) (lambda (x) x)))
(define (add-1 n)
  (lambda (f) (lambda (x) (f ((n f) x)))))
;; (add-1 zero) ->* (lambda (f) (lambda (x) (f x)))
;; (add-1 (add-1 zero)) ->* (lambda (f) (lambda (x) (f (f x))))
;; Define addtion of Church numerals
(define (add-ch n m) (lambda (f) (lambda (x) ((m f) ((n f) x)))))
;; Define multiplication of Church numerals
(define (mul-ch n m) (lambda (f) (lambda (x) ((m (n f)) x))))
;; Define exponentiation of Church numerals
(define (exp n m) (lambda (f) (lambda (x) (((m n) f) x))))

;; Truth Definition in Church encoding
(define t-ch (lambda (p) (lambda (q) p)))
(define nil-ch (lambda (p) (lambda (q) q)))
(define if-ch (lambda (p) (lambda (x) (lambda (y) ((p x) y)))))
;; Define isZero? in Church encoding
(define (isZero? n)
  (define false-constant (lambda (f) nil-ch))
  ((n false-constant) t-ch))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Define encoding, decoding of numerals
(define (encode-num n)
  (if (= n 0) zero
      (add-1 (encode-num (- n 1)))))
(define (decode-num n)
  (define (plus-one x) (+ x 1))
  ((n plus-one) 0))

;; Define encoding, decoding truth values
(define (encode-tval p) (if p t-ch nil-ch))
(define (decode-tval p) ((p #t) #f))

;;;;;;;;;;;;; あまりにしょぼいので加筆 ;;;;;;;;;;;;;;;;;;;;;;;;;

;; Define pairing functions and car, cdr
(define cons-ch (lambda (x) (lambda (y) (lambda (f) ((f x) y)))))
(define car-ch (lambda (p) (p t-ch)))
(define cdr-ch (lambda (p) (p nil-ch)))

;; Define Predecessor function
(define (pred-ch m)
  (define zz ((cons-ch zero) zero))
  (define ss (lambda (p) ((cons-ch (cdr-ch p)) (add-1 (cdr-ch p)))))
  (car-ch ((m ss) zz)))

Churchエンコーディングの話。
簡単なことしかやってませんがお許しを。結果は以下：

gosh> (decode-num (add-ch (encode-num 3)(encode-num 5)))
> 8

gosh> (decode-tval (isZero? (encode-num 0)))
> #t

gosh> (decode-tval (isZero? (encode-num 1)))
> #f

なんか本当にクソですね、すみません、死にます。
死にゃん

2012-07-07

いい天気ですねって書こうとしたら良い点ですねって打ち間違えたのでしそのまま投稿します

その他

なんか需要あるかと思って、[\square],[\diamondsuit]周りの話でも書こうと思ったけど面倒なのでやめました。
ああ、なんか Approachability とか Good point とか I[lambda] とかそのへんのお話。
I[lambda]の構造を弄る話に関しては Foreman も色々アナウンスしてるように未解決な話が多いし、一方で、 $\mathrm{Cof}(\omega_1)$ まわりの話だったらスパコン基数壊すだけで結構簡単に色々いじれるけど。
(でもこのへん(stationary reflectionの話も含め)の"exact consistency strength"ってあまり良くわかってなくて、非常に興味深いものがあるよね〜(*´･ω･)(･ω･｀*)ﾈｰ。(誰への同意だ(※関係者各位(※そもそも誰もみてない))))