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.2 2002/10/25 09:23:39 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)
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 (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))
348 (if (plusp (final-result game))
349 (format stream "Black wins by ~d!" (final-result game))
350 (format stream "White wins by ~d!" (- 0 (final-result game)))))))))
354 (defmethod add-debug ((reversi reversi) msg)
355 (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
357 (defmethod set-msgbar ((reversi reversi) msg)
358 (setf (msgbar-string reversi) msg))
360 (defmethod draw-debug-window ((reversi reversi) stream &key max-width max-height)
361 (declare (ignore max-width max-height))
362 (filling-output (stream)
363 (dolist (msg (debug-messages reversi))
367 (defmethod draw-msgbar ((reversi reversi) stream &key max-width max-height)
368 (declare (ignore max-width max-height))
369 (when (msgbar-string reversi)
370 (princ (msgbar-string reversi) stream)))
373 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
374 (declare (ignore max-width max-height))
375 (let ((game (reversi-game reversi)))
376 (when (and game (> (move-number game) 1))
377 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 1)
378 (dotimes (i (1- (move-number game)))
379 (let ((state (aref (moves game) i)))
381 (let ((str (format nil "~2d: ~5a ~2a"
382 (1+ i) (title-of (state-player state))
383 (88->h8 (state-move state)))))
384 (updating-output (stream :unique-id i :cache-value str)
385 (with-end-of-page-action (stream :scroll)
386 (formatting-cell (stream :align-x :right :align-y :top)
388 (terpri stream))))))))))))
391 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
392 (declare (ignore max-width max-height))
393 (let ((game (reversi-game reversi)))
394 (when (and game (> (move-number game) 1))
395 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 2)
396 (dotimes (i (1- (move-number game)))
397 (let ((state (aref (moves game) i)))
399 (let ((str (format nil "~2d: ~5a ~2a"
400 (1+ i) (title-of (state-player state))
401 (88->h8 (state-move state)))))
402 (updating-output (stream :unique-id i :cache-value str)
403 (with-end-of-page-action (stream :scroll)
404 (formatting-cell (stream :align-x :right :align-y :top)
406 (terpri stream))))))))))))
410 (let ((viewport (window-viewport stream)))
411 (multiple-value-bind (x y) (stream-cursor-position stream)
412 (add-debug reversi (format nil "~d ~d: ~s" x y viewport))
413 (if (> y (bounding-rectangle-bottom viewport))
414 (decf y (bounding-rectangle-bottom viewport)))
415 (window-set-viewport-position stream 0 0))))))
421 (defvar *reversi-frame* nil)
423 (eval-when (:compile-toplevel :load-toplevel :execute)
424 (defparameter *force*
425 #+(and os-threads microsoft-32)
427 #-(and os-threads microsoft-32)
434 (unless (or *force* (null *reversi-frame*))
435 (setq *reversi-frame* (make-application-frame 'reversi)))
436 (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
439 (defun run-frame (frame-name frame)
441 (when (or *force* (null frame))
442 (setq frame (make-application-frame frame-name)))
443 (run-frame-top-level frame)))
445 (mp:process-run-function (write-to-string frame-name) #'do-it)
451 (define-command-table reversi-game-table
452 :menu (("New" :command com-reversi-new)
453 ("Backup" :command (com-reversi-backup))
454 ("Exit" :command (com-reversi-exit))))
456 (define-command-table reversi-help-table)
459 (define-command (com-reversi-new :name "New Game"
460 :command-table reversi-game-table
461 :keystroke (:n :control)
464 :documentation "New Game"))
466 (with-application-frame (frame)
467 (new-game-gui frame)))
469 (define-command (com-reversi-recommend :name "Recommend Move"
470 :command-table reversi-game-table
471 :keystroke (:r :control)
472 :menu ("Recommend Move"
474 :documentation "Recommend Move"))
476 (with-application-frame (frame)
477 (let ((game (reversi-game frame))
478 (player (current-gui-player frame)))
479 (when (and game player)
480 (when (gui-player-human? player)
481 (let* ((port (find-port))
482 (pointer (port-pointer port)))
484 (setf (pointer-cursor pointer) :busy))
485 (set-msgbar frame "Thinking...")
486 (let ((move (funcall (iago 8) (gui-player-id player)
489 (setf (pointer-cursor pointer) :default))
492 (format nil "Recommend move to ~a"
493 (symbol-name (88->h8 move))))))))))))
495 (define-command (com-reversi-backup :name "Backup Move"
496 :command-table reversi-game-table
497 :keystroke (:b :control)
499 :after "Recommend Move"
500 :documentation "Backup Move"))
502 (with-application-frame (frame)
503 (let ((game (reversi-game frame)))
504 (when (and game (> (move-number game) 2))
505 (reset-game game (- (move-number game) 2))))))
508 (define-command (com-reversi-exit :name "Exit"
509 :command-table reversi-game-table
510 :keystroke (:q :control)
513 :documentation "Quit application"))
515 (clim:frame-exit clim:*application-frame*))
518 (define-command (com-reversi-options :name "Game Options"
519 :command-table reversi-game-table
520 :menu ("Game Options" :documentation "Game Options"))
522 (with-application-frame (frame)
523 (game-dialog frame)))
527 ;(define-command-table reversi-game
528 ; :inherit-from (reversi-game-table)
531 ;(define-command-table reversi-help)
532 ; :inherit-from (reversi-help-commands)
535 (define-command (com-about :command-table reversi-help-table
539 :documentation "About Reversi"))
542 ;; (acl-clim::pop-up-about-climap-dialog *application-frame*))
546 (defun make-move-gui (game move player)
547 (make-game-move game move player))
549 (defun get-move-gui (frame)
550 (let ((gui-player (current-gui-player frame)))
552 (if (gui-player-human? gui-player)
553 (setf (gui-player-start-time gui-player) (get-internal-real-time))
554 (computer-move gui-player frame)))))
556 (defun computer-move (gui-player frame)
557 (let* ((game (reversi-game frame))
559 (pointer (port-pointer port)))
560 (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
562 (setf (pointer-cursor pointer) :busy))
563 (set-msgbar frame "Thinking...")
564 (while (eq gui-player (current-gui-player frame))
565 (setf (gui-player-start-time gui-player)
566 (get-internal-real-time))
567 (let ((move (funcall (gui-player-strategy gui-player)
569 (replace-board *board* (board game)))))
570 (when (and move (legal-p move (player game) (board game)))
571 (decf (elt (clock game) (player game))
572 (- (get-internal-real-time)
573 (gui-player-start-time gui-player)))
574 (make-move-gui game move (player game))
576 (next-to-play (board game) (player game))))))
577 (set-msgbar frame nil)
579 (setf (pointer-cursor pointer) :default)))
580 (setq gui-player (current-gui-player frame))
582 (if (and gui-player (not (gui-player-human? gui-player)))
583 (redisplay-frame-pane frame (get-frame-pane frame 'board)))
584 (get-move-gui frame))
589 (defun game-dialog (frame)
590 (let* ((stream (get-frame-pane frame 'debug-window))
591 ;; (white-strategy-id (white-strategy-id frame)
592 ;; (black-strategy-id (black-strategy-id frame))
593 (wh (white-player frame))
594 (bl (black-player frame))
595 (white-searcher (gui-player-searcher-id wh))
596 (white-evaluator (gui-player-eval-id wh))
597 (white-ply (gui-player-ply wh))
598 (black-searcher (gui-player-searcher-id bl))
599 (black-evaluator (gui-player-eval-id bl))
600 (black-ply (gui-player-ply bl))
601 (minutes (minutes frame)))
603 (accepting-values (stream :own-window t
604 :label "Reversi Parameters")
608 :prompt "Maximum minutes" :default minutes))
610 (format stream "White Player~%")
612 (accept '(member :human :random :minimax :alpha-beta3)
614 :prompt "White Player Search" :default white-searcher))
616 (setq white-evaluator
617 (accept '(member :difference :weighted :modified-weighted :iago)
619 :prompt "White Player Evaluator" :default white-evaluator))
624 :prompt "White Ply" :default white-ply))
627 (format stream "Black Player~%")
630 (accept '(member :human :random :minimax :alpha-beta3)
632 :prompt "Black Player Search" :default black-searcher))
634 (setq black-evaluator
635 (accept '(member :difference :weighted :modified-weighted :iago)
637 :prompt "Black Player Evaluator" :default black-evaluator))
642 :prompt "Black Ply" :default black-ply))
645 (setf (minutes frame) minutes)
646 (setf (white-player frame) (make-gui-player :id white
647 :searcher-id white-searcher
648 :eval-id white-evaluator
650 (setf (black-player frame) (make-gui-player :id black
651 :searcher-id black-searcher
652 :eval-id black-evaluator
657 (defmethod draw-board ((reversi reversi) stream &key max-width max-height)
658 "This should produce a checkerboard pattern."
659 (declare (ignore max-width max-height))
660 (let ((game (reversi-game reversi)))
665 (+ label-width (* cell-width i)
666 half-cell-inner-width)
668 :align-x :center :align-y :top))
671 (format nil "~d" (1+ i))
674 (+ label-height (* cell-height i)
675 half-cell-inner-height))
676 :align-x :left :align-y :center))
677 (stream-set-cursor-position stream label-width label-height)
678 (surrounding-output-with-border (stream)
679 (formatting-table (stream :y-spacing 0 :x-spacing 0)
681 (formatting-row (stream)
683 (let* ((cell-id (square-number row column))
686 (bref (board game) cell-id)
688 (updating-output (stream :unique-id cell-id
690 (formatting-cell (stream :align-x :right :align-y :top)
691 (with-output-as-presentation (stream cell-id 'reversi-cell)
692 (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
693 (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
698 half-cell-inner-width
699 half-cell-inner-height
700 piece-radius :filled t :ink +black+))
704 half-cell-inner-width
705 half-cell-inner-height
706 piece-radius :filled t :ink +white+))))))))))))))