ミニマックス法でリバーシ

reversi.lisp

;;load後、(ltk::main)で実行

#|
(require :asdf-install)
(asdf-install:install :ltk)
|#
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :ltk))

(in-package :ltk)


(defparameter *board-offset* 10)
(defparameter *cell-size* 30)

(defvar *current-turn* 'white)
(defvar *board* nil)

(defun update-text (tb txt)
  (setf (text tb) (format nil "~A~%~A" txt (text tb))))

(defun change-turn (tb)
  (block exit
    (setq *current-turn* (reverse-color *current-turn*))
    (when (null (get-puttable-list *board* *current-turn*))
      (update-text tb "置けるところがありません。")
      (if (null (get-puttable-list *board* (reverse-color *current-turn*)))
	  (multiple-value-bind (total black white) (count-cell *board*)
	    (do-msg (format nil "ゲームセット~%~A - ~A で~Aです。"
			    black white (cond ((> black white) "あなたの勝ち")
					      ((= black white) "引き分け")
					      (t "あなたの負け"))))
	    (setf *exit-mainloop* t)
	    (return-from exit))
	  (setq *current-turn* (reverse-color *current-turn*))))
    (if (eq *current-turn* 'white)
	(progn
	  (update-text tb "コンピュータの番です。思考中...")
	  (multiple-value-bind (v pos) (search-ab *board* 'max 'white nil nil 0)
	    (update-text tb (format nil "コンピュータは(~A,~A)に置きました。"
				     (car pos) (cdr pos)))
	    (setq *board* (put *board* (car pos) (cdr pos) 'white)))
	  (change-turn tb))
	(update-text tb "あなたの番です。"))))
      

(defun main ()
  (setf *debug-tk* nil)
  (setf *current-turn* 'white)
  (setf *board* (make-board))
  (with-ltk ()
    (let* ((canvas (make-instance 'canvas))
	   (frame (make-instance 'frame))
	   (tb (make-text frame :width nil :height 2)))
      (pack canvas)
      (pack frame)
      (pack tb)
      (bind canvas "<ButtonPress-1>"
	    (lambda (evt)                    
	      (let* ((mouse-x (event-x evt)) (mouse-y (event-y evt))
		     (rx (- mouse-x *board-offset*))
		     (ry (- mouse-y *board-offset*))
		     (cx (truncate rx *cell-size*)) (cy (truncate ry *cell-size*))
		     (puttable (get-puttable-list *board* 'black)))
		(if (and (eq *current-turn* 'black)
			 (member (cons cx cy) puttable :test #'equal))
		    (progn
		      (update-text tb (format nil "あなたは(~A,~A)に置きました。" cx cy))
		      (setq *board* (put *board* cx cy 'black))
		      (draw-board canvas)
		      (change-turn tb)
		      (draw-board canvas))
		    (do-msg "そこには置けません")))))
      (draw-board canvas)
      (change-turn tb))))
		

(defun draw-board (canvas)
  (clear canvas)
  (dotimes (x *board-xsize*)
    (dotimes (y *board-ysize*)
      (itemconfigure
       canvas
       (create-rectangle
	canvas
        (+ *board-offset* (* x *cell-size*))
	(+ *board-offset* (* y *cell-size*))
	(+ *board-offset* (* (1+ x) *cell-size*))
	(+ *board-offset* (* (1+ y) *cell-size*)))
       "outline" "black")))
  (dolist (cell *board*)
    (destructuring-bind (x y color) cell
      (itemconfigure
       canvas
       (create-oval canvas
		    (+ *board-offset* (* x *cell-size*))
		    (+ *board-offset* (* y *cell-size*))
		    (+ *board-offset* (* x *cell-size*) *cell-size*)
		    (+ *board-offset* (* y *cell-size*) *cell-size*))
       "fill" (if (eq color 'black) "black" "white")))))


(defparameter *board-xsize* 8)
(defparameter *board-ysize* 8)
(defparameter *depth-limit* 4)

(defun make-board ()
  (assert (and (evenp *board-xsize*) (evenp *board-ysize*)
	       (> *board-xsize* 2) (> *board-ysize* 2)))
  (list (list (/ *board-xsize* 2) (/ *board-ysize* 2) 'white)
	(list (1- (/ *board-xsize* 2)) (/ *board-ysize* 2) 'black)
	(list (/ *board-xsize* 2) (1- (/ *board-ysize* 2)) 'black)
	(list (1- (/ *board-xsize* 2)) (1- (/ *board-ysize* 2)) 'white)))

(defun sign (n)
  (cond ((plusp n) 1)
	((zerop n) 0)
	(t -1)))

(defun get-turn-list (board x y color)
  (labels ((collect (dx dy)
	     (remove-if-not (lambda (item)
			       (and
				(or (= 0 (* dx dy))
				     (= (abs (- (first item) x))
					(abs (- (second item) y))))
				(= dx (sign (- (first item) x)))
				(= dy (sign (- (second item) y))))) board))
	   (turn-list-sub (dx dy)
	     (let* ((sort-op (if (plusp (if (zerop dy) dx dy)) #'< #'>))
		    (line (sort (collect dx dy)
				(lambda (a b)
				  (if (zerop dy)
				      (funcall sort-op (first a) (first b))
				      (funcall sort-op (second a) (second b))))))
		    (tlist nil))
	       (do ((current-x (+ x dx) (+ current-x dx))
		    (current-y (+ y dy) (+ current-y dy))
		    (line-ptr line (cdr line-ptr)))
		   ((or
		     (null line-ptr)
		     (/= (caar line-ptr) current-x)
		     (/= (cadar line-ptr) current-y))
		    (setq tlist nil))
		 (if (eq (caddar line-ptr) color)
		     (return)
		     (push (cons current-x current-y) tlist)))
	       tlist)))
    (mapcan (lambda (x)
	      (mapcan (lambda (y)
			(turn-list-sub x y)) '(-1 0 1))) '(-1 0 1))))

(defun reverse-color (c)
  (if (eq c 'black) 'white 'black))

(defun reverse-phase (p)
  (if (eq p 'max) 'min 'max))

(defun put (board x y color)
  (let ((tl (get-turn-list board x y color)))
    (cons (list x y color)
	  (mapcar (lambda (item)
		    (if (find-if (lambda (ti)
				   (and (= (car ti) (first item))
					(= (cdr ti) (second item)))) tl)
			(list (first item) (second item) color)
			item)) board))))

(defun count-cell (board)
  (let* ((total (length board))
	 (black (length (remove-if (lambda (item) (eq (third item) 'white)) board)))
	 (white (- total black)))
    (values total black white)))

(defparameter bp
  #2A((45 -11 4 -1 -1 4 -11 45)
      (-11 -16 -1 -3 -3 2 -16 -11)
      (4 -1 2 -1 -1 2 -1 4)
      (-1 -3 -1 0 0 -1 -3 -1)
      (-1 -3 -1 0 0 -1 -3 -1)
      (4 -1 2 -1 -1 2 -1 4)
      (-11 -16 -1 -3 -3 -1 -16 -11)
      (45 -11 4 -1 -1 4 -11 45)))

;;確定石を数える
(defun count-fixed (board color)
  (let ((map (make-array '(8 8))))
    (mapc (lambda (cell)
	    (if (eq (third cell) color)
		(setf (aref map (first cell) (second cell)) 1))) board)
    ;;四隅は確定
    (mapc (lambda (c) (if (eq (aref map (car c) (cdr c)) 1)
			  (setf (aref map (car c) (cdr c)) 2)))
	  '((0 . 0) (7 . 7) (0 . 7) (7 . 0)))
    (dotimes (i 8)
      (if (eq (aref map i 0) 0)
	  (return)
	  (setf (aref map i 0) 2)))
    (dotimes (i 8)
      (if (eq (aref map i 7) 0)
	  (return)
	  (setf (aref map i 7) 2)))
    (dotimes (i 8)
      (if (eq (aref map 0 i) 0)
	  (return)
	  (setf (aref map 0 i) 2)))
    (dotimes (i 8)
      (if (eq (aref map 7 i) 0)
	  (return)
	  (setf (aref map 7 i) 2)))
    (dotimes (i 8)
      (if (eq (aref map (- 7 i) 0) 0)
	  (return)
	  (setf (aref map (- 7 i) 0) 2)))
    (dotimes (i 8)
      (if (eq (aref map (- 7 i) 7) 0)
	  (return)
	  (setf (aref map (- 7 i) 7) 2)))
    (dotimes (i 8)
      (if (eq (aref map 0 (- 7 i)) 0)
	  (return)
	  (setf (aref map 0 (- 7 i)) 2)))
    (dotimes (i 8)
      (if (eq (aref map 7 (- 7 i)) 0)
	  (return)
	  (setf (aref map 7 (- 7 i)) 2)))
    (dotimes (x 8)
      (dotimes (y 8)
	(if (eq (aref map x y) 0)
	  (return)
	  (setf (aref map x y) 2))))
    (dotimes (x 8)
      (dotimes (y 8)
	(if (eq (aref map x (- 7 y)) 0)
	  (return)
	  (setf (aref map x (- 7 y)) 2))))
    (dotimes (y 8)
      (dotimes (x 8)
	(if (eq (aref map x y) 0)
	  (return)
	  (setf (aref map x y) 2))))
    (dotimes (y 8)
      (dotimes (x 8)
	(if (eq (aref map (- 7 x) y) 0)
	  (return)
	  (setf (aref map (- 7 x) y) 2))))
    (let ((sum 0))
      (dotimes (x 8)
	(dotimes (y 8)
	  (if (eq (aref map x y) 2)
	      (incf sum))))
      sum)))

(defun static-eval (board color)
  (let ((bp-val (apply #'+
		       (mapcar (lambda (cell)
				 (let ((cx (first cell)) (cy (second cell))
				       (cc (third cell)))
				   (* (aref bp cy cx) (if (eq color cc) 1 -1)))) board)))
	(fs-val (count-fixed board color)))
    (+ (* bp-val 1) (* fs-val 3))))

(defun get-puttable-list (board color)
  (let ((all-cells))
    (dotimes (x *board-xsize*)
      (dotimes (y *board-ysize*)
	(push (cons x y) all-cells)))
    (remove-if (lambda (pos)
		 (null (get-turn-list board (car pos) (cdr pos) color)))
	       (set-difference all-cells board :test (lambda (a b)
						       (and (= (car a) (first b))
							    (= (cdr a) (second b))))))))

(defun max-ignore-nil (&rest items)
  (apply #'max (remove-if #'null items)))

(defun min-ignore-nil (&rest items)
  (apply #'min (remove-if #'null items)))

(defun take (n list)
  (if (>= n (length list))
      list
      (subseq list 0 n)))

(defun search-ab (board phase color alpha beta depth)
  (if (< *depth-limit* depth)
      (static-eval board color)
      (let* ((puttable (get-puttable-list board color))
	     (sval (mapcar (lambda (pos)
				    (cons
				     (static-eval
				      (put board (car pos) (cdr pos) color) color)
				     pos))
			   puttable))
	     (sorted-sval (take
			   (- 10 depth) ;;候補の上限数
			   (sort sval (lambda (a b)
				       (case phase
					 (max (> (car a) (car b)))
					 (min (< (car a) (car b)))))))))
	(if (null puttable)
	    (static-eval board color)
	    (let ((current-top nil) (top-pos nil))
	      (block cut-exit
		(dolist (candidate sorted-sval)
		  (let* ((cx (cadr candidate))
			 (cy (cddr candidate))
			 (new-alpha (if (eq phase 'min) current-top alpha))
			 (new-beta (if (eq phase 'max) current-top beta))
			 (child-result (search-ab (put board cx cy color)
						  (reverse-phase phase)
						  color
						  new-alpha new-beta (1+ depth))))
		    (when child-result
		      (case phase
			(min (if (and (not (null alpha)) (>= alpha child-result))
				 (progn
				   ;;(print "αカット!")
				   (return-from cut-exit))
				 (progn
				   (setq
				    current-top
				    (min-ignore-nil current-top child-result))
				   (if (= current-top child-result)
				       (setq top-pos (cons cx cy))))))
			(max (if (and (not (null beta)) (<= beta child-result))
				 (progn
				   ;;(print "βカット!")
				   (return-from cut-exit))
				 (progn
				   (setq
				    current-top
				    (max-ignore-nil current-top child-result))
				   (if (= current-top child-result)
				       (setq top-pos (cons cx cy)))))))))))
	      (values current-top top-pos))))))