LtkでGUIの練習―オセロ盤

Common Lispには全てのウィジェットがCLOSオブジェクトという強力なGUI環境の仕様CLIM(Common Lisp Interface Manager)というのがあって、商用の実装Allegro CLIMやオープンソースの実装McCLIMがある。しかしMcCLIMはかなり大きいライブラリなのでインストールやロードが大変だったりする。
一方、Tcl/TkをLispから呼ぶライブラリとしてLtkがあり、こっちはMcCLIMよりかなり軽量なGUIライブラリだ。コアとなるファイルはltk.lispの一つしかない。Tcl/TkはUNIXだろうとMacだろうとWindowsだろうと使えるので、CLISPみたいなポータブルな処理系と組み合わせると色んなところで使えそう。

お盆は山形に行っていたのだけど、ネット環境もないので、甥っ子たちと遊ぶ用のオセロ盤をLtkでつくってみた。ちゃんと置けるところはハイライトするようにしたりヒストリ機能をつけたりしてみた。

Ltkのインストール

事前にtcl/tkをインストールしておくことが必要。でもLinuxとかなら普通は入っているはず。
asdf-installから、

(require 'asdf-install)
(asdf-install:install :ltk)

とやっても普通にインストールできるが、ちょっとバージョンが古いのでLtkの公式サイトから最新版のtar玉をダウンロードしてきて、*central-registory*のパスにasdファイルへのシンボリックリンクを張っておくことによってもインストールできる。

FreeBSDの場合、tclの実行コマンドwishにバージョン番号がついているのでバージョンが違うと動かない。その場合、ltk.lispの中の*wish-pathname*

(defvar *wish-pathname*
  #+freebsd "wish8.4"
  #-freebsd "wish")

をwish8.5とかに変更する必要がある。

(asdf:oos 'asdf:load-op :ltk)
(ltk:ltktest)

で次のような画面が出てくればインストールは成功している。

;; load ltk
(ql:quickload '(:ltk :alexandria))

(defpackage :reversi
  (:use :cl :ltk)
  (:import-from #:alexandria
                #:copy-array)
  (:export #:reversi-board))

(in-package :reversi)

;; define variables
(defparameter *board* (make-array '(8 8)))
(defvar *board-stack-back*)
(defvar *board-stack-forward*)

(defparameter cell-size 55)
(defparameter margin-size 10)

(defconstant +black+ 1)
(defconstant +white+ 2)

(defun init-board! (board)
  (setf *board-stack-back* nil)
  (setf *board-stack-forward* nil)
  (loop for i from 0 below (array-dimension board 0) do
    (loop for j from 0 below (array-dimension board 1) do
      (cond ((and (= i (1- (/ (array-dimension board 0) 2)))
		  (= j (1- (/ (array-dimension board 1) 2))))
	     (setf (aref board i j) +black+))
	    ((and (= i (/ (array-dimension board 0) 2))
		  (= j (/ (array-dimension board 1) 2)))
	     (setf (aref board i j) +black+))
	    ((and (= i (1- (/ (array-dimension board 0) 2)))
		  (= j (/ (array-dimension board 1) 2)))
	     (setf (aref board i j) +white+))
	    ((and (= i (/ (array-dimension board 0) 2))
		  (= j (1- (/ (array-dimension board 1) 2))))
	     (setf (aref board i j) +white+))
	    (t (setf (aref board i j) 0))))))

(defun opposite (self-b/w)
  (if (= self-b/w +black+)
      +white+
      +black+))

(defun h-line-plus-check (board i j self-b/w &key (cnt 0))
  (cond ((= j (1- (array-dimension board 1))) nil)
	((= (aref board i (1+ j)) 0) nil)
	((= (aref board i (1+ j)) (opposite self-b/w))
	 (h-line-plus-check board i (1+ j) self-b/w :cnt (1+ cnt)))
	((= (aref board i (1+ j)) self-b/w) cnt)))

(defun h-line-plus-reverse! (board i j self-b/w)
  (when (= (aref board i (1+ j)) (opposite self-b/w))
    (setf (aref board i (1+ j)) self-b/w)
    (h-line-plus-reverse! board i (1+ j) self-b/w)))

(defun h-line-minus-check (board i j self-b/w &key (cnt 0))
  (cond ((= j 0) nil)
	((= (aref board i (1- j)) 0) nil)
	((= (aref board i (1- j)) (opposite self-b/w))
	 (h-line-minus-check board i (1- j) self-b/w :cnt (1+ cnt)))
	((= (aref board i (1- j)) self-b/w) cnt)))

(defun h-line-minus-reverse! (board i j self-b/w)
  (when (= (aref board i (1- j)) (opposite self-b/w))
    (setf (aref board i (1- j)) self-b/w)
    (h-line-minus-reverse! board i (1- j) self-b/w)))

(defun v-line-plus-check (board i j self-b/w &key (cnt 0))
  (cond ((= i (1- (array-dimension board 0))) nil)
	((= (aref board (1+ i) j) 0) nil)
	((= (aref board (1+ i) j) (opposite self-b/w))
	 (v-line-plus-check board (1+ i) j self-b/w :cnt (1+ cnt)))
	((= (aref board (1+ i) j) self-b/w) cnt)))

(defun v-line-plus-reverse! (board i j self-b/w)
  (when (= (aref board (1+ i) j) (opposite self-b/w))
    (setf (aref board (1+ i) j) self-b/w)
    (v-line-plus-reverse! board (1+ i) j self-b/w)))

(defun v-line-minus-check (board i j self-b/w &key (cnt 0))
  (cond ((= i 0) nil)
	((= (aref board (1- i) j) 0) nil)
	((= (aref board (1- i) j) (opposite self-b/w))
	 (v-line-minus-check board (1- i) j self-b/w :cnt (1+ cnt)))
	((= (aref board (1- i) j) self-b/w) cnt)))

(defun v-line-minus-reverse! (board i j self-b/w)
  (when (= (aref board (1- i) j) (opposite self-b/w))
    (setf (aref board (1- i) j) self-b/w)
    (v-line-minus-reverse! board (1- i) j self-b/w)))

(defun right-naname-plus-check (board i j self-b/w &key (cnt 0))
  (cond ((or (= i (1- (array-dimension board 0)))
	     (= j (1- (array-dimension board 1)))) nil)
	((= (aref board (1+ i) (1+ j)) 0) nil)
	((= (aref board (1+ i) (1+ j)) (opposite self-b/w))
	 (right-naname-plus-check board (1+ i) (1+ j) self-b/w :cnt (1+ cnt)))
	((= (aref board (1+ i) (1+ j)) self-b/w) cnt)))

(defun right-naname-plus-reverse! (board i j self-b/w)
  (when (= (aref board (1+ i) (1+ j)) (opposite self-b/w))
    (setf (aref board (1+ i) (1+ j)) self-b/w)
    (right-naname-plus-reverse! board (1+ i) (1+ j) self-b/w)))

(defun right-naname-minus-check (board i j self-b/w &key (cnt 0))
  (cond ((or (= i 0)
	     (= j 0)) nil)
	((= (aref board (1- i) (1- j)) 0) nil)
	((= (aref board (1- i) (1- j)) (opposite self-b/w))
	 (right-naname-minus-check board (1- i) (1- j) self-b/w :cnt (1+ cnt)))
	((= (aref board (1- i) (1- j)) self-b/w) cnt)))

(defun right-naname-minus-reverse! (board i j self-b/w)
  (when (= (aref board (1- i) (1- j)) (opposite self-b/w))
    (setf (aref board (1- i) (1- j)) self-b/w)
    (right-naname-minus-reverse! board (1- i) (1- j) self-b/w)))

(defun left-naname-plus-check (board i j self-b/w &key (cnt 0))
  (cond ((or (= i 0)
	     (= j (1- (array-dimension board 1)))) nil)
	((= (aref board (1- i) (1+ j)) 0) nil)
	((= (aref board (1- i) (1+ j)) (opposite self-b/w))
	 (left-naname-plus-check board (1- i) (1+ j) self-b/w :cnt (1+ cnt)))
	((= (aref board (1- i) (1+ j)) self-b/w) cnt)))

(defun left-naname-plus-reverse! (board i j self-b/w)
  (when (= (aref board (1- i) (1+ j)) (opposite self-b/w))
    (setf (aref board (1- i) (1+ j)) self-b/w)
    (left-naname-plus-reverse! board (1- i) (1+ j) self-b/w)))

(defun left-naname-minus-check (board i j self-b/w &key (cnt 0))
  (cond ((or (= i (1- (array-dimension board 0)))
	     (= j 0)) nil)
	((= (aref board (1+ i) (1- j)) 0) nil)
	((= (aref board (1+ i) (1- j)) (opposite self-b/w))
	 (left-naname-minus-check board (1+ i) (1- j) self-b/w :cnt (1+ cnt)))
	((= (aref board (1+ i) (1- j)) self-b/w) cnt)))

(defun left-naname-minus-reverse! (board i j self-b/w)
  (when (= (aref board (1+ i) (1- j)) (opposite self-b/w))
    (setf (aref board (1+ i) (1- j)) self-b/w)
    (left-naname-minus-reverse! board (1+ i) (1- j) self-b/w)))

(defun put-stone! (board i j b/w)
  (let ((h-line-plus-check?        (and (h-line-plus-check        board i j b/w)
				        (> (h-line-plus-check        board i j b/w) 0)))
	(h-line-minus-check?       (and (h-line-minus-check       board i j b/w)
				        (> (h-line-minus-check       board i j b/w) 0)))
	(v-line-plus-check?        (and (v-line-plus-check        board i j b/w)
				        (> (v-line-plus-check        board i j b/w) 0)))
	(v-line-minus-check?       (and (v-line-minus-check       board i j b/w)
				        (> (v-line-minus-check       board i j b/w) 0)))
	(right-naname-plus-check?  (and (right-naname-plus-check  board i j b/w)
				        (> (right-naname-plus-check  board i j b/w) 0)))
	(right-naname-minus-check? (and (right-naname-minus-check board i j b/w)
				        (> (right-naname-minus-check board i j b/w) 0)))
	(left-naname-plus-check?   (and (left-naname-plus-check   board i j b/w)
				        (> (left-naname-plus-check   board i j b/w) 0)))
	(left-naname-minus-check?  (and (left-naname-minus-check  board i j b/w)
				        (> (left-naname-minus-check  board i j b/w) 0))))
    
    (if h-line-plus-check?  (h-line-plus-reverse! board i j b/w))
    (if h-line-minus-check? (h-line-minus-reverse! board i j b/w))
    (if v-line-plus-check?  (v-line-plus-reverse! board i j b/w))
    (if v-line-minus-check? (v-line-minus-reverse! board i j b/w))
    (if right-naname-plus-check?  (right-naname-plus-reverse! board i j b/w))
    (if right-naname-minus-check? (right-naname-minus-reverse! board i j b/w))
    (if left-naname-plus-check?   (left-naname-plus-reverse! board i j b/w))
    (if left-naname-minus-check?  (left-naname-minus-reverse! board i j b/w))

    (if (and
	 (zerop (aref board i j))
	 (or h-line-plus-check?       h-line-minus-check?
	     v-line-plus-check?       v-line-minus-check?
	     right-naname-plus-check? right-naname-minus-check? 
	     left-naname-plus-check?  left-naname-minus-check?  ))
	(progn (setf (aref board i j) b/w)
	       b/w)
	nil)))

(defun put-able? (board i j b/w)
  (let ((h-line-plus-check?        (and (h-line-plus-check        board i j b/w)
				        (> (h-line-plus-check        board i j b/w) 0)))
	(h-line-minus-check?       (and (h-line-minus-check       board i j b/w)
				        (> (h-line-minus-check       board i j b/w) 0)))
	(v-line-plus-check?        (and (v-line-plus-check        board i j b/w)
				        (> (v-line-plus-check        board i j b/w) 0)))
	(v-line-minus-check?       (and (v-line-minus-check       board i j b/w)
				        (> (v-line-minus-check       board i j b/w) 0)))
	(right-naname-plus-check?  (and (right-naname-plus-check  board i j b/w)
				        (> (right-naname-plus-check  board i j b/w) 0)))
	(right-naname-minus-check? (and (right-naname-minus-check board i j b/w)
				        (> (right-naname-minus-check board i j b/w) 0)))
	(left-naname-plus-check?   (and (left-naname-plus-check   board i j b/w)
				        (> (left-naname-plus-check   board i j b/w) 0)))
	(left-naname-minus-check?  (and (left-naname-minus-check  board i j b/w)
				        (> (left-naname-minus-check  board i j b/w) 0))))
    
    (and
     (zerop (aref board i j))
     (or h-line-plus-check?       h-line-minus-check?
	 v-line-plus-check?       v-line-minus-check?
	 right-naname-plus-check? right-naname-minus-check? 
	 left-naname-plus-check?  left-naname-minus-check?  ))))

(defun print-board (board)
  (format t "   ")
  (loop for j from 0 below (array-dimension board 1) do
    (format t "~A " j))
  (format t "~%~%")

  (loop for i from 0 below (array-dimension board 0) do
    (format t "~A  " i)
    (loop for j from 0 below (array-dimension board 1) do
      (format t "~A " (aref board i j)))
    (format t "~%")))

(defun create-board (canvas board margin-size cell-size stone-color)
  (loop for i from 0 below (array-dimension board 0) do
    (loop for j from 0 below (array-dimension board 1) do
      (if (put-able? board i j stone-color)
	  (itemconfigure
	   canvas
	   (create-rectangle canvas
			     (+ margin-size (* j cell-size))
			     (+ margin-size (* i cell-size))
			     (+ margin-size (* j cell-size) cell-size)
			     (+ margin-size (* i cell-size) cell-size))
	   "fill" "#008000")
	  (itemconfigure
	   canvas
	   (create-rectangle canvas
			     (+ margin-size (* j cell-size))
			     (+ margin-size (* i cell-size))
			     (+ margin-size (* j cell-size) cell-size)
			     (+ margin-size (* i cell-size) cell-size))
	   "fill" "dark green")))))

(defun reflect-board (canvas board margin-size cell-size)
  (loop for i from 0 below (array-dimension board 0) do
    (loop for j from 0 below (array-dimension board 1) do
      (cond ((= (aref board i j) +black+)
	     (itemconfigure
	      canvas
	      (create-oval canvas
			   (+ margin-size (* j cell-size) (/ (- cell-size (* cell-size 0.8)) 2))
			   (+ margin-size (* i cell-size) (/ (- cell-size (* cell-size 0.8)) 2))
			   (+ margin-size (* j cell-size)
			      (- cell-size (/ (- cell-size (* cell-size 0.8)) 2)))
			   (+ margin-size (* i cell-size)
			      (- cell-size (/ (- cell-size (* cell-size 0.8)) 2))))
	      "fill" "black"))
	    ((= (aref board i j) +white+)
	     (itemconfigure
	      canvas
	      (create-oval canvas
			   (+ margin-size (* j cell-size) (/ (- cell-size (* cell-size 0.8)) 2))
			   (+ margin-size (* i cell-size) (/ (- cell-size (* cell-size 0.8)) 2))
			   (+ margin-size (* j cell-size)
			      (- cell-size (/ (- cell-size (* cell-size 0.8)) 2)))
			   (+ margin-size (* i cell-size)
			      (- cell-size (/ (- cell-size (* cell-size 0.8)) 2))))
	      "fill" "white"))))))

(defun display-board (board)
  (with-ltk ()
    (let* ((board-frame (make-instance 'frame))
	   (canvas (make-canvas board-frame
				:width  (+ (* (array-dimension board 1) cell-size)
					   (* 2 margin-size))
				:height (+ (* (array-dimension board 0) cell-size)
					   (* 2 margin-size))))	   
	   (stone-color +black+)
	   (button-frame (make-instance 'frame))
	   (tb (make-text button-frame :width nil :height 2))
	   (back-b (make-instance 'button
				  :master button-frame
				  :text "Back"
				  :command
				  (lambda ()
				    (when *board-stack-back*
				      (push (copy-array board) *board-stack-forward*)
				      (setf board (pop *board-stack-back*))
				      (clear-text tb)
				      (if (= stone-color +black+)
					  (append-text tb (format nil "WHITE's turn~%"))
					  (append-text tb (format nil "BLACK's turn~%")))
				      (if (= stone-color +black+)
				    	  (setf stone-color +white+)
				    	  (setf stone-color +black+))
				      (clear canvas)
				      (create-board canvas board margin-size cell-size stone-color)
				      (reflect-board canvas board margin-size cell-size))
				    )))
	   (forward-b (make-instance 'button
				     :master button-frame
				     :text "Forward"
				     :command
				     (lambda ()
				       (when *board-stack-forward*
				         (push (copy-array board) *board-stack-back*)
				         (setf board (pop *board-stack-forward*))
				         (clear-text tb)
				         (if (= stone-color +black+)
					     (append-text tb (format nil "WHITE's turn~%"))
					     (append-text tb (format nil "BLACK's turn~%")))
				         (if (= stone-color +black+)
				    	     (setf stone-color +white+)
				    	     (setf stone-color +black+))
				         (clear canvas)
				         (create-board canvas board margin-size cell-size stone-color)
				         (reflect-board canvas board margin-size cell-size))
				       )))
	   (pass-b (make-instance 'button
				  :master button-frame
				  :text "Pass"
				  :command
				  (lambda ()
				    (push (copy-array board) *board-stack-back*)
				    (setf *board-stack-forward* nil)
				    (clear-text tb)
				    (if (= stone-color +black+)
					(append-text tb (format nil "WHITE's turn~%"))
					(append-text tb (format nil "BLACK's turn~%")))
				    (if (= stone-color +black+)
					(setf stone-color +white+)
					(setf stone-color +black+))
				    (clear canvas)
				    (create-board canvas board margin-size cell-size stone-color)
				    (reflect-board canvas board margin-size cell-size)))))
      (pack board-frame)
      (pack canvas :side :left)      
      (pack button-frame)
      (pack tb :side :left)
      (pack back-b :side :left)
      (pack forward-b :side :left)
      (pack pass-b :side :left)
      
      (create-board canvas board margin-size cell-size stone-color)
      (reflect-board canvas board margin-size cell-size)
      (append-text tb (format nil "BLACK's turn~%"))
      (append-text tb (format nil "BLACK: 2 WHITE: 2"))
      
      (bind canvas "<ButtonPress-1>"
      	    (lambda (evt)	      
	      (let ((i (truncate (- (event-y evt) margin-size) cell-size))
		    (j (truncate (- (event-x evt) margin-size) cell-size)))

		(push (copy-array board) *board-stack-back*)
		(setf *board-stack-forward* nil)
		
		(when (put-stone! board i j stone-color)
		  ;; (print-board board) ;debug
		  (clear canvas)
		  (create-board canvas board margin-size cell-size
				(if (= stone-color +black+) +white+ +black+))
		  (reflect-board canvas board margin-size cell-size)
		  
		  (let ((b-cnt 0) (w-cnt 0))
		    (loop for i from 0 below (array-dimension board 0) do
		      (loop for j from 0 below (array-dimension board 1) do
			(cond ((= (aref board i j) +black+) (incf b-cnt))
			      ((= (aref board i j) +white+) (incf w-cnt)))))
		    ;; display text box
		    (clear-text tb)
		    (if (= stone-color +black+)
			(append-text tb (format nil "WHITE's turn~%"))
			(append-text tb (format nil "BLACK's turn~%")))
		    (append-text tb (format nil "BLACK: ~A WHITE: ~A" b-cnt w-cnt))

		    ;; change stone-color
		    (if (= stone-color +black+)
			(setf stone-color +white+)
			(setf stone-color +black+))))))))))

(defun reversi-board ()
  (init-board! *board*)
  (display-board *board*))