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.13 2003/06/12 12:42:13 kevin Exp $
13 ;;;; This file is Copyright (c) 2001-2003 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 ;;;;***************************************************************************
20 (in-package #:reversi)
22 #+mcclim (shadowing-import 'clim-internals::stream-set-cursor-position)
24 (defparameter cell-inner-width 40)
25 (defparameter cell-inner-height 40)
26 (defparameter half-cell-inner-width 20)
27 (defparameter half-cell-inner-height 20)
28 (defparameter line-thickness 2)
29 (defparameter piece-radius 16)
30 (defparameter cell-width (+ line-thickness cell-inner-width))
31 (defparameter cell-height (+ line-thickness cell-inner-height))
32 (defparameter label-height 42)
33 (defparameter label-width 42)
35 (defparameter board-width (+ 30 (* 8 cell-width)))
36 (defparameter board-height (+ 30 (* 8 cell-height)))
38 (defparameter status-width 300)
41 (defstruct (gui-player (:constructor make-gui-player-struct))
42 id name searcher eval ply strategy start-time
45 (defun make-gui-player (&key id name strategy searcher-id eval-id (ply 0))
46 (let ((p (make-gui-player-struct :id id :ply ply
47 :name name :strategy strategy
48 :searcher-id searcher-id :eval-id eval-id))
51 ((eq searcher-id :human)
53 ((eq searcher-id :minimax)
55 ((eq searcher-id :alpha-beta)
56 #'alpha-beta-searcher)
57 ((eq searcher-id :alpha-beta2)
58 #'alpha-beta-searcher2)
59 ((eq searcher-id :alpha-beta3)
60 #'alpha-beta-searcher3)
61 ((eq searcher-id :random)
65 ((eq eval-id :difference)
67 ((eq eval-id :weighted)
69 ((eq eval-id :modified-weighted)
70 #'modified-weighted-squares)
75 ((eq search-func #'human)
77 ((eq search-func #'random-strategy)
78 (setf (gui-player-strategy p) search-func))
80 (setf (gui-player-strategy p)
81 (funcall search-func ply eval-func)))))
85 (defun gui-player-human? (gp)
86 (eql (gui-player-searcher-id gp) :human))
88 (defun current-gui-player (frame)
90 (aif (reversi-game frame)
94 ((= (player it) black)
96 ((= (player it) white)
103 (defun current-gui-player-human? (frame)
105 (aif (current-gui-player frame)
106 (gui-player-human? it)
108 (gui-player-human? (current-gui-player frame))
111 (define-application-frame reversi ()
113 :accessor reversi-game)
114 (minutes :initform 30
116 (black-player :initform nil
117 :accessor black-player)
118 (white-player :initform nil
119 :accessor white-player)
120 (debug-messages :initform nil
121 :accessor debug-messages)
122 (msgbar-string :initform nil
123 :accessor msgbar-string)
124 (human-time-start :initform nil
125 :accessor reversi-human-time-start))
128 :display-function 'draw-board
129 :text-style '(:sans-serif :bold :very-large)
130 ;; :incremental-redisplay t
135 :width (+ label-width board-width)
136 :height (+ label-height board-height)
137 :min-width board-width
138 :min-height board-height
143 :display-function 'draw-status
144 :text-style '(:sans-serif :bold :large)
145 :incremental-redisplay t
153 (history :application
154 :display-function 'draw-history
155 :text-style '(:fix :roman :normal)
156 :incremental-redisplay t
162 :initial-cursor-visibility :on
163 :scroll-bars :vertical
166 :end-of-page-action :scroll
167 :end-of-line-action :scroll)
168 (debug-window :application
169 :display-function 'draw-debug-window
170 :text-style '(:serif :roman :normal)
171 :incremental-redisplay t
176 :scroll-bars :vertical
179 :end-of-page-action :scroll
180 :end-of-line-action :scroll
183 :display-function 'draw-msgbar
184 :text-style '(:sans-serif :roman :normal)
185 :incremental-redisplay t
187 :background (make-rgb-color 0.75 0.75 0.75)
194 :end-of-page-action :scroll
195 :end-of-line-action :scroll))
196 (:pointer-documentation nil)
197 (:command-table (reversi
198 :inherit-from (user-command-table
202 :menu reversi-game-table
204 :documentation "Game commands")
206 :menu reversi-help-table
208 :documentation "Help Commands"))))
224 (defmethod frame-standard-input ((reversi reversi))
225 (get-frame-pane reversi 'debug-window))
227 (defmethod frame-standard-output ((reversi reversi))
228 (get-frame-pane reversi 'debug-window))
230 (defmethod run-frame-top-level :before ((reversi reversi) &key)
231 (initialize-reversi reversi))
234 (defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
235 (let ((abort-chars #+Genera '(#\Abort #\End)
237 (let ((command (read-command-using-keystrokes
238 (frame-command-table reversi) abort-chars
240 (if (characterp command)
244 (define-presentation-type reversi-cell ()
245 :inherit-from '(integer 11 88))
248 (define-presentation-method highlight-presentation ((type reversi-cell)
251 (multiple-value-bind (xoff yoff)
252 (clim::convert-from-relative-to-absolute-coordinates
253 stream (output-record-parent record))
254 (with-bounding-rectangle* (left top right bottom) record
255 (draw-rectangle* stream
256 (+ left xoff) (+ top yoff)
257 (+ right xoff) (+ bottom yoff)
258 :ink +flipping-ink+))))
260 (define-reversi-command com-select-cell ((move 'reversi-cell))
261 (with-application-frame (frame)
262 (with-slots (game) frame
263 (let ((gui-player (current-gui-player frame)))
264 (when (and game gui-player (gui-player-human? gui-player))
265 (if (not (legal-p move (gui-player-id gui-player) (board game)))
267 (format nil "Illegal move: ~a"
268 (symbol-name (88->h8 move))))
270 (decf (elt (clock game) (player game))
271 (- (get-internal-real-time) (gui-player-start-time gui-player)))
272 (make-move-gui game move (gui-player-id gui-player))
273 (setf (player game) (next-to-play (board game) (player game)))
274 (get-move-gui frame))))))))
277 (define-presentation-to-command-translator select-cell
278 (reversi-cell com-select-cell reversi
279 :documentation "Select cell"
280 :tester ((object frame window) (cell-selectable-p object frame window)))
284 (defun cell-selectable-p (object frame window)
285 (when (and (eq (get-frame-pane frame 'board) window)
286 (reversi-game frame))
287 (let ((game (reversi-game frame)))
288 (if (legal-p object (player game) (board game))
294 (defun new-game-gui (frame)
295 (setf (reversi-game frame)
297 (gui-player-strategy (black-player frame))
298 (gui-player-strategy (white-player frame))
301 :minutes (minutes frame)))
302 (set-msgbar frame "New Game")
303 (get-move-gui frame))
307 (defmethod initialize-reversi ((reversi reversi))
308 (setf (black-player reversi)
309 (make-gui-player :id black :searcher-id :human)
311 (setf (white-player reversi)
312 (make-gui-player :id white
313 :searcher-id :alpha-beta3
318 (defun square-number (row column)
319 (declare (fixnum row column))
323 (defmethod draw-status ((reversi reversi) stream &key max-width max-height)
324 (declare (ignore max-width max-height))
325 (let ((game (reversi-game reversi)))
327 (if (null (player game))
329 (setf (final-result game) (count-difference black (board game)))
330 (format stream "Game Over~2%"))
331 (format stream "Move Number ~d~2%" (move-number game)))
332 (format stream "Pieces~% ~a ~2d~% ~a ~2d~% Difference ~2d~2&"
333 (title-of black) (count black (board game))
334 (title-of white) (count white (board game))
335 (count-difference black (board game)))
337 (format stream "Time Remaining~% ~a ~a~% ~a ~a~2%"
338 (title-of black) (time-string (elt (clock game) black))
339 (title-of white) (time-string (elt (clock game) white))))
340 (let ((gui-player (current-gui-player reversi)))
341 (when (and gui-player (gui-player-human? gui-player))
343 (loop for move in (legal-moves (gui-player-id gui-player)
345 collect (symbol-name (88->h8 move)))))
347 (format stream "Valid Moves~%~A"
348 (list-to-delimited-string legal-moves #\space)))))
349 (when (null (player game))
351 ((zerop (final-result game))
352 (format stream "It's a draw!"))
353 ((plusp (final-result game))
354 (format stream "Black wins by ~d!" (final-result game)))
356 (format stream "White wins by ~d!" (- 0 (final-result game))))))))))
360 (defmethod add-debug ((reversi reversi) msg)
361 (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
363 (defmethod set-msgbar ((reversi reversi) msg)
364 (setf (msgbar-string reversi) msg))
366 (defmethod draw-debug-window ((reversi reversi) stream &key max-width max-height)
367 (declare (ignore max-width max-height))
368 (filling-output (stream)
369 (dolist (msg (debug-messages reversi))
373 (defmethod draw-msgbar ((reversi reversi) stream &key max-width max-height)
374 (declare (ignore max-width max-height))
375 (when (msgbar-string reversi)
376 (princ (msgbar-string reversi) stream)))
379 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
380 (declare (ignore max-width max-height))
381 (let ((game (reversi-game reversi)))
382 (when (and game (> (move-number game) 1))
383 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 1)
384 (dotimes (i (1- (move-number game)))
385 (let ((state (aref (moves game) i)))
387 (let ((str (format nil "~2d: ~5a ~2a"
388 (1+ i) (title-of (state-player state))
389 (88->h8 (state-move state)))))
390 (updating-output (stream :unique-id i :cache-value str)
391 (with-end-of-page-action (stream :scroll)
392 (formatting-cell (stream :align-x :right :align-y :top)
394 (terpri stream))))))))))))
397 (defmethod draw-history ((reversi reversi) stream &key max-width max-height)
398 (declare (ignore max-width max-height))
399 (let ((game (reversi-game reversi)))
400 (when (and game (> (move-number game) 1))
401 (formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 2)
402 (dotimes (i (1- (move-number game)))
403 (let ((state (aref (moves game) i)))
405 (let ((str (format nil "~2d: ~5a ~2a"
406 (1+ i) (title-of (state-player state))
407 (88->h8 (state-move state)))))
408 (updating-output (stream :unique-id i :cache-value str)
409 (with-end-of-page-action (stream :scroll)
410 (formatting-cell (stream :align-x :right :align-y :top)
412 (terpri stream))))))))))))
416 (let ((viewport (window-viewport stream)))
417 (multiple-value-bind (x y) (stream-cursor-position stream)
418 (add-debug reversi (format nil "~d ~d: ~s" x y viewport))
419 (if (> y (bounding-rectangle-bottom viewport))
420 (decf y (bounding-rectangle-bottom viewport)))
421 (window-set-viewport-position stream 0 0))))))
427 (defvar *reversi-frame* nil)
429 (eval-when (:compile-toplevel :load-toplevel :execute)
430 (defparameter *force*
431 #+(and os-threads microsoft-32)
433 #-(and os-threads microsoft-32)
436 (defun clim-reversi ()
437 (unless (or *force* (null *reversi-frame*))
438 (setq *reversi-frame* (make-application-frame 'reversi)))
439 (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
442 (defun run-frame (frame-name frame)
444 (when (or *force* (null frame))
445 (setq frame (make-application-frame frame-name)))
446 (run-frame-top-level frame)))
448 (mp:process-run-function (write-to-string frame-name) #'do-it)
454 (define-command-table reversi-game-table
455 :menu (("New" :command com-reversi-new)
456 ("Backup" :command (com-reversi-backup))
457 ("Exit" :command (com-reversi-exit))))
459 (define-command-table reversi-help-table)
462 (define-command (com-reversi-new :name "New Game"
463 :command-table reversi-game-table
464 :keystroke (:n :control)
467 :documentation "New Game"))
469 (with-application-frame (frame)
470 (new-game-gui frame)))
472 (define-command (com-reversi-recommend :name "Recommend Move"
473 :command-table reversi-game-table
474 :keystroke (:r :control)
475 :menu ("Recommend Move"
477 :documentation "Recommend Move"))
479 (with-application-frame (frame)
480 (let ((game (reversi-game frame))
481 (player (current-gui-player frame)))
482 (when (and game player)
483 (when (gui-player-human? player)
484 (let* ((port (find-port))
485 (pointer (port-pointer port)))
487 (setf (pointer-cursor pointer) :busy))
488 (set-msgbar frame "Thinking...")
489 (let ((move (funcall (iago 8) (gui-player-id player)
492 (setf (pointer-cursor pointer) :default))
495 (format nil "Recommend move to ~a"
496 (symbol-name (88->h8 move))))))))))))
498 (define-command (com-reversi-backup :name "Backup Move"
499 :command-table reversi-game-table
500 :keystroke (:b :control)
502 :after "Recommend Move"
503 :documentation "Backup Move"))
505 (with-application-frame (frame)
506 (let ((game (reversi-game frame)))
507 (when (and game (> (move-number game) 2))
508 (reset-game game (- (move-number game) 2))))))
511 (define-command (com-reversi-exit :name "Exit"
512 :command-table reversi-game-table
513 :keystroke (:q :control)
516 :documentation "Quit application"))
518 (clim:frame-exit clim:*application-frame*))
521 (define-command (com-reversi-options :name "Game Options"
522 :command-table reversi-game-table
523 :menu ("Game Options" :documentation "Game Options"))
525 (with-application-frame (frame)
526 (game-dialog frame)))
530 ;(define-command-table reversi-game
531 ; :inherit-from (reversi-game-table)
534 ;(define-command-table reversi-help)
535 ; :inherit-from (reversi-help-commands)
538 (define-command (com-about :command-table reversi-help-table
542 :documentation "About Reversi"))
545 ;; (acl-clim::pop-up-about-climap-dialog *application-frame*))
549 (defun make-move-gui (game move player)
550 (make-game-move game move player))
552 (defun get-move-gui (frame)
553 (let ((gui-player (current-gui-player frame)))
555 (if (gui-player-human? gui-player)
556 (setf (gui-player-start-time gui-player) (get-internal-real-time))
557 (computer-move gui-player frame)))))
559 (defun computer-move (gui-player frame)
560 (let* ((game (reversi-game frame))
562 (pointer (port-pointer port)))
563 (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
565 (setf (pointer-cursor pointer) :busy))
566 (set-msgbar frame "Thinking...")
567 (while (eq gui-player (current-gui-player frame))
568 (setf (gui-player-start-time gui-player)
569 (get-internal-real-time))
570 (let ((move (funcall (gui-player-strategy gui-player)
572 (replace-board *board* (board game)))))
573 (when (and move (legal-p move (player game) (board game)))
574 (decf (elt (clock game) (player game))
575 (- (get-internal-real-time)
576 (gui-player-start-time gui-player)))
577 (make-move-gui game move (player game))
579 (next-to-play (board game) (player game))))))
580 (set-msgbar frame nil)
582 (setf (pointer-cursor pointer) :default)))
583 (setq gui-player (current-gui-player frame))
585 (if (and gui-player (not (gui-player-human? gui-player)))
586 (redisplay-frame-pane frame (get-frame-pane frame 'board)))
587 (get-move-gui frame))
592 (defun game-dialog (frame)
593 (let* ((stream (get-frame-pane frame 'debug-window))
594 ;; (white-strategy-id (white-strategy-id frame)
595 ;; (black-strategy-id (black-strategy-id frame))
596 (wh (white-player frame))
597 (bl (black-player frame))
598 (white-searcher (gui-player-searcher-id wh))
599 (white-evaluator (gui-player-eval-id wh))
600 (white-ply (gui-player-ply wh))
601 (black-searcher (gui-player-searcher-id bl))
602 (black-evaluator (gui-player-eval-id bl))
603 (black-ply (gui-player-ply bl))
604 (minutes (minutes frame)))
606 (accepting-values (stream :own-window t
607 :label "Reversi Parameters")
611 :prompt "Maximum minutes" :default minutes))
613 (format stream "White Player~%")
615 (accept '(member :human :random :minimax :alpha-beta3)
617 :prompt "White Player Search" :default white-searcher))
619 (setq white-evaluator
620 (accept '(member :difference :weighted :modified-weighted :iago)
622 :prompt "White Player Evaluator" :default white-evaluator))
627 :prompt "White Ply" :default white-ply))
630 (format stream "Black Player~%")
633 (accept '(member :human :random :minimax :alpha-beta3)
635 :prompt "Black Player Search" :default black-searcher))
637 (setq black-evaluator
638 (accept '(member :difference :weighted :modified-weighted :iago)
640 :prompt "Black Player Evaluator" :default black-evaluator))
645 :prompt "Black Ply" :default black-ply))
648 (setf (minutes frame) minutes)
649 (setf (white-player frame) (make-gui-player :id white
650 :searcher-id white-searcher
651 :eval-id white-evaluator
653 (setf (black-player frame) (make-gui-player :id black
654 :searcher-id black-searcher
655 :eval-id black-evaluator
660 (defmethod draw-board ((reversi reversi) stream &key max-width max-height)
661 "This should produce a checkerboard pattern."
662 (declare (ignore max-width max-height))
663 (let ((game (reversi-game reversi)))
668 (+ label-width (* cell-width i)
669 half-cell-inner-width)
671 :align-x :center :align-y :top))
674 (format nil "~d" (1+ i))
677 (+ label-height (* cell-height i)
678 half-cell-inner-height))
679 :align-x :left :align-y :center))
680 (stream-set-cursor-position stream label-width label-height)
681 (surrounding-output-with-border (stream)
682 (formatting-table (stream :y-spacing 0 :x-spacing 0)
684 (formatting-row (stream)
686 (let* ((cell-id (square-number row column))
689 (bref (board game) cell-id)
691 (updating-output (stream :unique-id cell-id
693 (formatting-cell (stream :align-x :right :align-y :top)
694 (with-output-as-presentation (stream cell-id 'reversi-cell)
695 (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
696 (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
701 half-cell-inner-width
702 half-cell-inner-height
703 piece-radius :filled t :ink +black+))
707 half-cell-inner-width
708 half-cell-inner-height
709 piece-radius :filled t :ink +white+))))))))))))))