ぷよぷよ19連鎖の問題

ぷよぷよ19連鎖の問題をschemeで解いてみた。最近書いていなかったので何か手続的な書き方になってしまっているかも？

(use srfi-42)
(use gauche.experimental.ref)
(use gauche.experimental.app :only ($))
(use gauche.experimental.lamb)
(use gauche.sequence :only (for-each-with-index for-each))

(define (load-data file)
  (let1 seq (call-with-input-file file 
              (cut port->list read-line <>))
    (vector-ec (: line seq)
               ($ list->vector $ string->list line))))

(define (at board y x)
  (guard (e (else #f))
    (~ board y x)))

(define (board-each-with-index fn board)
  (for-each-with-index 
   (^ (i row) (for-each-with-index (cut fn i <> <> ) row))
   board))

;;; output util
(define (color-display n str)
  (display (apply string `(#\escape #\[ ,@(string->list (x->string n)) #\m)))
  (display str)
  (display (apply string '(#\escape #\[ #\0 #\m))))
  
(define (display* x)
  (case x
    [(#\R) (color-display 31 x)]
    [(#\G) (color-display 32 x)]
    [(#\Y) (color-display 33 x)]
    [(#\B) (color-display 34 x)]
    (else (display x))))

(define (show-board board)
  (display (apply string '(#\escape #\[ #\2 #\J)))
  (for-each (^ (row)
               (newline)
               (for-each display* row))
            board)
  (newline))


(define (all-groups board)
  (rlet1 results (list)
    (let1 ht (make-hash-table 'equal?)
      (board-each-with-index 
       (lambda (y x e)
         (let1 r (search-group board ht y x)
           (unless (null? r)
             (push! results r))))
       board))))

(define (search-group board ht y x)
  (let1 e (at board y x)
    (define (visited? k)
      (hash-table-exists? ht k))
    (define (update y x r)
      (let1 e* (at board y x)
        (cond ((or (not e*) (visited? (cons y x)))
               r)
              ((equal? e* e)
               (hash-table-put! ht (cons y x) #t)
               (collect y x (cons (list e* y x) r)))
              (else r))))
    (define (collect y x r)
      (fold (^ (i j r)
               (update (+ i y) (+ j x) r))
            r '(0 0 -1 1) '(-1 1 0 0)))
    (cond ((equal? e #\space) '())
          (else (collect y x (update y x '()))))))

(define (fall! board y x)
  (do-ec (: i y 0 -1)
         (begin
           (set! (~ board i x) (at board (- i 1) x))
           (set! (~ board (- i 1) x) #\space))))


(define (vanish! board group)
  (for-each (^ (args) (apply fall! board args))
            (sort-by (map cdr group) car)))

(define N 4)
(define (check-and-vanish! board)
  (rlet1 status #f
    (do-ec (: group (all-groups board))
           (if (>= (length group) N))
           (begin (vanish! board group)
                  (set! status #t)))))

;;; main
(define board (load-data "data.txt"))
(begin (show-board board))
(while (check-and-vanish! board)
  (sys-nanosleep 300000000)
  (show-board board))