Hatena::ブログ(Diary)

釣り日誌

2009-01-27 (Tue)

Drschemeでrandom

言語の選択は、Essentials of Programming Language(3rd ed.)

(require srfi/27)
(random-real)
(random-integer 200)

SICP3章読んでて、randomが出てくるところで悩んだ。randomなんてないから。

1.2.6節でもrandom出てきてるから、あのときどうやって解いたっけと思ってたら、言語でHow to Desing Programsの何れか選ぶと、基本手続きとしてrandomが使えるようだ。なるほどねぇ

2008-11-16 (Sun)

問題2.74から

問題2.74

この問題はかなり悩んだ。

765proと961proという架空の事業所の、2つのデータベースを考える。レコードはリスト形式で、以下のようなデータを持つ。

;(name salay blood)
(define 765pro-db (list '(haruka 100 O)
                        '(yayoi 120 O)
                        '(makoto 140 O)))
;(age name blood salay)
(define 961pro-db (list '(15 ganaha A 200)
                        '(14 hoshii B 220)
                        '(17 shijou B 240)))
;データにタグをつけて、従業員ファイルにする。
(define 765pro-file (attach-tag '765pro 765pro-db))
(define 961pro-file (attach-tag '961pro 961pro-db))

765pro-file, 961pro-fileのデータ形式を扱えるような、パッケージを用意する。

;765proパッケージ
(define (install-765pro-package)
  (define (get-record file name)
    (define (iter list)
      ;(display (car list)) (newline)
      (cond ((null? list) #f)
            ( (eq? name (caar list)) (car list))
            (else (iter (cdr list)))))
    (iter file))
  (define (get-salary rec) (cadr rec))    
  (define (tag x) (attach-tag '765pro x))
  
  (put 'get-record '765pro
       (lambda (file name) (tag (get-record file name))))
  (put 'get-salary '(765pro) get-salary)
  'done)
(install-765pro-package)

;961プロパッケージ
(define (install-961pro-package)
  (define (get-record file name)
    (define (iter list)
      ;(display (cadr (car list))) (newline)
      (cond ((null? list) #f)
            ((eq? name (cadr (car list))) (car list))
            (else (iter (cdr list)))))
    (iter file))
  (define (get-salary rec) (cadddr rec))    
  (define (tag x) (attach-tag '961pro x))
  
  (put 'get-record '961pro
       (lambda (file name) (tag (get-record file name))))
  (put 'get-salary '(961pro) get-salary)
  'done)
(install-961pro-package)

ここまで用意できたら、問a。従業員ファイルから、名前を指定してそのレコードを返す手続きget-recordを実装する。

;a
(define (get-record file name)
  ( (get 'get-record (type-tag file)) (contents file) name))
;使ってみる
(get-record 765pro-file 'makoto)
-> (765pro makoto 140 O)

事業所ファイルには、事業所の型情報を付加する必要がある。

問b 従業員レコードから給与を返す、get-salaryを実装する。

(define (get-salary rec) (apply-generic 'get-salary rec))
;使ってみる
(get-salary (get-record 765pro-file 'makoto))
-> 140

従業員レコードには、事業所の型情報を付加する必要がある。

問c すべての事業所ファイルから、名前を指定して、従業員レコードを返す手続きfind-employee-recordを実装する。

(define (find-employee-record file-list name)
  (if (null? file-list) #f
      (let ((rec (get-record (car file-list) name)))
        (if (contents rec)
            rec
            (find-employee-record (cdr file-list) name)))))
;使ってみる
(define all-file (list 765pro-file 961pro-file)) ;全事業所ファイル
(find-employee-record all-file 'hoshii)
-> (961pro 14 hoshii B 220)

問d 新しい従業員情報をシステムに組み込むには、どういう変更が必要か?

新しい事業所の型タグを決めて、データファイルに付加する。

そのデータを扱うための、get-record,get-salaryを持つパッケージを用意してインストールする。

問題を解いてはみたけど、Webに載ってる解答を見たりして、やっと解いた感じ。

contentsの使い方なんかが、自分の欲しいデータを取るために恣意的に使ってるようで、この答えでOKかどうかは疑問。

問題2.75

make-from-mag-angをメッセージパッシングの流儀で実装する。

(define (make-from-mag-ang r a)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* r (cos a)))
          ((eq? op 'imag-part) (* r (sin a)))
          ((eq? op 'magnitude) r)
          ((eq? op 'angle) a)
          (else
           (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)

;make-from-mag-angを使ってみると
(define PI (atan 0 -1))
(define z (make-from-mag-ang 1 PI))
(z 'real-part) -> -1.0
(z 'imag-part) -> 1.2246467991473532e-16
(z 'magnitude) -> 1
(z 'angle) -> 3.141592653589793

問題2.76

新しい型や新しい演算が追加されるシステムには、3つの戦略(明白な振分けを持つ汎用演算,データ主導流,メッセージパッシング流)のうちどれが適切か?

  • 明白な振分けを持つ汎用演算
    • 新しい型を追加
      • 既存の演算の型判定部分に、新しい型用の処理を追加する。
    • 新しい演算を追加
      • 新しい演算用の手続きを追加する。その手続き内では、既存の型判定を行っている。
  • データ主導流
    • 新しい型を追加
    • 新しい演算を追加
      • 既存のインストールパッケージの全てに、新しい演算用の手続きを追加し、それを演算表に追加する処理を書く。

既存のシステムへの変更が少ないという点で、

が適切な気がするなぁ。

問題2.77

はじめに(magnitude z)がエラーになるのは、complex型のmagnitudeがパッケージに登録されてないため。

問題の通り、(put 'magnitude '(complex) magnitude)と登録すれば、apply-generic内の

(get 'magnitude '(complex)

で演算(magnitude)が取り出される。

演算(magnitude)が取り出されれば、apply-genericの

(apply proc (map contents args))

で、proc = magnitude, args = zと考えて、complex型がひっぺがされたz( =(rectanglar x . y) )がmagnitudeに渡される。

magnitude手続きでは、再度apply-genericが実行されて、今度はrectangular型のmagnitudeがgetで取り出される。

で、このmagnitudeは、install-rectangular-packegeで定義されたものなので、欲しかった結果を返す。

(magnitude z)で呼び出される手続きをトレースすると

(define z (make-complex-from-real-imag 3 4))
(trace magnitude)
(trace apply-generic)
(trace type-tag)
(trace get)

(magnitude z)
結果
|(magnitude (complex rectangular 3 . 4))
|(apply-generic magnitude (complex rectangular 3 . 4))
| (type-tag (complex rectangular 3 . 4))
| complex
| (get magnitude (complex))
| #<procedure:magnitude>
|(apply-generic magnitude (rectangular 3 . 4))
| (type-tag (rectangular 3 . 4))
| rectangular
| (get magnitude (rectangular))
| #<procedure:magnitude>
|5
5

apply-genericは2回呼び出される。

1回目はinstall-complex-packageで登録したmagnitude、2回目はinstall-rectangular-packageで登録したmagnitudeに振り分けられる。

問題2.78

データ型が数なら型タグをつけないなどする。

(define (attach-tag type-tag contents)
  (if (eq? type-tag 'scheme-number)
      contents
      (cons type-tag contents)))
(define (type-tag datum)
  (cond ( (number? datum) 'scheme-number)
        ( (pair? datum) (car datum))
        (else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
  (cond ( (number? datum) datum)
        ( (pair? datum) (cdr datum))
        (else (error "Bad tagged datum -- CONTENTS" datum))))

2008-09-06 (Sat)

問題2.59から

問題2.59

union-setの定義

(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((null? set2) set1)
        ((element-of-set? (car set1) set2)
         (union-set (cdr set1) set2))
        (else (cons (car set1) (union-set (cdr set1) set2)))))

;element-of-set?
(define (element-of-set? x set)
  (cond ((null? set) #f)
        ( (equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))

問題2.60

集合が重複を許す場合の、element-of-set?,adjoin-set,union-set,intersection-setの手続きは?

element-of-set?とintersection-setの変更はなし。スッテプ数はそれぞれ、θ(n), θ(n^2)。

;adjoin-set
(define adjoin-set cons)
;ステップ数はθ(1)で重複なしより良くなる。重複なしのステップ数はθ(n)

;union-set
(define union-set append)
;ステップ数はθ(n)になるのかな。重複なしはθ(n^2)

重複を許した集合は計算量の効率はよくなる。この集合を使いたくなる応用は


問題2.61

順序づけられた集合のadjoin-setの実装

(define (adjoin-set x set)
  (cond ( (null? set) (list x))
        ( (= x (car set)) set)
        ( (< x (car set)) (cons x set))
        (else (cons (car set) (adjoin-set x (cdr set))))))

順序づけられた集合を使うと、xがsetの最初の要素より小さい場合に、残りのsetの値を見ること無く要素を追加することができる。


問題2.62

順序づけられた集合のunion-setを実装する。これはθ(n)のオーダーになる。

(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ( (null? set2) set1)
        (else
         (let ( (x1 (car set1)) (x2 (car set2)))
          (cond ((= x1 x2)
                 (cons x1 (union-set (cdr set1)
                                     (cdr set2))))
                ((< x1 x2)
                 (cons x1 (union-set (cdr set1) set2)))
                ((> x1 x2)
                 (cons x2 (union-set set1 (cdr set2)))))))))

2008-08-25 (Mon)

問題2.40から

問題2.40

nが与えられたら、1≦j<i≦nとなるような(i,j)の並びを作るunique-pairsの定義

(define (unique-pairs n)
  (flatmap 
   (lambda (i) 
     (map (lambda (j) (list i j)) 
          (enumerate-interval 1 (- i 1))))
  (enumerate-interval 1 n)))

上のunique-pairsを使って、prime-sum-pairsを書き直せ。

もとのprime-sum-pairsはこんな定義

(define (prime-sum-pairs n)
  (map make-pair-sum
        (filter prime-sum?
                (flatmap
                 (lambda (i)
                   (map (lambda (j) (list i j))
                        (enumerate-interval 1 (- i 1))))
                 (enumerate-interval 1 n)))))

これをunique-pairsを使って書き直すと、

(define (prime-sum-pairs2 n)
  (map make-pair-sum
       (filter prime-sum? (unique-pairs n))))

問題2.41

整数nに対して、nより小さいか等しい相異なる正の数i,j,kの組で、和が与えられた整数sに等しいものを返す手続きを書く。

;まず、unique-pairsのように3組の数の組あわせを返す手続きを作る。
(define (unique-3 n)
  (flatmap (lambda (i)
             (flatmap (lambda (j)
                        (map (lambda (k) (list i j k))
                  (enumerate-interval 1 (- j 1))))
          (enumerate-interval 1 (- i 1))))
   (enumerate-interval 1 n)))

;3組の数の和を返す手続き
(define (sum-3 pair)
  (+ (car pair) (cadr pair) (car (cddr pair))))

;整数sと3組の数の和が等しいかfilterを使って
(define (sum-equals-s n s)
  (filter (lambda (list) (= (sum-3 list) s))
          (unique-3 n)))

;使ってみる
(sum-equals-s 6 10)
-> ( (5 3 2) (5 4 1) (6 3 1))

反省会用にあじの南蛮漬け作ってみました。魚の下処理が想像以上に面倒で、泣きそうになりました。いままで実家で料理を作ってくれていた母に感謝しました。

2008-08-17 (Sun)

問題2.35から

問題2.35

(define (count-leaves t)
  (accumulate + 0 
              (map 
               (lambda (x) 
                 (if (pair? x) 
                     (count-leaves x) 
                     1))
               t)))
(count-leaves (list (list 1 2) (list 3 4)))

難しいっす。自力で解いてないです・・

問題2.36

(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      '()
      (cons (accumulate op init (map car seqs))
            (accumulate-n op init (map cdr seqs)))))
(define s (list (list 1 2 3) (list 4 5 6) (list 7 8 9) (list 10 11 12)))
(accumulate-n + 0 s)

難しいっす。accumulate, accumulate-nの引数を(car seqs), (cdr seqs)てしてしまう。答え見ればなるほどなぁと思うんだけど・・

問題2.37

問題2.38

fold-right(accumulate)とfold-leftの動作の違い。

(define (fold-left op init seq)
  (define (iter result rest)
    (if (null? rest)
        result
        (iter (op result (car rest))
                  (cdr rest))))
  (iter init seq))
(define fold-right accumulate)

(fold-right / 1 (list 1 2 3))
-> 1 1/2
(fold-left / 1 (list 1 2 3))
-> 1/6
(fold-right list '() (list 1 2 3))
-> (1 (2 (3 ())))
(fold-left list '() (list 1 2 3))
-> (((() 1) 2) 3)

予想してた結果と違う。accumulateの理解度低いね・・

fold-rightとfold-leftの結果が同じ値になるためにopが満たすべき性質は、

引数の順序を変えても、結果が同じなること(+や*など)。

問題2.39

2.38のfold-rightとfold-leftを使って、reverseを書く。

;fold-right版
(define (reverse seq)
  (fold-right (lambda (x y) (if (pair? x)
                (append y x)
                (append y (list x))
                )) '() seq))

;fold-left版
(define (reverse seq)
  (fold-left (lambda (x y)
               (cons y x)
               )
             '() seq))

ガチャガチャと式をいじってたら偶然できました。