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.3 2002/10/25 13:09:11 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 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*)))
 434
 435
 436 (defun run-frame (frame-name frame)
 437   (flet ((do-it ()
 438            (when (or *force* (null frame))
 439              (setq frame (make-application-frame frame-name)))
 440            (run-frame-top-level frame)))
 441     #+allegro
 442     (mp:process-run-function (write-to-string frame-name) #'do-it)
 443     #-allegro
 444     (do-it))
 445   frame)
 446
 447
 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))))
 452
 453 (define-command-table reversi-help-table)
 454
 455
 456 (define-command (com-reversi-new :name "New Game"
 457                                  :command-table reversi-game-table
 458                                  :keystroke (:n :control)
 459                                  :menu ("New Game"
 460                                         :after :start
 461                                         :documentation "New Game"))
 462     ()
 463   (with-application-frame (frame)
 464     (new-game-gui frame)))
 465
 466 (define-command (com-reversi-recommend :name "Recommend Move"
 467                                        :command-table reversi-game-table
 468                                        :keystroke (:r :control)
 469                                        :menu ("Recommend Move"
 470                                               :after "New Game"
 471                                               :documentation "Recommend Move"))
 472     ()
 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)))
 480             (when pointer
 481               (setf (pointer-cursor pointer) :busy))
 482           (set-msgbar frame "Thinking...")
 483           (let ((move (funcall (iago 8) (gui-player-id player)
 484                                (board game))))
 485             (when pointer
 486               (setf (pointer-cursor pointer) :default))
 487             (when move
 488               (set-msgbar frame
 489                           (format nil "Recommend move to ~a"
 490                                   (symbol-name (88->h8 move))))))))))))
 491
 492 (define-command (com-reversi-backup :name "Backup Move"
 493                                     :command-table reversi-game-table
 494                                     :keystroke (:b :control)
 495                                     :menu ("Backup Move"
 496                                            :after "Recommend Move"
 497                                            :documentation "Backup Move"))
 498     ()
 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))))))
 503
 504
 505 (define-command (com-reversi-exit :name "Exit"
 506                                   :command-table reversi-game-table
 507                                   :keystroke (:q :control)
 508                                   :menu ("Exit"
 509                                          :after "Backup Move"
 510                                          :documentation "Quit application"))
 511     ()
 512   (clim:frame-exit clim:*application-frame*))
 513
 514
 515 (define-command (com-reversi-options :name "Game Options"
 516                                  :command-table reversi-game-table
 517                                  :menu ("Game Options" :documentation "Game Options"))
 518     ()
 519   (with-application-frame (frame)
 520     (game-dialog frame)))
 521
 522
 523
 524 ;(define-command-table reversi-game
 525 ;  :inherit-from (reversi-game-table)
 526 ;  :inherit-menu t)
 527
 528 ;(define-command-table reversi-help)
 529 ;    :inherit-from (reversi-help-commands)
 530 ;    :inherit-menu t)
 531
 532 (define-command (com-about :command-table reversi-help-table
 533                            :menu
 534                            ("About Reversi"
 535                             :after :start
 536                             :documentation "About Reversi"))
 537     ()
 538   t)
 539 ;;  (acl-clim::pop-up-about-climap-dialog *application-frame*))
 540
 541
 542
 543 (defun make-move-gui (game move player)
 544     (make-game-move game move player))
 545
 546 (defun get-move-gui (frame)
 547   (let ((gui-player (current-gui-player frame)))
 548     (when gui-player
 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)))))
 552
 553 (defun computer-move (gui-player frame)
 554   (let* ((game (reversi-game frame))
 555          (port (find-port))
 556          (pointer (port-pointer port)))
 557     (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
 558     (when pointer
 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)
 565                                 (player game)
 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))
 572                (setf (player game)
 573                  (next-to-play (board game) (player game))))))
 574     (set-msgbar frame nil)
 575     (when pointer
 576       (setf (pointer-cursor pointer) :default)))
 577   (setq gui-player (current-gui-player frame))
 578
 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))
 582
 583
 584
 585
 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)))
 599
 600     (accepting-values (stream :own-window t
 601                               :label "Reversi Parameters")
 602       (setq minutes
 603         (accept 'integer
 604                 :stream stream
 605                 :prompt "Maximum minutes" :default minutes))
 606       (terpri stream)
 607       (format stream "White Player~%")
 608       (setq white-searcher
 609         (accept '(member :human :random :minimax :alpha-beta3)
 610                 :stream stream
 611                 :prompt "White Player Search" :default white-searcher))
 612       (terpri stream)
 613       (setq white-evaluator
 614         (accept '(member :difference :weighted :modified-weighted :iago)
 615                 :stream stream
 616                 :prompt "White Player Evaluator" :default white-evaluator))
 617       (terpri stream)
 618       (setq white-ply
 619         (accept 'integer
 620                 :stream stream
 621                 :prompt "White Ply" :default white-ply))
 622       (terpri stream)
 623       (terpri stream)
 624       (format stream "Black Player~%")
 625       (terpri stream)
 626       (setq black-searcher
 627         (accept '(member :human :random :minimax :alpha-beta3)
 628                 :stream stream
 629                 :prompt "Black Player Search" :default black-searcher))
 630       (terpri stream)
 631       (setq black-evaluator
 632         (accept '(member :difference :weighted :modified-weighted :iago)
 633                 :stream stream
 634                 :prompt "Black Player Evaluator" :default black-evaluator))
 635       (terpri stream)
 636             (setq black-ply
 637               (accept 'integer
 638                       :stream stream
 639                       :prompt "Black Ply" :default black-ply))
 640       (terpri stream)
 641       )
 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
 646                                          :ply white-ply))
 647     (setf (black-player frame) (make-gui-player :id black
 648                                          :searcher-id black-searcher
 649                                          :eval-id black-evaluator
 650                                          :ply black-ply))
 651     ))
 652
 653
 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)))
 658     (dotimes (i 8)
 659       (draw-text stream
 660                  (elt "abcdefgh" i)
 661                  (make-point
 662                   (+ label-width (* cell-width i)
 663                      half-cell-inner-width)
 664                   0)
 665                  :align-x :center :align-y :top))
 666     (dotimes (i 8)
 667       (draw-text stream
 668                  (format nil "~d" (1+ i))
 669                  (make-point
 670                   0
 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)
 677         (dotimes (row 8)
 678           (formatting-row (stream)
 679             (dotimes (column 8)
 680               (let* ((cell-id (square-number row column))
 681                      (value
 682                       (if game
 683                           (bref (board game) cell-id)
 684                         empty)))
 685                 (updating-output (stream :unique-id cell-id
 686                                          :cache-value value)
 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)
 691                       (cond
 692                        ((= value black)
 693                         (draw-circle*
 694                          stream
 695                          half-cell-inner-width
 696                          half-cell-inner-height
 697                          piece-radius :filled t :ink +black+))
 698                        ((= value white)
 699                         (draw-circle*
 700                          stream
 701                          half-cell-inner-width
 702                          half-cell-inner-height
 703                          piece-radius :filled t :ink +white+))))))))))))))
 704
 705
 706