2010/10/14

ちょっと考えてみたけど、やっぱボツだった accum

これを読んで、以前再帰とか S 式に慣れるために何度も書いたことを思い出しました。
SICP や The Little Schemer にも登場しますね。

とりあえず、Scheme で改めて書いてみました。
(define (collatz n)
(let rec ((n n)(acc `(,n)))
(if (<= n 1)
acc
(let1 r (if (even? n)
(/ n 2)
(+ 1 (* 3 n)))
(rec r (cons r acc))))))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)
view raw collatz.scm hosted with ❤ by GitHub

Common Lisp だと、こうでしょうか。
(defun collatz (n)
(labels ((rec (n acc)
(if (<= n 1)
acc
(let ((r (if (evenp n)
(/ n 2)
(+ 1 (* 3 n)))))
(rec r (cons r acc))))))
(rec n (list n))))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325
;; 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734
;; 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276
;; 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186
;; 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121
;; 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)
view raw collatz.lisp hosted with ❤ by GitHub

或いはこう？（仕様を満たせていませんね・・・）
(defun collatz (n)
(loop
with x = n
while (/= x 1)
if (evenp x)
do (setf x (/ x 2))
else
do (setf x (+ 1 (* 3 x)))
end
collect x))
view raw collatz-loop.lisp hosted with ❤ by GitHub


書いているうちに、こういうのがあったら良いんじゃないかなぁ、と思いました。
(hoge pred calc acc dec i) ==
(if (pred i)
    acc
    (hoge pred calc (calc i acc) dec (dec i)))

パッと見 unfold に似てるので、unfold で無理やり書いてみました。
(use srfi-1)
(define (collatz n)
(unfold (lambda (ls)
(<= (car ls) 1))
car
(lambda (ls)
(let1 a (car ls)
(cons (if (even? a)
(/ a 2)
(+ 1 (* 3 a))) ls)))
(list n)
(lambda _
(list 1))))
(collatz 27)
;; (27 82 41 124 62 31 94 47 142 71 214 107 322 161 484 242 121 364 182 91 274 137 412 206 103 310 155 466 233 700 350 175 526 263 790 395 1186 593 1780 890 445 1336 668 334 167 502 251 754 377 1132 566 283 850 425 1276 638 319 958 479 1438 719 2158 1079 3238 1619 4858 2429 7288 3644 1822 911 2734 1367 4102 2051 6154 3077 9232 4616 2308 1154 577 1732 866 433 1300 650 325 976 488 244 122 61 184 92 46 23 70 35 106 53 160 80 40 20 10 5 16 8 4 2 1)
view raw collatz-unfold.scm hosted with ❤ by GitHub

やはり unfold では強引な気がしたので試しに accum というのを定義してみました。
;; (hoge pred calc acc dec i) ==
;; (if (pred i)
;; acc
;; (hoge pred calc (calc i acc) dec (dec i)))
(define (accum pred proc seed . keywords)
(let-keywords* keywords ((terminal-fun identity)
(cons cons)
(acc-init '()))
(let rec ((seed seed)(acc acc-init))
(if (pred seed)
(terminal-fun acc)
(let1 r (proc seed)
(rec r (cons r acc)))))))
(define (collatz n)
(accum (pa$ = 1)
(lambda (n)
(if (even? n)
(/ n 2)
(+ 1 (* 3 n))))
n
:acc-init (list n)))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)
view raw collatz-accum.scm hosted with ❤ by GitHub

試しに fizzbuzz を書いてみたり。
(define (fizzbuzz n)
(accum (pa$ >= 1)
(cut - <> 1)
n
:cons (lambda (n acc)
(let1 mul? (compose zero? (pa$ remainder n))
(cons (cond ((mul? 15) "fizzbuzz")
((mul? 5) "buzz")
((mul? 3) "fizz")
(else n))
acc)))))
(print (fizzbuzz 100))
;; (1 2 fizz 4 buzz fizz 7 8 fizz buzz 11 fizz 13 14 fizzbuzz 16 17 fizz 19 buzz fizz 22 23 fizz buzz 26 fizz 28 29 fizzbuzz 31 32 fizz 34 buzz fizz 37 38 fizz buzz 41 fizz 43 44 fizzbuzz 46 47 fizz 49 buzz fizz 52 53 fizz buzz 56 fizz 58 59 fizzbuzz 61 62 fizz 64 buzz fizz 67 68 fizz buzz 71 fizz 73 74 fizzbuzz 76 77 fizz 79 buzz fizz 82 83 fizz buzz 86 fizz 88 89 fizzbuzz 91 92 fizz 94 buzz fizz 97 98 fizz)
(use srfi-1)
(fold-right (lambda (e acc)
(let ((p (compose zero? (cut modulo e <>))))
(cons (cond ((p 15) "fizzbuzz")
((p 5) "buzz")
((p 3) "fizz")
(else e)) acc)))
'() (iota 100 1))
view raw fizzbuzz.scm hosted with ❤ by GitHub

いまいち。ちょっと変更。
(define (accum pred proc seed . keywords)
(let-keywords* keywords ((terminal-fun identity)
(cons cons)
(acc-init '()))
(let rec ((seed seed)(acc acc-init))
(if (pred seed)
(terminal-fun acc)
(rec (proc seed)(cons seed acc))))))
(define (collatz n)
(accum (pa$ = 1)
(lambda (n)
(if (even? n)
(/ n 2)
(+ 1 (* 3 n))))
n
:terminal-fun (pa$ cons 1)))
(collatz 27)
;; (1 2 4 8 16 5 10 20 40 80 160 53 106 35 70 23 46 92 184 61 122 244 488 976 325 650 1300 433 866 1732 577 1154 2308 4616 9232 3077 6154 2051 4102 1367 2734 911 1822 3644 7288 2429 4858 1619 3238 1079 2158 719 1438 479 958 319 638 1276 425 850 283 566 1132 377 754 251 502 167 334 668 1336 445 890 1780 593 1186 395 790 263 526 175 350 700 233 466 155 310 103 206 412 137 274 91 182 364 121 242 484 161 322 107 214 71 142 47 94 31 62 124 41 82 27)
(define (fizzbuzz n)
(accum zero?
(cut - <> 1)
n
:cons (lambda (n acc)
(let1 mul? (compose zero? (pa$ remainder n))
(cons (cond ((mul? 15) "fizzbuzz")
((mul? 5) "buzz")
((mul? 3) "fizz")
(else n))
acc)))))
(print (fizzbuzz 100))
;; (1 2 fizz 4 buzz fizz 7 8 fizz buzz 11 fizz 13 14 fizzbuzz 16 17 fizz 19 buzz fizz 22 23 fizz buzz 26 fizz 28 29 fizzbuzz 31 32 fizz 34 buzz fizz 37 38 fizz buzz 41 fizz 43 44 fizzbuzz 46 47 fizz 49 buzz fizz 52 53 fizz buzz 56 fizz 58 59 fizzbuzz 61 62 fizz 64 buzz fizz 67 68 fizz buzz 71 fizz 73 74 fizzbuzz 76 77 fizz 79 buzz fizz 82 83 fizz buzz 86 fizz 88 89 fizzbuzz 91 92 fizz 94 buzz fizz 97 98 fizz buzz)
view raw collatz-accum2.scm hosted with ❤ by GitHub

それでもいまいち。きっともっとちゃんと抽象化されたものがどこかにあるはず。。

追記

調べたら、ちょっと前に unfold で書いてた。今日書いたものより、こっちの方が良い・・・。
(use srfi-1)
(define (collatz n)
(unfold (lambda (s)
(= s 1))
(lambda (s)
s)
(lambda (s)
(cond ((even? s)(/ s 2))
((odd? s)(+ (* s 3) 1))
(else s)))
n
(lambda (s)
(cons s '()))))
(collatz 10)
; -> (10 5 16 8 4 2 1)
view raw collatz-unfold.scm hosted with ❤ by GitHub


Scheme手習い
written by time:
labels : ,

0 件のコメント:

コメントを投稿

登録: コメントの投稿 (Atom)