2007/03/23

R.バード『関数プログラミング』の亀の子図形問題、Scheme版

『関数プログラミング』(R. バード,P.ワドラー著/武市 正人訳)に亀の子図形の例題がある。その一筆書きバージョンを Gauche で書くとこんな感じ。
;; state -> state
(define (move state)
(match state
(`((,x ,y) 0) (make-state (- x 1) y 0)) ;; N
(`((,x ,y) 1) (make-state x (- y 1) 1)) ;; W
(`((,x ,y) 2) (make-state (+ x 1) y 2)) ;; S
(`((,x ,y) 3) (make-state x (+ y 1) 3)) ;; E
))

;; state -> state
(define (turn-left state)
(let-state state
(x y d)
(make-state x y (remainder (+ d 1) 4))))
ただし、
(define (make-state x y d)
(list (list x y) d))

(define-syntax let-state
(syntax-rules ()
((_ e1 (e2 e3 e4) e5 ...)
(let ((e2 (caar e1))
(e3 (cadar e1))
(e4 (cadr e1)))
e5 ...))))
とする。

この move と turn-left(および同様に定義した turn-right)を使って「鉛筆の軌跡」をつくり、それを適当な大きさのビットマップに対応させれば、結果として絵が描ける。そのためのプロシージャは、たとえば以下のように定義すればいい。
;; [state] -> [[boole]]
(define (bitmap-by-truth-value ps)
(define (range xs)
(list-ec (: i (apply min xs) (+ (apply max xs) 1)) i))
(define (orlist ls)
(cond ((null? ls) #f)
((car ls) #t)
(else
(orlist (cdr ls)))))
(define (in? x xs)
(orlist (map (cut equal? <> x) xs)))
(let ((codes (map car ps)))
(list-ec (: x (range (map car codes)))
(list-ec (: y (range (map cadr codes)))
(in? (list x y) codes)))))

;; [[boole]] -> string
(define (picture-with-numbermark bitmap)
(string-join
(map (lambda (y)
(string-join (map (lambda (x) (if x "#" " ")) y) "" 'strict-infix))
bitmap)
"\n" 'strict-infix))
(ちなみにコード中にコメントで示している型は厳密なものではなく、コードを書くときの便宜的なものです。)

教科書には正方形を描く例がある。でもそれは面白くない。簡単な応用として螺旋模様を描いてみよう。
(define (make-simple-spiral-states length)
(define (make-spiral-series total)
(let* ((most (floor (/ (- (sqrt (+ 1 (* 8 (- total 1)))) 1) 2)))
(lmost (iota (- most 1) 2 1))
(rest (- total (fold + 1 lmost))))
(append (list 2) lmost (if (zero? rest) '() (list rest)))))
(let ((series (make-spiral-series length))
(init-state (make-state 0 0 0)))
(scanf init-state (concatenate (map (lambda (n) (append (keep-moving n) (list turn-left))) series)))))
keep-moving と scanf は以下のような関数。
;; num -> (state -> [state])
(define (keep-moving n)
(list-tabulate n (lambda (i) move)))

;; (alpha -> beta) -> gamma -> [alpha -> beta]
(define (scanf init procs)
(if (null? procs)
'()
(let ((value ((car procs) init)))
(cons value
(scanf value (cdr procs))))))

実行するとこんな感じ。
gosh> (display (picture-with-numbermark (bitmap-by-truth-value (make-simple-spiral-states 55))))
###########
#
####### #
# # #
# ### # #
# # # # #
# # # #
# ##### #
# #
##########<undef>
(srfi-1 と srfi-42 と util.match が必要)

No comments :