1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: reversi -*-
2 ;;;;***************************************************************************
4 ;;;; FILE IDENTIFICATION
6 ;;;; Name: io-clim.lisp
7 ;;;; Purpose: CLIM GUI for reversi
8 ;;;; Programer: Kevin M. Rosenberg
9 ;;;; Date Started: 1 Nov 2001
11 ;;;; $Id: io-clim.lisp,v 1.9 2003/04/03 16:29:52 kevin Exp $
13 ;;;; This file is Copyright (c) 2001-2002 by Kevin M. Rosenberg
15 ;;;; Reversi users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
18 ;;;;***************************************************************************
22 (defparameter cell-inner-width 40)
23 (defparameter cell-inner-height 40)
24 (defparameter half-cell-inner-width 20)
25 (defparameter half-cell-inner-height 20)
26 (defparameter line-thickness 2)
27 (defparameter piece-radius 16)
28 (defparameter cell-width (+ line-thickness cell-inner-width))
29 (defparameter cell-height (+ line-thickness cell-inner-height))
30 (defparameter label-height 42)
31 (defparameter label-width 42)
33 (defparameter board-width (+ 30 (* 8 cell-width)))
34 (defparameter board-height (+ 30 (* 8 cell-height)))
36 (defparameter status-width 300)
39 (defstruct (gui-player (:constructor make-gui-player-struct))
40 id name searcher eval ply strategy start-time
43 (defun make-gui-player (&key id name strategy searcher-id eval-id (ply 0))
44 (let ((p (make-gui-player-struct :id id :ply ply
45 :name name :strategy strategy
46 :searcher-id searcher-id :eval-id eval-id))
49 ((eq searcher-id :human)
51 ((eq searcher-id :minimax)
53 ((eq searcher-id :alpha-beta)
54 #'alpha-beta-searcher)
55 ((eq searcher-id :alpha-beta2)
56 #'alpha-beta-searcher2)
57 ((eq searcher-id :alpha-beta3)
58 #'alpha-beta-searcher3)
59 ((eq searcher-id :random)
63 ((eq eval-id :difference)
65 ((eq eval-id :weighted)
67 ((eq eval-id :modified-weighted)
68 #'modified-weighted-squares)
73 ((eq search-func #'human)
75 ((eq search-func #'random-strategy)
76 (setf (gui-player-strategy p) search-func))
78 (setf (gui-player-strategy p)
79 (funcall search-func ply eval-func)))))
83 (defun gui-player-human? (gp)
84 (eql (gui-player-searcher-id gp) :human))
86 (defun current-gui-player (frame)
88 (aif (reversi-game frame)
92 ((= (player it) black)
94 ((= (player it) white)
101 (defun current-gui-player-human? (frame)
103 (aif (current-gui-player frame)
104 (gui-player-human? it)
106 (gui-player-human? (current-gui-player frame))
109 (define-application-frame reversi ()
111 :accessor reversi-game)
112 (minutes :initform 30
114 (black-player :initform nil
115 :accessor black-player)
116 (white-player :initform nil
117 :accessor white-player)
118 (debug-messages :initform nil
119 :accessor debug-messages)
120 (msgbar-string :initform nil
121 :accessor msgbar-string)
122 (human-time-start :initform nil
123 :accessor reversi-human-time-start))
126 :display-function 'draw-board
127 :text-style '(:sans-serif :bold :very-large)
128 ;; :incremental-redisplay t
133 :width (+ label-width board-width)
134 :height (+ label-height board-height)
135 :min-width board-width
136 :min-height board-height
141 :display-function 'draw-status
142 :text-style '(:sans-serif :bold :large)
143 :incremental-redisplay t
151 (history :application
152 :display-function 'draw-history
153 :text-style '(:fix :roman :normal)
154 :incremental-redisplay t
160 :initial-cursor-visibility :on
161 :scroll-bars :vertical
164 :end-of-page-action :scroll
165 :end-of-line-action :scroll)
166 (debug-window :application
167 :display-function 'draw-debug-window
168 :text-style '(:serif :roman :normal)
169 :incremental-redisplay t
174 :scroll-bars :vertical
177 :end-of-page-action :scroll
178 :end-of-line-action :scroll
181 :display-function 'draw-msgbar
182 :text-style '(:sans-serif :roman :normal)
183 :incremental-redisplay t
185 :background (make-rgb-color 0.75 0.75 0.75)
192 :end-of-page-action :scroll
193 :end-of-line-action :scroll))
194 (:pointer-documentation nil)
195 (:command-table (reversi
196 :inherit-from (user-command-table
200 :menu reversi-game-table
202 :documentation "Game commands")
204 :menu reversi-help-table
206 :documentation "Help Commands"))))
222 (defmethod frame-standard-input ((reversi reversi))
223 (get-frame-pane reversi 'debug-window))
225 (defmethod frame-standard-output ((reversi reversi))
226 (get-frame-pane reversi 'debug-window))
228 (defmethod run-frame-top-level :before ((reversi reversi) &key)
229 (initialize-reversi reversi))
232 (defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
233 (let ((abort-chars #+Genera '(#\Abort #\End)
235 (let ((command (read-command-using-keystrokes
236 (frame-command-table reversi) abort-chars
238 (if (characterp command)
242 (define-presentation-type reversi-cell ()
243 :inherit-from '(integer 11 88))
246 (define-presentation-method highlight-presentation ((type reversi-cell)
249 (multiple-value-bind (xoff yoff)
250 (clim::convert-from-relative-to-absolute-coordinates
251 stream (output-record-parent record))
252 (with-bounding-rectangle* (left top right bottom) record
253 (draw-rectangle* stream
254 (+ left xoff) (+ top yoff)
255 (+ right xoff) (+ bottom yoff)
256 :ink +flipping-ink+))))
258 (define-reversi-command com-select-cell ((move 'reversi-cell))
259 (with-application-frame (frame)
260 (with-slots (game) frame
261 (let ((gui-player (current-gui-player frame)))
262 (when (and game gui-player (gui-player-human? gui-player))
263 (if (not (legal-p move (gui-player-id gui-player) (board game)))
265 (format nil "Illegal move: ~a"
266 (symbol-name (88->h8 move))))
268 (decf (elt (clock game) (player game))
269 (- (get-internal-real-time) (gui-player-start-time gui-player)))
270 (make-move-gui game move (gui-player-id gui-player))
271 (setf (player game) (next-to-play (board game) (player game)))
272 (get-move-gui frame))))))))
275 (define-presentation-to-command-translator select-cell
276 (reversi-cell com-select-cell reversi
277 :documentation "Select cell"
278 :tester ((object frame window) (cell-selectable-p object frame window)))
282 (defun cell-selectable-p (object frame window)
283 (when (and (eq (get-frame-pane frame 'board) window)
284 (reversi-game frame))
285 (let ((game (reversi-game frame)))
286 (if (legal-p object (player game) (board game))
292 (defun new-game-gui (frame)
293 (setf (reversi-game frame)
295 (gui-player-strategy (black-player frame))
296 (gui-player-strategy (white-player frame))
299 :minutes (minutes frame)))
300 (set-msgbar frame "New Game")
301 (get-move-gui frame))
305 (defmethod initialize-reversi ((reversi reversi))
306 (setf (black-player reversi)
307 (make-gui-player :id black :searcher-id :human)
309 (setf (white-player reversi)
310 (make-gui-player :id white
311 :searcher-id :alpha-beta3
316 (defun square-number (row column)
317 (declare (fixnum row column))
321 (defmethod draw-status ((reversi reversi) stream &key max-width max-height)
322 (declare (ignore max-width max-height))
323 (let ((game (reversi-game reversi)))
325 (if (null (player game))
327 (setf (final-result game) (count-difference black (board game)))
328 (format stream "Game Over~2%"))
329 (format stream "Move Number ~d~2%" (move-number game)))
330 (format stream "Pieces~% ~a ~2d~% ~a ~2d~% Difference ~2d~2&"
331 (title-of black) (count black (board game))
332 (title-of white) (count white (board game))
333 (count-difference black (board game)))
335 (format stream "Time Remaining~% ~a ~a~% ~a ~a~2%"
336 (title-of black) (time-string (elt (clock game) black))
337 (title-of white) (time-string (elt (clock game) white))))
338 (let ((gui-player (current-gui-player reversi)))
339 (when (and gui-player (gui-player-human? gui-player))
341 (loop for move in (legal-moves (gui-player-id gui-player)
343 collect (symbol-name (88->h8 move)))))
345 (format stream "Valid Moves~%~A"
346 (list-to-delimited-string legal-moves #\space)))))
347 (when (null (player game))
349 ((zerop (final-result games))
350 (format stream "It's a draw!"))
351 ((plusp (final-result game))
352 (format stream "Black wins by ~d!" (final-result game)))
354 (format stream "White wins by ~d!" (- 0 (final-result game))))))))))
358 (defmethod add-debug ((reversi reversi) msg)
359 (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
361 (defmethod set-msgbar ((reversi reversi) msg)
362 (setf (msgbar-string reversi) msg))
364 (defmethod draw-debug-window ((reversi reversi) stream &key max-width max-height)
365 (declare (ignore max-width max-height))
366 (filling-output (stream)
367 (dolist (msg (debug-messages reversi))
371 (defmethod draw-msgbar ((reversi reversi) stream &key max-width max-height)
372 (declare (ignore max-width max-height))
373 (when (msgbar-string reversi)
374 (princ (msgbar-string reversi) stream)))
377 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
378 (declare (ignore max-width max-height))
379 (let ((game (reversi-game reversi)))
380 (when (and game (> (move-number game) 1))
381 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 1)
382 (dotimes (i (1- (move-number game)))
383 (let ((state (aref (moves game) i)))
385 (let ((str (format nil "~2d: ~5a ~2a"
386 (1+ i) (title-of (state-player state))
387 (88->h8 (state-move state)))))
388 (updating-output (stream :unique-id i :cache-value str)
389 (with-end-of-page-action (stream :scroll)
390 (formatting-cell (stream :align-x :right :align-y :top)
392 (terpri stream))))))))))))
395 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
396 (declare (ignore max-width max-height))
397 (let ((game (reversi-game reversi)))
398 (when (and game (> (move-number game) 1))
399 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 2)
400 (dotimes (i (1- (move-number game)))
401 (let ((state (aref (moves game) i)))
403 (let ((str (format nil "~2d: ~5a ~2a"
404 (1+ i) (title-of (state-player state))
405 (88->h8 (state-move state)))))
406 (updating-output (stream :unique-id i :cache-value str)
407 (with-end-of-page-action (stream :scroll)
408 (formatting-cell (stream :align-x :right :align-y :top)
410 (terpri stream))))))))))))
414 (let ((viewport (window-viewport stream)))
415 (multiple-value-bind (x y) (stream-cursor-position stream)
416 (add-debug reversi (format nil "~d ~d: ~s" x y viewport))
417 (if (> y (bounding-rectangle-bottom viewport))
418 (decf y (bounding-rectangle-bottom viewport)))
419 (window-set-viewport-position stream 0 0))))))
425 (defvar *reversi-frame* nil)
427 (eval-when (:compile-toplevel :load-toplevel :execute)
428 (defparameter *force*
429 #+(and os-threads microsoft-32)
431 #-(and os-threads microsoft-32)
434 (defun clim-reversi ()
435 (unless (or *force* (null *reversi-frame*))
436 (setq *reversi-frame* (make-application-frame 'reversi)))
437 (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
440 (defun run-frame (frame-name frame)
442 (when (or *force* (null frame))
443 (setq frame (make-application-frame frame-name)))
444 (run-frame-top-level frame)))
446 (mp:process-run-function (write-to-string frame-name) #'do-it)
452 (define-command-table reversi-game-table
453 :menu (("New" :command com-reversi-new)
454 ("Backup" :command (com-reversi-backup))
455 ("Exit" :command (com-reversi-exit))))
457 (define-command-table reversi-help-table)
460 (define-command (com-reversi-new :name "New Game"
461 :command-table reversi-game-table
462 :keystroke (:n :control)
465 :documentation "New Game"))
467 (with-application-frame (frame)
468 (new-game-gui frame)))
470 (define-command (com-reversi-recommend :name "Recommend Move"
471 :command-table reversi-game-table
472 :keystroke (:r :control)
473 :menu ("Recommend Move"
475 :documentation "Recommend Move"))
477 (with-application-frame (frame)
478 (let ((game (reversi-game frame))
479 (player (current-gui-player frame)))
480 (when (and game player)
481 (when (gui-player-human? player)
482 (let* ((port (find-port))
483 (pointer (port-pointer port)))
485 (setf (pointer-cursor pointer) :busy))
486 (set-msgbar frame "Thinking...")
487 (let ((move (funcall (iago 8) (gui-player-id player)
490 (setf (pointer-cursor pointer) :default))
493 (format nil "Recommend move to ~a"
494 (symbol-name (88->h8 move))))))))))))
496 (define-command (com-reversi-backup :name "Backup Move"
497 :command-table reversi-game-table
498 :keystroke (:b :control)
500 :after "Recommend Move"
501 :documentation "Backup Move"))
503 (with-application-frame (frame)
504 (let ((game (reversi-game frame)))
505 (when (and game (> (move-number game) 2))
506 (reset-game game (- (move-number game) 2))))))
509 (define-command (com-reversi-exit :name "Exit"
510 :command-table reversi-game-table
511 :keystroke (:q :control)
514 :documentation "Quit application"))
516 (clim:frame-exit clim:*application-frame*))
519 (define-command (com-reversi-options :name "Game Options"
520 :command-table reversi-game-table
521 :menu ("Game Options" :documentation "Game Options"))
523 (with-application-frame (frame)
524 (game-dialog frame)))
528 ;(define-command-table reversi-game
529 ; :inherit-from (reversi-game-table)
532 ;(define-command-table reversi-help)
533 ; :inherit-from (reversi-help-commands)
536 (define-command (com-about :command-table reversi-help-table
540 :documentation "About Reversi"))
543 ;; (acl-clim::pop-up-about-climap-dialog *application-frame*))
547 (defun make-move-gui (game move player)
548 (make-game-move game move player))
550 (defun get-move-gui (frame)
551 (let ((gui-player (current-gui-player frame)))
553 (if (gui-player-human? gui-player)
554 (setf (gui-player-start-time gui-player) (get-internal-real-time))
555 (computer-move gui-player frame)))))
557 (defun computer-move (gui-player frame)
558 (let* ((game (reversi-game frame))
560 (pointer (port-pointer port)))
561 (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
563 (setf (pointer-cursor pointer) :busy))
564 (set-msgbar frame "Thinking...")
565 (while (eq gui-player (current-gui-player frame))
566 (setf (gui-player-start-time gui-player)
567 (get-internal-real-time))
568 (let ((move (funcall (gui-player-strategy gui-player)
570 (replace-board *board* (board game)))))
571 (when (and move (legal-p move (player game) (board game)))
572 (decf (elt (clock game) (player game))
573 (- (get-internal-real-time)
574 (gui-player-start-time gui-player)))
575 (make-move-gui game move (player game))
577 (next-to-play (board game) (player game))))))
578 (set-msgbar frame nil)
580 (setf (pointer-cursor pointer) :default)))
581 (setq gui-player (current-gui-player frame))
583 (if (and gui-player (not (gui-player-human? gui-player)))
584 (redisplay-frame-pane frame (get-frame-pane frame 'board)))
585 (get-move-gui frame))
590 (defun game-dialog (frame)
591 (let* ((stream (get-frame-pane frame 'debug-window))
592 ;; (white-strategy-id (white-strategy-id frame)
593 ;; (black-strategy-id (black-strategy-id frame))
594 (wh (white-player frame))
595 (bl (black-player frame))
596 (white-searcher (gui-player-searcher-id wh))
597 (white-evaluator (gui-player-eval-id wh))
598 (white-ply (gui-player-ply wh))
599 (black-searcher (gui-player-searcher-id bl))
600 (black-evaluator (gui-player-eval-id bl))
601 (black-ply (gui-player-ply bl))
602 (minutes (minutes frame)))
604 (accepting-values (stream :own-window t
605 :label "Reversi Parameters")
609 :prompt "Maximum minutes" :default minutes))
611 (format stream "White Player~%")
613 (accept '(member :human :random :minimax :alpha-beta3)
615 :prompt "White Player Search" :default white-searcher))
617 (setq white-evaluator
618 (accept '(member :difference :weighted :modified-weighted :iago)
620 :prompt "White Player Evaluator" :default white-evaluator))
625 :prompt "White Ply" :default white-ply))
628 (format stream "Black Player~%")
631 (accept '(member :human :random :minimax :alpha-beta3)
633 :prompt "Black Player Search" :default black-searcher))
635 (setq black-evaluator
636 (accept '(member :difference :weighted :modified-weighted :iago)
638 :prompt "Black Player Evaluator" :default black-evaluator))
643 :prompt "Black Ply" :default black-ply))
646 (setf (minutes frame) minutes)
647 (setf (white-player frame) (make-gui-player :id white
648 :searcher-id white-searcher
649 :eval-id white-evaluator
651 (setf (black-player frame) (make-gui-player :id black
652 :searcher-id black-searcher
653 :eval-id black-evaluator
658 (defmethod draw-board ((reversi reversi) stream &key max-width max-height)
659 "This should produce a checkerboard pattern."
660 (declare (ignore max-width max-height))
661 (let ((game (reversi-game reversi)))
666 (+ label-width (* cell-width i)
667 half-cell-inner-width)
669 :align-x :center :align-y :top))
672 (format nil "~d" (1+ i))
675 (+ label-height (* cell-height i)
676 half-cell-inner-height))
677 :align-x :left :align-y :center))
678 (if (find-package 'mcclim)
679 (setf (stream-set-cursor-position stream)
680 (values label-width label-height))
681 (stream-set-cursor-position stream label-width label-height))
682 (surrounding-output-with-border (stream)
683 (formatting-table (stream :y-spacing 0 :x-spacing 0)
685 (formatting-row (stream)
687 (let* ((cell-id (square-number row column))
690 (bref (board game) cell-id)
692 (updating-output (stream :unique-id cell-id
694 (formatting-cell (stream :align-x :right :align-y :top)
695 (with-output-as-presentation (stream cell-id 'reversi-cell)
696 (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
697 (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
702 half-cell-inner-width
703 half-cell-inner-height
704 piece-radius :filled t :ink +black+))
708 half-cell-inner-width
709 half-cell-inner-height
710 piece-radius :filled t :ink +white+))))))))))))))