文字列を螺旋にそって描く。これに似ているけど、もっと単純に、ASCIIのみからなる文字列を同心円状の渦巻に沿って出力する。交差はさせない。(できない)

howm wiki - spiral.el
http://howm.sourceforge.jp/cgi-bin/hiki/hiki.cgi?SpiralDotEl

昨日定義した関数たちを改良して、

• 螺旋のパラメータを指定できるようにする
• state の列に真偽値ではなく各文字を対応させる（同じ座標の state を飛ばす処理も必要）

ようにする。

;; num -> direction -> type -> [state]
(define (make-spiral-states length start-x start-y start-direction l-or-r)
  (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 start-x start-y start-direction))
        (turn (if (equal? l-or-r 'left) turn-left turn-right)))
    (scanf init-state (concatenate (map (lambda (n) (append (keep-moving n) (list turn))) series)))))

;; [state] -> [codes]
(define (normalize states)
  (let R ((ps '()) (codes (map car states)))
    (cond ((null? codes)
           ps)
          ((member (car codes) ps)
           (R ps (cdr codes)))
          (else
           (R (cons (car codes) ps) (cdr codes))))))

;; [codes] -> [state]
(define (stick-char codes chars)
  (map (cut list <> <>) codes chars))

;; [state] -> [[char]]
(define (bitmap ps)
  (define (range xs)
    (list-ec (: i (apply min xs) (+ (apply max xs) 1)) i))
  (define (corresponding-char code ps)
    (cond ((null? ps) " ")
          ((equal? code (caar ps)) (cadar ps))
          (else (corresponding-char code (cdr ps)))))
  (let ((codes (map car ps)))
    (list-ec (: x (range (map car codes)))
             (list-ec (: y (range (map cadr codes)))
                      (corresponding-char (list x y) ps)))))

;; [[char]] -> string
(define (picture bitmap)
  (string-join 
   (map (lambda (line) (string-join (map x->string line) "" 'strict-infix)) 
        bitmap)
   "\n" 'strict-infix))


(define (display-spiral string)
  (let ((length (string-length string)))
    (display 
     (picture
      (bitmap
       (stick-char
        (normalize (make-spiral-states length 0 0 2 'left))
        (string->list (string-join (string-split string #[\s]) "+" 'strict-infix))))))
    (newline)
    (values)))

実行例（サンプルの文字列は Gauche のトップページから引用）

gosh> (display-spiral "Gauche is an R5RS Scheme implementation developed to be a handy script interpreter,
which allows programmers and system administrators to write small to large scripts for their daily chores.
Quick startup, built-in system interface, native multilingual support are some of my goals.")

                Gauche+
                      i
nterpreter,+which+all s
i                   o +
+ all+to+large+scri w a
t m               p s n
p s ,+built-in+sy t + +
i + p           s s p R
r e u ingual+su t + r 5
c t t l       p e f o R
s i r i +my+g p m o g S
+ r a t f   o o + r r +
y w t l o   a r i + a S
d + s u + .sl t n t m c
n o + m e     + t h m h
a t k + mos+era e e e e
h + c e         r i r m
+ s i vitan+,ecaf r s e
a r u             + + +
+ o Q+.serohc+yliad a i
e t                 n m
b artsinimda+metsys+d p
+                     l
ot+depoleved+noitatneme

スクリプトの全体→ spiral-string.scm