io-clim.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: reversi -*-
   2 ;;;;***************************************************************************
   3 ;;;;
   4 ;;;; FILE IDENTIFICATION
   5 ;;;;
   6 ;;;;  Name:           io-clim.lisp
   7 ;;;;  Purpose:        CLIM GUI for reversi
   8 ;;;;  Programer:      Kevin M. Rosenberg
   9 ;;;;  Date Started:   1 Nov 2001
  10 ;;;;
  11 ;;;; $Id: io-clim.lisp,v 1.2 2002/10/25 09:23:39 kevin Exp $
  12 ;;;;
  13 ;;;; This file is Copyright (c) 2001-2002 by Kevin M. Rosenberg
  14 ;;;;
  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 ;;;;***************************************************************************
  19
  20 (in-package :reversi)
  21
  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)
  32
  33 (defparameter board-width (+ 30 (* 8 cell-width)))
  34 (defparameter board-height (+ 30 (* 8 cell-height)))
  35
  36 (defparameter status-width 300)
  37
  38
  39 (defstruct (gui-player (:constructor make-gui-player-struct))
  40   id name searcher eval ply strategy start-time
  41   searcher-id eval-id)
  42
  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))
  47         (search-func
  48          (cond
  49           ((eq searcher-id :human)
  50            #'human)
  51           ((eq searcher-id :minimax)
  52            #'minimax-searcher)
  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)
  60            #'random-strategy)))
  61         (eval-func
  62          (cond
  63           ((eq eval-id :difference)
  64            #'count-difference)
  65           ((eq eval-id :weighted)
  66            #'weighted-squares)
  67           ((eq eval-id :modified-weighted)
  68            #'modified-weighted-squares)
  69           ((eq eval-id :iago)
  70            #'iago-eval))))
  71     (unless strategy
  72       (cond
  73        ((eq search-func #'human)
  74         )
  75        ((eq search-func #'random-strategy)
  76         (setf (gui-player-strategy p) search-func))
  77        (t
  78         (setf (gui-player-strategy p)
  79           (funcall search-func ply eval-func)))))
  80     p))
  81
  82
  83 (defun gui-player-human? (gp)
  84   (eql (gui-player-searcher-id gp) :human))
  85
  86 (defun current-gui-player (frame)
  87     (if frame
  88         (aif (reversi-game frame)
  89              (cond
  90                ((null (player it))
  91                 nil)
  92                ((= (player it) black)
  93                 (black-player frame))
  94                ((= (player it) white)
  95                 (white-player frame))
  96                (t
  97                 nil))
  98              nil)
  99       nil))
 100
 101 (defun current-gui-player-human? (frame)
 102   #+ignore
 103   (aif (current-gui-player frame)
 104        (gui-player-human? it)
 105        nil)
 106   (gui-player-human? (current-gui-player frame))
 107   )
 108
 109 (define-application-frame reversi ()
 110   ((game :initform nil
 111          :accessor reversi-game)
 112    (minutes :initform 30
 113             :accessor minutes)
 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))
 124   (:panes
 125     (board :application
 126              :display-function 'draw-board
 127              :text-style '(:sans-serif :bold :very-large)
 128 ;;           :incremental-redisplay t
 129              :text-cursor nil
 130              :background +green+
 131              :borders nil
 132              :scroll-bars nil
 133              :width (+ label-width board-width)
 134              :height (+ label-height  board-height)
 135              :min-width board-width
 136              :min-height board-height
 137              :max-width +fill+
 138              :max-height +fill+
 139              )
 140     (status :application
 141              :display-function 'draw-status
 142              :text-style '(:sans-serif :bold :large)
 143              :incremental-redisplay t
 144              :text-cursor nil
 145              :background +white+
 146              :scroll-bars nil
 147              :width status-width
 148              :max-width +fill+
 149              :max-height +fill+
 150              :height :compute)
 151     (history :application
 152              :display-function 'draw-history
 153              :text-style '(:fix :roman :normal)
 154              :incremental-redisplay t
 155              :text-cursor nil
 156              :background +white+
 157              :width 220
 158              :height :compute
 159              :min-width 100
 160              :initial-cursor-visibility :on
 161              :scroll-bars :vertical
 162              :max-width +fill+
 163              :max-height +fill+
 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
 170              :text-cursor nil
 171              :background +white+
 172              :width :compute
 173              :height :compute
 174              :scroll-bars :vertical
 175              :max-width +fill+
 176              :max-height +fill+
 177              :end-of-page-action :scroll
 178              :end-of-line-action :scroll
 179              )
 180     (msgbar :application
 181              :display-function 'draw-msgbar
 182              :text-style '(:sans-serif :roman :normal)
 183              :incremental-redisplay t
 184              :text-cursor nil
 185              :background (make-rgb-color 0.75 0.75 0.75)
 186              :foreground +red+
 187              :scroll-bars nil
 188              :width :compute
 189              :height 25
 190              :max-width +fill+
 191              :max-height +fill+
 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
 197                                   reversi-game-table
 198                                   reversi-help-table)
 199                      :menu (("Game"
 200                              :menu reversi-game-table
 201                              :mnemonic #\G
 202                              :documentation "Game commands")
 203                             ("Help"
 204                              :menu reversi-help-table
 205                              :mnemonic #\H
 206                              :documentation "Help Commands"))))
 207   (:menu-bar t)
 208   (:layouts
 209    (default
 210        (horizontally   ()
 211            (vertically   ()
 212              (horizontally ()
 213                board status)
 214              msgbar
 215              debug-window)
 216            history)
 217        ))
 218   )
 219
 220  ;;(:spacing 3)
 221
 222 (defmethod frame-standard-input ((reversi reversi))
 223   (get-frame-pane reversi 'debug-window))
 224
 225 (defmethod frame-standard-output ((reversi reversi))
 226   (get-frame-pane reversi 'debug-window))
 227
 228 (defmethod run-frame-top-level :before ((reversi reversi) &key)
 229   (initialize-reversi reversi))
 230
 231
 232 (defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
 233   (let ((abort-chars #+Genera '(#\Abort #\End)
 234                      #-Genera nil))
 235     (let ((command (read-command-using-keystrokes
 236                      (frame-command-table reversi) abort-chars
 237                      :stream stream)))
 238       (if (characterp command)
 239           (frame-exit reversi)
 240         command))))
 241
 242 (define-presentation-type reversi-cell ()
 243  :inherit-from '(integer 11 88))
 244
 245 #-lispworks
 246 (define-presentation-method highlight-presentation ((type reversi-cell)
 247                                                     record stream state)
 248   state
 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+))))
 257
 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)))
 264               (set-msgbar frame
 265                           (format nil "Illegal move: ~a"
 266                                   (symbol-name (88->h8 move))))
 267             (progn
 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))))))))
 273
 274
 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)))
 279     (object)
 280     (list object))
 281
 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))
 287           t
 288         nil))))
 289
 290
 291
 292 (defun new-game-gui (frame)
 293   (setf (reversi-game frame)
 294     (make-game
 295      (gui-player-strategy (black-player frame))
 296      (gui-player-strategy (white-player frame))
 297      :record-game t
 298      :print nil
 299      :minutes (minutes frame)))
 300   (set-msgbar frame "New Game")
 301   (get-move-gui frame))
 302
 303
 304
 305 (defmethod initialize-reversi ((reversi reversi))
 306   (setf (black-player reversi)
 307     (make-gui-player :id black :searcher-id :human)
 308     )
 309   (setf (white-player reversi)
 310     (make-gui-player :id white
 311                      :searcher-id :alpha-beta3
 312                      :eval-id :iago
 313                      :ply 5)))
 314
 315
 316 (defun square-number (row column)
 317   (declare (fixnum row column))
 318   (+ (* 10 (1+ row))
 319      (1+ column)))
 320
 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)))
 324     (when game
 325       (if (null (player game))
 326           (progn
 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)))
 334       (when (clock 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))
 340           (let ((legal-moves
 341                  (loop for move in (legal-moves (gui-player-id gui-player)
 342                                                 (board game))
 343                      collect (symbol-name (88->h8 move)))))
 344             (if legal-moves
 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)))))))))
 351
 352
 353
 354 (defmethod add-debug ((reversi reversi) msg)
 355   (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
 356
 357 (defmethod set-msgbar ((reversi reversi) msg)
 358   (setf (msgbar-string reversi) msg))
 359
 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))
 364       (princ msg stream)
 365       (terpri stream))))
 366
 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)))
 371
 372
 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)))
 380               (when state
 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)
 387                         (format stream str)
 388                         (terpri stream))))))))))))
 389
 390 #+ignore
 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)))
 398               (when state
 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)
 405                         (format stream str)
 406                         (terpri stream))))))))))))
 407
 408
 409 #|
 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))))))
 416   |#
 417
 418
 419
 420
 421 (defvar *reversi-frame* nil)
 422
 423 (eval-when (:compile-toplevel :load-toplevel :execute)
 424   (defparameter *force*
 425   #+(and os-threads microsoft-32)
 426   t
 427   #-(and os-threads microsoft-32)
 428   nil))
 429
 430 (defun g ()
 431  (greversi))
 432
 433 (defun greversi ()
 434   (unless (or *force* (null *reversi-frame*))
 435     (setq *reversi-frame* (make-application-frame 'reversi)))
 436   (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
 437
 438
 439 (defun run-frame (frame-name frame)
 440   (flet ((do-it ()
 441            (when (or *force* (null frame))
 442              (setq frame (make-application-frame frame-name)))
 443            (run-frame-top-level frame)))
 444     #+allegro
 445     (mp:process-run-function (write-to-string frame-name) #'do-it)
 446     #-allegro
 447     (do-it))
 448   frame)
 449
 450
 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))))
 455
 456 (define-command-table reversi-help-table)
 457
 458
 459 (define-command (com-reversi-new :name "New Game"
 460                                  :command-table reversi-game-table
 461                                  :keystroke (:n :control)
 462                                  :menu ("New Game"
 463                                         :after :start
 464                                         :documentation "New Game"))
 465     ()
 466   (with-application-frame (frame)
 467     (new-game-gui frame)))
 468
 469 (define-command (com-reversi-recommend :name "Recommend Move"
 470                                        :command-table reversi-game-table
 471                                        :keystroke (:r :control)
 472                                        :menu ("Recommend Move"
 473                                               :after "New Game"
 474                                               :documentation "Recommend Move"))
 475     ()
 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)))
 483             (when pointer
 484               (setf (pointer-cursor pointer) :busy))
 485           (set-msgbar frame "Thinking...")
 486           (let ((move (funcall (iago 8) (gui-player-id player)
 487                                (board game))))
 488             (when pointer
 489               (setf (pointer-cursor pointer) :default))
 490             (when move
 491               (set-msgbar frame
 492                           (format nil "Recommend move to ~a"
 493                                   (symbol-name (88->h8 move))))))))))))
 494
 495 (define-command (com-reversi-backup :name "Backup Move"
 496                                     :command-table reversi-game-table
 497                                     :keystroke (:b :control)
 498                                     :menu ("Backup Move"
 499                                            :after "Recommend Move"
 500                                            :documentation "Backup Move"))
 501     ()
 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))))))
 506
 507
 508 (define-command (com-reversi-exit :name "Exit"
 509                                   :command-table reversi-game-table
 510                                   :keystroke (:q :control)
 511                                   :menu ("Exit"
 512                                          :after "Backup Move"
 513                                          :documentation "Quit application"))
 514     ()
 515   (clim:frame-exit clim:*application-frame*))
 516
 517
 518 (define-command (com-reversi-options :name "Game Options"
 519                                  :command-table reversi-game-table
 520                                  :menu ("Game Options" :documentation "Game Options"))
 521     ()
 522   (with-application-frame (frame)
 523     (game-dialog frame)))
 524
 525
 526
 527 ;(define-command-table reversi-game
 528 ;  :inherit-from (reversi-game-table)
 529 ;  :inherit-menu t)
 530
 531 ;(define-command-table reversi-help)
 532 ;    :inherit-from (reversi-help-commands)
 533 ;    :inherit-menu t)
 534
 535 (define-command (com-about :command-table reversi-help-table
 536                            :menu
 537                            ("About Reversi"
 538                             :after :start
 539                             :documentation "About Reversi"))
 540     ()
 541   t)
 542 ;;  (acl-clim::pop-up-about-climap-dialog *application-frame*))
 543
 544
 545
 546 (defun make-move-gui (game move player)
 547     (make-game-move game move player))
 548
 549 (defun get-move-gui (frame)
 550   (let ((gui-player (current-gui-player frame)))
 551     (when gui-player
 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)))))
 555
 556 (defun computer-move (gui-player frame)
 557   (let* ((game (reversi-game frame))
 558          (port (find-port))
 559          (pointer (port-pointer port)))
 560     (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
 561     (when pointer
 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)
 568                                 (player game)
 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))
 575                (setf (player game)
 576                  (next-to-play (board game) (player game))))))
 577     (set-msgbar frame nil)
 578     (when pointer
 579       (setf (pointer-cursor pointer) :default)))
 580   (setq gui-player (current-gui-player frame))
 581
 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))
 585
 586
 587
 588
 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)))
 602
 603     (accepting-values (stream :own-window t
 604                               :label "Reversi Parameters")
 605       (setq minutes
 606         (accept 'integer
 607                 :stream stream
 608                 :prompt "Maximum minutes" :default minutes))
 609       (terpri stream)
 610       (format stream "White Player~%")
 611       (setq white-searcher
 612         (accept '(member :human :random :minimax :alpha-beta3)
 613                 :stream stream
 614                 :prompt "White Player Search" :default white-searcher))
 615       (terpri stream)
 616       (setq white-evaluator
 617         (accept '(member :difference :weighted :modified-weighted :iago)
 618                 :stream stream
 619                 :prompt "White Player Evaluator" :default white-evaluator))
 620       (terpri stream)
 621       (setq white-ply
 622         (accept 'integer
 623                 :stream stream
 624                 :prompt "White Ply" :default white-ply))
 625       (terpri stream)
 626       (terpri stream)
 627       (format stream "Black Player~%")
 628       (terpri stream)
 629       (setq black-searcher
 630         (accept '(member :human :random :minimax :alpha-beta3)
 631                 :stream stream
 632                 :prompt "Black Player Search" :default black-searcher))
 633       (terpri stream)
 634       (setq black-evaluator
 635         (accept '(member :difference :weighted :modified-weighted :iago)
 636                 :stream stream
 637                 :prompt "Black Player Evaluator" :default black-evaluator))
 638       (terpri stream)
 639             (setq black-ply
 640               (accept 'integer
 641                       :stream stream
 642                       :prompt "Black Ply" :default black-ply))
 643       (terpri stream)
 644       )
 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
 649                                          :ply white-ply))
 650     (setf (black-player frame) (make-gui-player :id black
 651                                          :searcher-id black-searcher
 652                                          :eval-id black-evaluator
 653                                          :ply black-ply))
 654     ))
 655
 656
 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)))
 661     (dotimes (i 8)
 662       (draw-text stream
 663                  (elt "abcdefgh" i)
 664                  (make-point
 665                   (+ label-width (* cell-width i)
 666                      half-cell-inner-width)
 667                   0)
 668                  :align-x :center :align-y :top))
 669     (dotimes (i 8)
 670       (draw-text stream
 671                  (format nil "~d" (1+ i))
 672                  (make-point
 673                   0
 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)
 680         (dotimes (row 8)
 681           (formatting-row (stream)
 682             (dotimes (column 8)
 683               (let* ((cell-id (square-number row column))
 684                      (value
 685                       (if game
 686                           (bref (board game) cell-id)
 687                         empty)))
 688                 (updating-output (stream :unique-id cell-id
 689                                          :cache-value value)
 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)
 694                       (cond
 695                        ((= value black)
 696                         (draw-circle*
 697                          stream
 698                          half-cell-inner-width
 699                          half-cell-inner-height
 700                          piece-radius :filled t :ink +black+))
 701                        ((= value white)
 702                         (draw-circle*
 703                          stream
 704                          half-cell-inner-width
 705                          half-cell-inner-height
 706                          piece-radius :filled t :ink +white+))))))))))))))
 707
 708
 709