AA 折れ線グラフクイズ ９

id:sumim:20060408:p1 で書き直した Squeak の Smalltalk 版 および Ruby 版を、Gauche（Scheme）を用いた毎度お馴染みの直訳ぎみ＋妙な回避策で。　私自身に Scheme 力が足りないのと、push! 、pop! を無理に使ったためか、こんなんなってしまいました。ごめんなさい…。＞誰へというわけもなく

なにか後学のためのアドバイスをいただけるかもしれないので、晒しておきます。

(define (graph series)
   (let ((uppers (list ())) (lowers (list ())))
      (define (plot from to chr)
         (let ((curr 
               (if (eq? (car from) '()) (list ()) (pop! (car from)))))
            (for-each (lambda (line) (push! (car line) #\space))
               (append (car uppers) (car lowers)))
            (push! (car curr) chr)
            (push! (car to) curr)))
      (for-each (lambda (code)
            (case code
               ((#\R) (plot lowers uppers #\/))
               ((#\F) (plot uppers lowers #\\))
               ((#\C) (plot uppers uppers #\_))))
         (reverse (string->list series)))
      (for-each (lambda (line)
            (display (list->string (car line))) (display #\newline))
         (append (reverse (car uppers)) (car lowers)))))

(graph "RCRFCRFFCCRFFRRCRRCCFRFRFF")

念のため、なんでリストへのアクセスの際に常に (car ...) なのか…というと、Gauche の push! と pop! がいつも値の再代入になるため（これが仕様です）、複数のシンボルからいつも同じオブジェクトを参照できるようにするのに、このフォームを使用する方法しか思いつかなかったからです。

(define a '(1))
(define b a)
(eq? a b)             ;=> #t

(push! a 2)
(eq? a b)             ;=> #f
a                     ;=> (2 1)
b                     ;=> (1)

(set! a (list '(1)))
(set! b a)

(push! (car a) 2)
(eq? a b)             ;=> #t
a                     ;=> ((2 1))
b                     ;=> ((2 1))

追記：
ためしに…と、CONS セルを使い回す push と pop を自前で持ってみました。かいあって (car ...) は無くせたのですが、ただこれだと、本体の簡潔な記述のありがたみが文字通り“半減”ですねぇ〜。

(define (graph series)
   (let ((uppers (list ())) (lowers (list ())))
      (define (push list obj)
         (if (null? lst) #f
            (if (null? (car lst)) (set-car! lst obj)
               (begin
                  (set-cdr! lst (cons (car lst) (cdr lst)))
                  (set-car! lst obj)))))
      (define (pop lst)
         (let ((result (car lst)))
            (if (= (length lst) 1) (set-car! lst ())
               (begin
                  (set-car! lst (cadr lst))
                  (set-cdr! lst (cddr lst))))
         result))
      (define (plot from to chr)
         (let ((curr (if (null? (car from)) (list ()) (pop from))))
            (for-each (cut push <> #\space) (append uppers lowers))
            (push curr chr)
            (push to curr)))
      (for-each (lambda (code)
            (case code
               ((#\R) (plot lowers uppers #\/))
               ((#\F) (plot uppers lowers #\\))
               ((#\C) (plot uppers uppers #\_))))
         (reverse (string->list series)))
      (for-each (lambda (line)
            (display (list->string line)) (display #\newline))
         (append (reverse uppers) lowers))))

(graph "RCRFCRFFCCRFFRRCRRCCFRFRFF")

多値で受け渡す版

(use srfi-11)
(use gauche.sequence)

(define (graph series)
   (define (car-gn lst) (if (null? lst) () (car lst)))
   (define (cdr-gn lst) (if (null? lst) () (cdr lst)))
   (define (push-sp lsts) (map (cut cons #\space <>) lsts))
   (let-values (((uppers lowers)
         (fold2 (lambda (code upps lows)
              (case code
                  ((#\R) (values 
                     (cons (cons #\/ (car-gn lows)) (push-sp upps))
                     (push-sp (cdr-gn lows))))
                  ((#\F) (values
                     (push-sp (cdr-gn upps))
                     (cons (cons #\\ (car-gn upps)) (push-sp lows))))
                  ((#\C) (values
                     (cons (cons #\_ (car-gn upps)) (push-sp (cdr-gn upps)))
                     (push-sp lows)))))
            () () (reverse (string->list series)))))
      (for-each (lambda (line)
            (display (list->string line)) (display #\newline))
         (append (reverse uppers) lowers))))

(graph "RCRFCRFFCCRFFRRCRRCCFRFRFF")