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.4 2002/11/08 10:31:59 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)
430 (defun clim-reversi ()
431 (unless (or *force* (null *reversi-frame*))
432 (setq *reversi-frame* (make-application-frame 'reversi)))
433 (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
436 (defun run-frame (frame-name frame)
438 (when (or *force* (null frame))
439 (setq frame (make-application-frame frame-name)))
440 (run-frame-top-level frame)))
442 (mp:process-run-function (write-to-string frame-name) #'do-it)
448 (define-command-table reversi-game-table
449 :menu (("New" :command com-reversi-new)
450 ("Backup" :command (com-reversi-backup))
451 ("Exit" :command (com-reversi-exit))))
453 (define-command-table reversi-help-table)
456 (define-command (com-reversi-new :name "New Game"
457 :command-table reversi-game-table
458 :keystroke (:n :control)
461 :documentation "New Game"))
463 (with-application-frame (frame)
464 (new-game-gui frame)))
466 (define-command (com-reversi-recommend :name "Recommend Move"
467 :command-table reversi-game-table
468 :keystroke (:r :control)
469 :menu ("Recommend Move"
471 :documentation "Recommend Move"))
473 (with-application-frame (frame)
474 (let ((game (reversi-game frame))
475 (player (current-gui-player frame)))
476 (when (and game player)
477 (when (gui-player-human? player)
478 (let* ((port (find-port))
479 (pointer (port-pointer port)))
481 (setf (pointer-cursor pointer) :busy))
482 (set-msgbar frame "Thinking...")
483 (let ((move (funcall (iago 8) (gui-player-id player)
486 (setf (pointer-cursor pointer) :default))
489 (format nil "Recommend move to ~a"
490 (symbol-name (88->h8 move))))))))))))
492 (define-command (com-reversi-backup :name "Backup Move"
493 :command-table reversi-game-table
494 :keystroke (:b :control)
496 :after "Recommend Move"
497 :documentation "Backup Move"))
499 (with-application-frame (frame)
500 (let ((game (reversi-game frame)))
501 (when (and game (> (move-number game) 2))
502 (reset-game game (- (move-number game) 2))))))
505 (define-command (com-reversi-exit :name "Exit"
506 :command-table reversi-game-table
507 :keystroke (:q :control)
510 :documentation "Quit application"))
512 (clim:frame-exit clim:*application-frame*))
515 (define-command (com-reversi-options :name "Game Options"
516 :command-table reversi-game-table
517 :menu ("Game Options" :documentation "Game Options"))
519 (with-application-frame (frame)
520 (game-dialog frame)))
524 ;(define-command-table reversi-game
525 ; :inherit-from (reversi-game-table)
528 ;(define-command-table reversi-help)
529 ; :inherit-from (reversi-help-commands)
532 (define-command (com-about :command-table reversi-help-table
536 :documentation "About Reversi"))
539 ;; (acl-clim::pop-up-about-climap-dialog *application-frame*))
543 (defun make-move-gui (game move player)
544 (make-game-move game move player))
546 (defun get-move-gui (frame)
547 (let ((gui-player (current-gui-player frame)))
549 (if (gui-player-human? gui-player)
550 (setf (gui-player-start-time gui-player) (get-internal-real-time))
551 (computer-move gui-player frame)))))
553 (defun computer-move (gui-player frame)
554 (let* ((game (reversi-game frame))
556 (pointer (port-pointer port)))
557 (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
559 (setf (pointer-cursor pointer) :busy))
560 (set-msgbar frame "Thinking...")
561 (while (eq gui-player (current-gui-player frame))
562 (setf (gui-player-start-time gui-player)
563 (get-internal-real-time))
564 (let ((move (funcall (gui-player-strategy gui-player)
566 (replace-board *board* (board game)))))
567 (when (and move (legal-p move (player game) (board game)))
568 (decf (elt (clock game) (player game))
569 (- (get-internal-real-time)
570 (gui-player-start-time gui-player)))
571 (make-move-gui game move (player game))
573 (next-to-play (board game) (player game))))))
574 (set-msgbar frame nil)
576 (setf (pointer-cursor pointer) :default)))
577 (setq gui-player (current-gui-player frame))
579 (if (and gui-player (not (gui-player-human? gui-player)))
580 (redisplay-frame-pane frame (get-frame-pane frame 'board)))
581 (get-move-gui frame))
586 (defun game-dialog (frame)
587 (let* ((stream (get-frame-pane frame 'debug-window))
588 ;; (white-strategy-id (white-strategy-id frame)
589 ;; (black-strategy-id (black-strategy-id frame))
590 (wh (white-player frame))
591 (bl (black-player frame))
592 (white-searcher (gui-player-searcher-id wh))
593 (white-evaluator (gui-player-eval-id wh))
594 (white-ply (gui-player-ply wh))
595 (black-searcher (gui-player-searcher-id bl))
596 (black-evaluator (gui-player-eval-id bl))
597 (black-ply (gui-player-ply bl))
598 (minutes (minutes frame)))
600 (accepting-values (stream :own-window t
601 :label "Reversi Parameters")
605 :prompt "Maximum minutes" :default minutes))
607 (format stream "White Player~%")
609 (accept '(member :human :random :minimax :alpha-beta3)
611 :prompt "White Player Search" :default white-searcher))
613 (setq white-evaluator
614 (accept '(member :difference :weighted :modified-weighted :iago)
616 :prompt "White Player Evaluator" :default white-evaluator))
621 :prompt "White Ply" :default white-ply))
624 (format stream "Black Player~%")
627 (accept '(member :human :random :minimax :alpha-beta3)
629 :prompt "Black Player Search" :default black-searcher))
631 (setq black-evaluator
632 (accept '(member :difference :weighted :modified-weighted :iago)
634 :prompt "Black Player Evaluator" :default black-evaluator))
639 :prompt "Black Ply" :default black-ply))
642 (setf (minutes frame) minutes)
643 (setf (white-player frame) (make-gui-player :id white
644 :searcher-id white-searcher
645 :eval-id white-evaluator
647 (setf (black-player frame) (make-gui-player :id black
648 :searcher-id black-searcher
649 :eval-id black-evaluator
654 (defmethod draw-board ((reversi reversi) stream &key max-width max-height)
655 "This should produce a checkerboard pattern."
656 (declare (ignore max-width max-height))
657 (let ((game (reversi-game reversi)))
662 (+ label-width (* cell-width i)
663 half-cell-inner-width)
665 :align-x :center :align-y :top))
668 (format nil "~d" (1+ i))
671 (+ label-height (* cell-height i)
672 half-cell-inner-height))
673 :align-x :left :align-y :center))
674 (stream-set-cursor-position stream label-width label-height)
675 (surrounding-output-with-border (stream)
676 (formatting-table (stream :y-spacing 0 :x-spacing 0)
678 (formatting-row (stream)
680 (let* ((cell-id (square-number row column))
683 (bref (board game) cell-id)
685 (updating-output (stream :unique-id cell-id
687 (formatting-cell (stream :align-x :right :align-y :top)
688 (with-output-as-presentation (stream cell-id 'reversi-cell)
689 (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
690 (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
695 half-cell-inner-width
696 half-cell-inner-height
697 piece-radius :filled t :ink +black+))
701 half-cell-inner-width
702 half-cell-inner-height
703 piece-radius :filled t :ink +white+))))))))))))))