一昨日のエントリのように文字列をうねうね曲げる。とりあえず1バイト文字バージョンで妥協。あとは、折り曲げるポイントを割り出すための仕組みが必要か。

; (fold-puts '("a" ("b" . "l") "c" "d" ("e" . "d") "f" "g"))
; =>
; edcb
; f  a
; g  
;
(use srfi-1)

(define culc-room-space
  (lambda (ls)
    (cons
      (if (>= (car ls) (cadr ls))
          (car ls)
          (cadr ls))
      (if (>= (caddr ls) (cadddr ls))
          (caddr ls)
          (cadddr ls)))))

(define count-direction
  (lambda (ls)
    (let f ((ls ls) (height+ 1) (height- 1) (width+ 1) (width- 1) (direction "u"))
      (if (null? (cdr ls))
          (cond ((equal? direction "l")
                   (list height+ height- (- width+ 1) width-))
                ((equal? direction "r")
                   (list height+ height- width+ (- width- 1)))
                ((equal? direction "u")
                   (list (- height+ 1) height- width+ width-))
                ((equal? direction "d")
                   (list height+ (- height- 1) width+ width-)))
          (if (and (pair? (car ls)) (dotted-list? (car ls)))
              (cond ((equal? (cdr (car ls)) "l")
                      (f (cdr ls) height+ height- (+ width+ 1) width- "l"))
                    ((equal? (cdr (car ls)) "r")
                      (f (cdr ls) height+ height- width+ (+ width- 1) "r"))
                    ((equal? (cdr (car ls)) "u")
                      (f (cdr ls) (+ height+ 1) height- width+ width- "u"))
                    ((equal? (cdr (car ls)) "d")
                      (f (cdr ls) height+ (+ height- 1) width+ width- "d")))
              (cond ((equal? direction "l")
                      (f (cdr ls) height+ height- (+ width+ 1) width- direction))
                    ((equal? direction "r")
                      (f (cdr ls) height+ height- width+ (+ width- 1) direction))
                    ((equal? direction "u")
                      (f (cdr ls) (+ height+ 1) height- width+ width- direction))
                    ((equal? direction "d")
                      (f (cdr ls) height+ (+ height- 1) width+ width- direction))
                    (else
                      (f (cdr ls) height width direction))))))))

(define make-room          
  (lambda (size)
    (do ((m (make-vector (car size)))
         (i 0 (+ i 1)))
        ((= i (car size)) m)
        (vector-set! m i (make-vector (cdr size))))))

(define puts-room
  (lambda (m)
    (do ((i 0 (+ i 1)))
        ((= i (vector-length m)))
        (print
          (let ((column (vector-ref m i)))
            (do ((i 0 (+ i 1)))
                ((= i (vector-length column)))
                (let ((char (vector-ref column i)))
                  (if (string? char)
                      (display char)
                      (display " ")))))))))

(define set-char-at!
  (lambda (room i j character)
    (vector-set! (vector-ref room i) j character)))

(define fold-puts
  (lambda (ls)
    (let* ((dirs (count-direction ls)) (m (make-room (culc-room-space dirs))))
      (let puts ((i (- (car dirs) 1))
                 (j (- (caddr dirs) 1))
                 (ls ls)
                 (dir "u"))
        (if (null? (cdr ls))
            (puts-room m)
            (if (and (pair? (car ls)) (dotted-list? (car ls)))
                (begin 
                  (set-char-at! m i j (caar ls))
                  (cond ((equal? (cdr (car ls)) "l")
                           (puts i (- j 1) (cdr ls) "l"))
                        ((equal? (cdr (car ls)) "r")
                           (puts i (+ j 1) (cdr ls) "r"))
                        ((equal? (cdr (car ls)) "u")
                           (puts (- i 1) j (cdr ls) "u"))
                        ((equal? (cdr (car ls)) "d")
                           (puts (+ i 1) j (cdr ls) "d"))))
                (begin
                  (set-char-at! m i j (car ls))
                  (cond ((equal? dir "l")
                           (puts i (- j 1) (cdr ls) "l"))
                        ((equal? dir "r")
                           (puts i (+ j 1) (cdr ls) "r"))
                        ((equal? dir "u")
                           (puts (- i 1) j (cdr ls) "u"))
                        ((equal? dir "d")
                           (puts (+ i 1) j (cdr ls) "d"))))))))))

しかしまたみにくいなあ。やたらにcondだらけ。屈折した文字列をディスプレイするのに必要なマスの大きさを求めるのと、実際に屈折させた文字列を書き出すところは、同じようなcondが続く。こういう場面で、きっとマクロを使うに違いない。
ところでこんなものを曝すことに第三者的な意義なんてありえない。だから、これは自身のモチベーション維持としての役割なんだろう。