ぷよぷよ19連鎖

puyopuyo.lisp

;; http://d.hatena.ne.jp/yarb/20110202/p1
;; http://okajima.air-nifty.com/b/2011/01/2011-ffac.html

;;; solving time (19 chain) -- 1h26min :/
;;  -rw-r--r--  1 y2q  staff     4656  5 16 04:58 puyopuyo.lisp
;;  -rw-r--r--  1 y2q  staff       22  5 16 03:32 puyopuyo.lisp~

(ql:quickload "alexandria")

(in-package :cl-user)

(defvar *puyopuyo-init-1*
  "GGR
YGG")

(defvar *puyopuyo-init-2*
"  GYRR
RYYGYG
GYGYRR
RYGYRG
YGYRYG
GYRYRG
YGYRYR
YGYRYR
YRRGRG
RYGYGG
GRYGYR
GRYGYR
GRYGYR")

(defvar *puyopuyo-init-3*
"7745564556755676
5574456445677677
5574566456675566
4456745674567457
7557755775577556
4466446644664466
7456745674567457
7567456745674576
7466446644664477
4557755775577556
4567456745674576
7756745674567456
4557755775577557
7766446644664477
4756745674567456
4567456745674567
4766446644664466
7557755775577557
7567456745674567
4456745674567457
7557755775577556
4466446644664466
7456745674567457
7567456745674567
7466446644664466
4557755775577557
4567456745674567")

(defun load-puyopuyo-board (string x y)
  (with-input-from-string (stream string)
    (loop with ret = (make-array (list x y) :element-type t :initial-element nil)
       for x from 0
       for line = (read-line stream nil nil)
       while line
       do (loop for c across line
	     for y from 0
	     do (setf (aref ret x y)
		      (if (char= c #\space) nil c)))
       finally (return ret))))

(defun load-puyopuyo-board-1 ()
  (load-puyopuyo-board *puyopuyo-init-1* 2 3))

(defun load-puyopuyo-board-2 ()
  (load-puyopuyo-board *puyopuyo-init-2* 13 6))

(defun load-puyopuyo-board-3 ()
  (load-puyopuyo-board *puyopuyo-init-3* 27 16))

#|
(2018-7-6)

これはクソ
(destructuring-bind (x-max y-max) (array-dimensions board)
  (if (and (<= 0 x) (< x x-max)
	   (<= 0 y) (< y y-max))
      (aref board x y)))

`(setf board-ref)' を見ろ
|#
(defun board-ref (board x y)
  (if (array-in-bounds-p board x y)
      (aref board x y)))

#|
(2018-7-6)

ああ、これはクソです!
(destructuring-bind (x-max y-max) (array-dimensions board)
  (if (and (<= 0 x) (< x x-max)
	   (<= 0 y) (< y y-max))
      (setf (aref board x y) val)))

`array-in-bounds-p' をなぜ使わないのか
|#
(defun (setf board-ref) (val board x y)
  (if (array-in-bounds-p board x y)
      (setf (aref board x y) val)))

#|
(2018-7-6)

array って `copy-seq' でコピーできないんだっけ？と思って、 sequence == (or vector list) と知ってびっくりしてしまった。
可能なら、Alexandria の `copy-array' を使いましょう。

(destructuring-bind (x-max y-max) (array-dimensions board)
    (loop with ret = (make-array (list x-max y-max) :element-type t :initial-element nil)
       for x from 0 below x-max
       do (loop for y from 0 below y-max
	     do (setf (board-ref ret x y) (board-ref board x y)))
       finally (return ret)))
|#
(defun copy-board (board)
  (alexandria:copy-array board))

(defun count-puyo (board x y
		   &aux (count-board (make-array (array-dimensions board) :element-type 'boolean
						 :initial-element nil))
		     (count 0))
  (unless (board-ref board x y)
    (return-from count-puyo nil))	; out of bound
  (labels
      ((count-puyo-1 (x y)
	 (when (board-ref count-board x y)
	   (return-from count-puyo-1))
	 (setf (aref count-board x y) t)
	 (incf count)
	 (let ((current (board-ref board x y))
	       (up (board-ref board x (1- y)))
	       (down (board-ref board x (1+ y)))
	       (right (board-ref board (1+ x) y))
	       (left (board-ref board (1- x) y)))
	   (when (eql current up)
	     (count-puyo-1 x (1- y)))
	   (when (eql current down)
	     (count-puyo-1 x (1+ y)))
	   (when (eql current right)
	     (count-puyo-1 (1+ x) y))
	   (when (eql current left)
	     (count-puyo-1 (1- x) y)))))
    (count-puyo-1 x y))
  (values count count-board))

(defun merge-count-board (from to)
  (destructuring-bind (x-max y-max) (array-dimensions from)
    (loop for x from 0 below x-max
       do (loop for y from 0 below y-max
	     when (board-ref from x y)
	     do (setf (board-ref to x y) t)))))

(defun mark-puyopuyo-board (board)
  (let ((mark-board (make-array (array-dimensions board) :element-type 'boolean
				:initial-element nil))
	(mark-count 0))
    (destructuring-bind (x-max y-max) (array-dimensions board)
      (loop for x from 0 below x-max
	 do (loop for y from 0 below y-max
	       do (cond
		    ((board-ref mark-board x y)
		     (progn))		; already marked
		    (t
		     (multiple-value-bind (count count-board) (count-puyo board x y)
		       (when (and count (>= count 4))
			 (incf mark-count count)
			 (merge-count-board count-board mark-board))))))))
    (values mark-count mark-board)))

(defun remove-puyo (board mark-board)
  (destructuring-bind (x-max y-max) (array-dimensions board)
    (loop for x from 0 below x-max
       do (loop for y from 0 below y-max
	     when (board-ref mark-board x y)
	     do (setf (board-ref board x y) nil)))))

(defun drop-puyo (board)
  (destructuring-bind (x-max y-max) (array-dimensions board)
    (loop for y from 0 below y-max
       ;; do (pprint y)
       do (loop for x from (1- x-max) downto 0
	     as current = (board-ref board x y)
	     when (and (null current)
		       (loop for xx from (1- x) downto 0
			  thereis (board-ref board xx y)))
	     do (loop for xx from x downto 0
		   do (setf (board-ref board xx y)
			    (board-ref board (1- xx) y)))
	       (incf x)))))

(defun make-next-state-board (board)
  (multiple-value-bind (mark-count mark-board) (mark-puyopuyo-board board)
    (if (plusp mark-count)
	(progn (setf board (copy-board board))
	       ;; (pprint board)
	       (remove-puyo board mark-board)
	       ;; (pprint board)
	       (drop-puyo board)
	       ;; (pprint board)
	       board)
	board)))

(defun print-chain (board)
  (loop for b = board then next-b
     as next-b = (make-next-state-board b)
     as count from 0
     do (format t "~2&count ~A~%" count)
     do (pprint b)
     until (eq b next-b)
     ))

To Invoke:
(print-chain (load-puyopuyo-board-2))