1 ;;;;***************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: CLIM GUI for reversi
7 ;;;; Programer: Kevin M. Rosenberg, M.D.
8 ;;;; Date Started: 1 Nov 2001
9 ;;;; CVS Id: $Id: io-clim.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
11 ;;;;***************************************************************************
15 (defparameter cell-inner-width 40)
16 (defparameter cell-inner-height 40)
17 (defparameter half-cell-inner-width 20)
18 (defparameter half-cell-inner-height 20)
19 (defparameter line-thickness 2)
20 (defparameter piece-radius 16)
21 (defparameter cell-width (+ line-thickness cell-inner-width))
22 (defparameter cell-height (+ line-thickness cell-inner-height))
23 (defparameter label-height 42)
24 (defparameter label-width 42)
26 (defparameter board-width (+ 30 (* 8 cell-width)))
27 (defparameter board-height (+ 30 (* 8 cell-height)))
29 (defparameter status-width 300)
32 (defstruct (gui-player (:constructor make-gui-player-struct))
33 id name searcher eval ply strategy start-time
36 (defun make-gui-player (&key id name strategy searcher-id eval-id ply)
37 (let ((p (make-gui-player-struct :id id :ply ply
38 :name name :strategy strategy
39 :searcher-id searcher-id :eval-id eval-id))
42 ((eq searcher-id :human)
44 ((eq searcher-id :minimax)
46 ((eq searcher-id :alpha-beta)
47 #'alpha-beta-searcher)
48 ((eq searcher-id :alpha-beta2)
49 #'alpha-beta-searcher2)
50 ((eq searcher-id :alpha-beta3)
51 #'alpha-beta-searcher3)
52 ((eq searcher-id :random)
56 ((eq eval-id :difference)
58 ((eq eval-id :weighted)
60 ((eq eval-id :modified-weighted)
61 #'modified-weighted-squares)
66 ((eq search-func #'human)
68 ((eq search-func #'random-strategy)
69 (setf (gui-player-strategy p) search-func))
71 (setf (gui-player-strategy p)
72 (funcall search-func ply eval-func)))))
76 (defun gui-player-human? (gp)
77 (eql (gui-player-searcher-id gp) :human))
79 (defun current-gui-player (frame)
81 (aif (reversi-game frame)
85 ((= (player it) black)
87 ((= (player it) white)
94 (defun current-gui-player-human? (frame)
96 (aif (current-gui-player frame)
97 (gui-player-human? it)
99 (gui-player-human? (current-gui-player frame))
102 (define-application-frame reversi ()
104 :accessor reversi-game)
105 (minutes :initform 30
107 (black-player :initform nil
108 :accessor black-player)
109 (white-player :initform nil
110 :accessor white-player)
111 (debug-messages :initform nil
112 :accessor debug-messages)
113 (msgbar-string :initform nil
114 :accessor msgbar-string)
115 (human-time-start :initform nil
116 :accessor reversi-human-time-start))
119 :display-function 'draw-board
120 :text-style '(:sans-serif :bold :very-large)
121 ;; :incremental-redisplay t
126 :width (+ label-width board-width)
127 :height (+ label-height board-height)
128 :min-width board-width
129 :min-height board-height
134 :display-function 'draw-status
135 :text-style '(:sans-serif :bold :large)
136 :incremental-redisplay t
144 (history :application
145 :display-function 'draw-history
146 :text-style '(:fix :roman :normal)
147 :incremental-redisplay t
153 :initial-cursor-visibility :on
154 :scroll-bars :vertical
157 :end-of-page-action :scroll
158 :end-of-line-action :scroll)
159 (debug-window :application
160 :display-function 'draw-debug-window
161 :text-style '(:serif :roman :normal)
162 :incremental-redisplay t
167 :scroll-bars :vertical
170 :end-of-page-action :scroll
171 :end-of-line-action :scroll
174 :display-function 'draw-msgbar
175 :text-style '(:sans-serif :roman :normal)
176 :incremental-redisplay t
178 :background (make-rgb-color 0.75 0.75 0.75)
185 :end-of-page-action :scroll
186 :end-of-line-action :scroll))
187 (:pointer-documentation nil)
188 (:command-table (reversi
189 :inherit-from (user-command-table
193 :menu reversi-game-table
195 :documentation "Game commands")
197 :menu reversi-help-table
199 :documentation "Help Commands"))))
215 (defmethod frame-standard-input ((reversi reversi))
216 (get-frame-pane reversi 'debug-window))
218 (defmethod frame-standard-output ((reversi reversi))
219 (get-frame-pane reversi 'debug-window))
221 (defmethod run-frame-top-level :before ((reversi reversi) &key)
222 (initialize-reversi reversi))
225 (defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
226 (let ((abort-chars #+Genera '(#\Abort #\End)
228 (let ((command (read-command-using-keystrokes
229 (frame-command-table reversi) abort-chars
231 (if (characterp command)
235 (define-presentation-type reversi-cell ()
236 :inherit-from '(integer 11 88))
239 (define-presentation-method highlight-presentation ((type reversi-cell)
242 (multiple-value-bind (xoff yoff)
243 (convert-from-relative-to-absolute-coordinates
244 stream (output-record-parent record))
245 (with-bounding-rectangle* (left top right bottom) record
246 (draw-rectangle* stream
247 (+ left xoff) (+ top yoff)
248 (+ right xoff) (+ bottom yoff)
249 :ink +flipping-ink+))))
251 (define-reversi-command com-select-cell ((move 'reversi-cell))
252 (with-application-frame (frame)
253 (with-slots (game) frame
254 (let ((gui-player (current-gui-player frame)))
255 (when (and game gui-player (gui-player-human? gui-player))
256 (if (not (legal-p move (gui-player-id gui-player) (board game)))
258 (format nil "Illegal move: ~a"
259 (symbol-name (88->h8 move))))
261 (decf (elt (clock game) (player game))
262 (- (get-internal-real-time) (gui-player-start-time gui-player)))
263 (make-move-gui game move (gui-player-id gui-player))
264 (setf (player game) (next-to-play (board game) (player game)))
265 (get-move-gui frame))))))))
268 (define-presentation-to-command-translator select-cell
269 (reversi-cell com-select-cell reversi
270 :documentation "Select cell"
271 :tester ((object frame window) (cell-selectable-p object frame window)))
275 (defun cell-selectable-p (object frame window)
276 (when (and (eq (get-frame-pane frame 'board) window)
277 (reversi-game frame))
278 (let ((game (reversi-game frame)))
279 (if (legal-p object (player game) (board game))
285 (defun new-game-gui (frame)
286 (setf (reversi-game frame)
288 (gui-player-strategy (black-player frame))
289 (gui-player-strategy (white-player frame))
292 :minutes (minutes frame)))
293 (set-msgbar frame "New Game")
294 (get-move-gui frame))
298 (defmethod initialize-reversi ((reversi reversi))
299 (setf (black-player reversi)
300 (make-gui-player :id black :searcher-id :human)
302 (setf (white-player reversi)
303 (make-gui-player :id white
304 :searcher-id :alpha-beta3
309 (defun square-number (row column)
310 (declare (fixnum row column))
314 (defmethod draw-status ((reversi reversi) stream &key max-width max-height)
315 (declare (ignore max-width max-height))
316 (let ((game (reversi-game reversi)))
318 (if (null (player game))
320 (setf (final-result game) (count-difference black (board game)))
321 (format stream "Game Over~2%"))
322 (format stream "Move Number ~d~2%" (move-number game)))
323 (format stream "Pieces~% ~a ~2d~% ~a ~2d~% Difference ~2d~2&"
324 (title-of black) (count black (board game))
325 (title-of white) (count white (board game))
326 (count-difference black (board game)))
328 (format stream "Time Remaining~% ~a ~a~% ~a ~a~2%"
329 (title-of black) (time-string (elt (clock game) black))
330 (title-of white) (time-string (elt (clock game) white))))
331 (let ((gui-player (current-gui-player reversi)))
332 (when (and gui-player (gui-player-human? gui-player))
334 (loop for move in (legal-moves (gui-player-id gui-player)
336 collect (symbol-name (88->h8 move)))))
338 (format stream "Valid Moves~%~A"
339 (list-to-delimited-string legal-moves #\space)))))
340 (when (null (player game))
341 (if (plusp (final-result game))
342 (format stream "Black wins by ~d!" (final-result game))
343 (format stream "White wins by ~d!" (- 0 (final-result game)))))))))
347 (defmethod add-debug ((reversi reversi) msg)
348 (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
350 (defmethod set-msgbar ((reversi reversi) msg)
351 (setf (msgbar-string reversi) msg))
353 (defmethod draw-debug-window ((reversi reversi) stream &key max-width max-height)
354 (declare (ignore max-width max-height))
355 (filling-output (stream)
356 (dolist (msg (debug-messages reversi))
360 (defmethod draw-msgbar ((reversi reversi) stream &key max-width max-height)
361 (declare (ignore max-width max-height))
362 (when (msgbar-string reversi)
363 (princ (msgbar-string reversi) stream)))
366 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
367 (declare (ignore max-width max-height))
368 (let ((game (reversi-game reversi)))
369 (when (and game (> (move-number game) 1))
370 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 1)
371 (dotimes (i (1- (move-number game)))
372 (let ((state (aref (moves game) i)))
374 (let ((str (format nil "~2d: ~5a ~2a"
375 (1+ i) (title-of (state-player state))
376 (88->h8 (state-move state)))))
377 (updating-output (stream :unique-id i :cache-value str)
378 (with-end-of-page-action (stream :scroll)
379 (formatting-cell (stream :align-x :right :align-y :top)
381 (terpri stream))))))))))))
384 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
385 (declare (ignore max-width max-height))
386 (let ((game (reversi-game reversi)))
387 (when (and game (> (move-number game) 1))
388 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 2)
389 (dotimes (i (1- (move-number game)))
390 (let ((state (aref (moves game) i)))
392 (let ((str (format nil "~2d: ~5a ~2a"
393 (1+ i) (title-of (state-player state))
394 (88->h8 (state-move state)))))
395 (updating-output (stream :unique-id i :cache-value str)
396 (with-end-of-page-action (stream :scroll)
397 (formatting-cell (stream :align-x :right :align-y :top)
399 (terpri stream))))))))))))
403 (let ((viewport (window-viewport stream)))
404 (multiple-value-bind (x y) (stream-cursor-position stream)
405 (add-debug reversi (format nil "~d ~d: ~s" x y viewport))
406 (if (> y (bounding-rectangle-bottom viewport))
407 (decf y (bounding-rectangle-bottom viewport)))
408 (window-set-viewport-position stream 0 0))))))
414 (defvar *reversi-frame* nil)
416 (eval-when (:compile-toplevel :load-toplevel :execute)
417 (defparameter *force*
418 #+(and os-threads microsoft-32)
420 #-(and os-threads microsoft-32)
427 (unless (or *force* (null *reversi-frame*))
428 (setq *reversi-frame* (make-application-frame 'reversi)))
429 (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
432 (defun run-frame (frame-name frame)
434 (when (or *force* (null frame))
435 (setq frame (make-application-frame frame-name)))
436 (run-frame-top-level frame)))
438 (mp:process-run-function (write-to-string frame-name) #'do-it)
444 (define-command-table reversi-game-table
445 :menu (("New" :command com-reversi-new)
446 ("Backup" :command (com-reversi-backup))
447 ("Exit" :command (com-reversi-exit))))
449 (define-command-table reversi-help-table)
452 (define-command (com-reversi-new :name "New Game"
453 :command-table reversi-game-table
454 :keystroke (:n :control)
457 :documentation "New Game"))
459 (with-application-frame (frame)
460 (new-game-gui frame)))
462 (define-command (com-reversi-recommend :name "Recommend Move"
463 :command-table reversi-game-table
464 :keystroke (:r :control)
465 :menu ("Recommend Move"
467 :documentation "Recommend Move"))
469 (with-application-frame (frame)
470 (let ((game (reversi-game frame))
471 (player (current-gui-player frame)))
472 (when (and game player)
473 (when (gui-player-human? player)
474 (let* ((port (find-port))
475 (pointer (port-pointer port)))
477 (setf (pointer-cursor pointer) :busy))
478 (set-msgbar frame "Thinking...")
479 (let ((move (funcall (iago 8) (gui-player-id player)
482 (setf (pointer-cursor pointer) :default))
485 (format nil "Recommend move to ~a"
486 (symbol-name (88->h8 move))))))))))))
488 (define-command (com-reversi-backup :name "Backup Move"
489 :command-table reversi-game-table
490 :keystroke (:b :control)
492 :after "Recommend Move"
493 :documentation "Backup Move"))
495 (with-application-frame (frame)
496 (let ((game (reversi-game frame)))
497 (when (and game (> (move-number game) 2))
498 (reset-game game (- (move-number game) 2))))))
501 (define-command (com-reversi-exit :name "Exit"
502 :command-table reversi-game-table
503 :keystroke (:q :control)
506 :documentation "Quit application"))
508 (clim:frame-exit clim:*application-frame*))
511 (define-command (com-reversi-options :name "Game Options"
512 :command-table reversi-game-table
513 :menu ("Game Options" :documentation "Game Options"))
515 (with-application-frame (frame)
516 (game-dialog frame)))
520 ;(define-command-table reversi-game
521 ; :inherit-from (reversi-game-table)
524 ;(define-command-table reversi-help)
525 ; :inherit-from (reversi-help-commands)
528 (define-command (com-about :command-table reversi-help-table
532 :documentation "About Reversi"))
535 ;; (acl-clim::pop-up-about-climap-dialog *application-frame*))
539 (defun make-move-gui (game move player)
540 (make-game-move game move player))
542 (defun get-move-gui (frame)
543 (let ((gui-player (current-gui-player frame)))
545 (if (gui-player-human? gui-player)
546 (setf (gui-player-start-time gui-player) (get-internal-real-time))
547 (computer-move gui-player frame)))))
549 (defun computer-move (gui-player frame)
550 (let* ((game (reversi-game frame))
552 (pointer (port-pointer port)))
553 (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
555 (setf (pointer-cursor pointer) :busy))
556 (set-msgbar frame "Thinking...")
557 (while (eq gui-player (current-gui-player frame))
558 (setf (gui-player-start-time gui-player)
559 (get-internal-real-time))
560 (let ((move (funcall (gui-player-strategy gui-player)
562 (replace-board *board* (board game)))))
563 (when (and move (legal-p move (player game) (board game)))
564 (decf (elt (clock game) (player game))
565 (- (get-internal-real-time)
566 (gui-player-start-time gui-player)))
567 (make-move-gui game move (player game))
569 (next-to-play (board game) (player game))))))
570 (set-msgbar frame nil)
572 (setf (pointer-cursor pointer) :default)))
573 (setq gui-player (current-gui-player frame))
575 (if (and gui-player (not (gui-player-human? gui-player)))
576 (redisplay-frame-pane frame (get-frame-pane frame 'board)))
577 (get-move-gui frame))
582 (defun game-dialog (frame)
583 (let* ((stream (get-frame-pane frame 'debug-window))
584 ;; (white-strategy-id (white-strategy-id frame)
585 ;; (black-strategy-id (black-strategy-id frame))
586 (wh (white-player frame))
587 (bl (black-player frame))
588 (white-searcher (gui-player-searcher-id wh))
589 (white-evaluator (gui-player-eval-id wh))
590 (white-ply (gui-player-ply wh))
591 (black-searcher (gui-player-searcher-id bl))
592 (black-evaluator (gui-player-eval-id bl))
593 (black-ply (gui-player-ply bl))
594 (minutes (minutes frame)))
596 (accepting-values (stream :own-window t
597 :label "Reversi Parameters")
601 :prompt "Maximum minutes" :default minutes))
603 (format stream "White Player~%")
605 (accept '(member :human :random :minimax :alpha-beta3)
607 :prompt "White Player Search" :default white-searcher))
609 (setq white-evaluator
610 (accept '(member :difference :weighted :modified-weighted :iago)
612 :prompt "White Player Evaluator" :default white-evaluator))
617 :prompt "White Ply" :default white-ply))
620 (format stream "Black Player~%")
623 (accept '(member :human :random :minimax :alpha-beta3)
625 :prompt "Black Player Search" :default black-searcher))
627 (setq black-evaluator
628 (accept '(member :difference :weighted :modified-weighted :iago)
630 :prompt "Black Player Evaluator" :default black-evaluator))
635 :prompt "Black Ply" :default black-ply))
638 (setf (minutes frame) minutes)
639 (setf (white-player frame) (make-gui-player :id white
640 :searcher-id white-searcher
641 :eval-id white-evaluator
643 (setf (black-player frame) (make-gui-player :id black
644 :searcher-id black-searcher
645 :eval-id black-evaluator
650 (defmethod draw-board ((reversi reversi) stream &key max-width max-height)
651 "This should produce a checkerboard pattern."
652 (declare (ignore max-width max-height))
653 (let ((game (reversi-game reversi)))
658 (+ label-width (* cell-width i)
659 half-cell-inner-width)
661 :align-x :center :align-y :top))
664 (format nil "~d" (1+ i))
667 (+ label-height (* cell-height i)
668 half-cell-inner-height))
669 :align-x :left :align-y :center))
670 (stream-set-cursor-position stream label-width label-height)
671 (surrounding-output-with-border (stream)
672 (formatting-table (stream :y-spacing 0 :x-spacing 0)
674 (formatting-row (stream)
676 (let* ((cell-id (square-number row column))
679 (bref (board game) cell-id)
681 (updating-output (stream :unique-id cell-id
683 (formatting-cell (stream :align-x :right :align-y :top)
684 (with-output-as-presentation (stream cell-id 'reversi-cell)
685 (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
686 (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
691 half-cell-inner-width
692 half-cell-inner-height
693 piece-radius :filled t :ink +black+))
697 half-cell-inner-width
698 half-cell-inner-height
699 piece-radius :filled t :ink +white+))))))))))))))