ぷよぷよ問題(2)

前に一度、問題文をちゃんと読まずに公開してしまいました。どうもすみません。<_o_>
で、以下に同じものを公開します。

人材募集企画 2011年版: 人生を書き換える者すらいた。

面白そうだったので、刹那的にやってみました。
問題をファイルに保存して引数で渡して起動。
まだまだ Gauche のイディオムがスムーズに思い浮かばないですなぁ。index で走査するプログラムとか、ほとんど作ったことないのですけど、こういうもんなんだろうか。
それにしても汚い。あんまり使わないようにしている破壊的な関数も使ってしまったし。他の人の作ったのが読みたい。

#!/usr/local/bin/gosh

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

(debug-print-width #f)

(define (main args)
  (let1 file (cadr args)
    (let1 block (read-block-from-file file)
      (print-block block)
      (boot-puyopuyo block)))
  0)

(define (boot-puyopuyo block)
  (let loop ((rensa 1)
             (group (group-blocks block)))
    (when (pair? group)
      (let1 newblock (apply-grouped block group)
        (print-block newblock rensa)
        (loop (+ rensa 1) (group-blocks newblock))))))

(define (apply-grouped block groups)
  (map
   (lambda (group)
     (set! block (delete-block-cell block group)))
   groups)
  block)

(define (delete-block-cell block group)
  (map
   (lambda (cell)
     (let* ((x (car cell))
            (y (cdr cell)))
       (set-cell! (list-ref block y) x #\space)))
   group)
  (map-block
   (lambda (x pseudo-y color)
     (let1 y (- (length block) pseudo-y 1)
       (when (eq? color #\space)
         (let ((line (list-ref block y)))
           (receive (newcolor orig-y)
               (color-dropped-to block x y)
             (let1 line (list-ref block y)
               (set-cell! line x newcolor))
             (when orig-y
               (let1 line (list-ref block orig-y)
                 (set-cell! line x #\space))))))))
   (reverse block))
  block)

(define (color-dropped-to block x y)
  (let1 color (color-at block x y)
    (cond
     ((not (eq? color #\space))
      (values color y))
     ((> y 0)
      (color-dropped-to block x (- y 1)))
     (else
      (values #\space #f)))))

(define (map-block proc block)
  (map-with-index
   (lambda (y line)
     (map-with-index
      (lambda (x color)
        (proc x y color))
      line))
   block))

(define (set-cell! line x color)
  (if (= x 0)
    (set! (car line) color)
    (set-cell! (cdr line) (- x 1) color)))

(define (group-blocks block)
  (let ((done '())
        (grouped '()))
    (map-block
     (lambda (x y color)
       (unless (member (cons x y) done)
         (let1 group (sequence-color done block x y)
           (set! done (append (cons (cons x y) done) group))
           (when (and (pair? group)
                      (>= (length group) 4))
             (set! grouped (cons group grouped))))))
     block)
    grouped))

(define (sequence-color history block x y)
  (let1 color1 (color-at block x y)
    (if (member color1 '(#\G #\Y #\R))
      (fold
       (lambda (pair res)
         (cond
          ((member (cons x y) history)
           res)
          ((equal? color1 (color-at block (car pair) (cdr pair)))
           (let1 newres (cons (cons (car pair) (cdr pair)) res)
             (let1 newhist (cons (cons x y) history)
               (lset-union equal? 
                           newres
                           (sequence-color newhist block (car pair) (cdr pair))))))
          (else
           res)))
       '()
       (list
        (cons (- x 1) y)
        (cons x (- y 1))
        (cons (+ x 1) y)
        (cons x (+ y 1))))
      '())))

(define (color-at block x y)
  (cond
   ((< y 0) #f)
   ((<= (length block) y)
    #f)
   (else
    (let1 line (list-ref block y)
      (cond
       ((< x 0) #f)
       ((<= (length line) x)
        #f)
       (else
        (list-ref line x)))))))

(define *spell-list*
  '(
    "ファイヤー!"
    "アイスストーム!"
    "ダイアキュート!"
    "ブレインダムド!"
    "じゅげむ!"
    "ばよえ〜ん!"))

(define (print-block block :optional (rensa #f))
  (when rensa
    (let1 spell (list-ref *spell-list* (- (min rensa (length *spell-list*)) 1))
      (print (format #`",|spell| ,|rensa| 連鎖"))))
  (map 
   (lambda (line)
     (print (apply string line)))
   block)
  (print (make-string 10 #\-)))

(define (read-block-from-file file)
  (with-input-from-file file
    (lambda ()
      (let loop ((res '())
                 (l (read-line)))
        (if (eof-object? l)
          (reverse res)
          (loop (cons (string->list l) res) (read-line)))))))

所用時間 3 時間。1時間半経過時点でできそうにないので呪文を表示する機能も付けてみました。
こんな様子では採用されそうにありませんね。残念です。。
でも refactoring してたら gauche 上達しそう。