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 が必要）