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$
  12 ;;;;
  13 ;;;; This file is Copyright (c) 2001-2003 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 #+mcclim (shadowing-import 'clim-internals::stream-set-cursor-position)
  23
  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)
  34
  35 (defparameter board-width (+ 30 (* 8 cell-width)))
  36 (defparameter board-height (+ 30 (* 8 cell-height)))
  37
  38 (defparameter status-width 300)
  39
  40
  41 (defstruct (gui-player (:constructor make-gui-player-struct))
  42   id name searcher eval ply strategy start-time
  43   searcher-id eval-id)
  44
  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))
  49         (search-func
  50          (cond
  51           ((eq searcher-id :human)
  52            #'human)
  53           ((eq searcher-id :minimax)
  54            #'minimax-searcher)
  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)
  62            #'random-strategy)))
  63         (eval-func
  64          (cond
  65           ((eq eval-id :difference)
  66            #'count-difference)
  67           ((eq eval-id :weighted)
  68            #'weighted-squares)
  69           ((eq eval-id :modified-weighted)
  70            #'modified-weighted-squares)
  71           ((eq eval-id :iago)
  72            #'iago-eval))))
  73     (unless strategy
  74       (cond
  75        ((eq search-func #'human)
  76         )
  77        ((eq search-func #'random-strategy)
  78         (setf (gui-player-strategy p) search-func))
  79        (t
  80         (setf (gui-player-strategy p)
  81           (funcall search-func ply eval-func)))))
  82     p))
  83
  84
  85 (defun gui-player-human? (gp)
  86   (eql (gui-player-searcher-id gp) :human))
  87
  88 (defun current-gui-player (frame)
  89     (if frame
  90         (aif (reversi-game frame)
  91              (cond
  92                ((null (player it))
  93                 nil)
  94                ((= (player it) black)
  95                 (black-player frame))
  96                ((= (player it) white)
  97                 (white-player frame))
  98                (t
  99                 nil))
 100              nil)
 101       nil))
 102
 103 (defun current-gui-player-human? (frame)
 104   #+ignore
 105   (aif (current-gui-player frame)
 106        (gui-player-human? it)
 107        nil)
 108   (gui-player-human? (current-gui-player frame))
 109   )
 110
 111 (define-application-frame reversi ()
 112   ((game :initform nil
 113          :accessor reversi-game)
 114    (minutes :initform 30
 115             :accessor minutes)
 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))
 126   (:panes
 127     (board :application
 128              :display-function 'draw-board
 129              :text-style '(:sans-serif :bold :very-large)
 130 ;;           :incremental-redisplay t
 131              :text-cursor nil
 132              :background +green+
 133              :borders nil
 134              :scroll-bars nil
 135              :width (+ label-width board-width)
 136              :height (+ label-height  board-height)
 137              :min-width board-width
 138              :min-height board-height
 139              :max-width +fill+
 140              :max-height +fill+
 141              )
 142     (status :application
 143              :display-function 'draw-status
 144              :text-style '(:sans-serif :bold :large)
 145              :incremental-redisplay t
 146              :text-cursor nil
 147              :background +white+
 148              :scroll-bars nil
 149              :width status-width
 150              :max-width +fill+
 151              :max-height +fill+
 152              :height :compute)
 153     (history :application
 154              :display-function 'draw-history
 155              :text-style '(:fix :roman :normal)
 156              :incremental-redisplay t
 157              :text-cursor nil
 158              :background +white+
 159              :width 220
 160              :height :compute
 161              :min-width 100
 162              :initial-cursor-visibility :on
 163              :scroll-bars :vertical
 164              :max-width +fill+
 165              :max-height +fill+
 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
 172              :text-cursor nil
 173              :background +white+
 174              :width :compute
 175              :height :compute
 176              :scroll-bars :vertical
 177              :max-width +fill+
 178              :max-height +fill+
 179              :end-of-page-action :scroll
 180              :end-of-line-action :scroll
 181              )
 182     (msgbar :application
 183              :display-function 'draw-msgbar
 184              :text-style '(:sans-serif :roman :normal)
 185              :incremental-redisplay t
 186              :text-cursor nil
 187              :background (make-rgb-color 0.75 0.75 0.75)
 188              :foreground +red+
 189              :scroll-bars nil
 190              :width :compute
 191              :height 25
 192              :max-width +fill+
 193              :max-height +fill+
 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
 199                                   reversi-game-table
 200                                   reversi-help-table)
 201                      :menu (("Game"
 202                              :menu reversi-game-table
 203                              :keystroke #\G
 204                              :documentation "Game commands")
 205                             ("Help"
 206                              :menu reversi-help-table
 207                              :keystroke #\H
 208                              :documentation "Help Commands"))))
 209   (:menu-bar t)
 210   (:layouts
 211    (default
 212        (horizontally   ()
 213            (vertically   ()
 214              (horizontally ()
 215                board status)
 216              msgbar
 217              debug-window)
 218            history)
 219        ))
 220   )
 221
 222  ;;(:spacing 3)
 223
 224 (defmethod frame-standard-input ((reversi reversi))
 225   (get-frame-pane reversi 'debug-window))
 226
 227 (defmethod frame-standard-output ((reversi reversi))
 228   (get-frame-pane reversi 'debug-window))
 229
 230 (defmethod run-frame-top-level :before ((reversi reversi) &key)
 231   (initialize-reversi reversi))
 232
 233
 234 (defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
 235   (let ((abort-chars #+Genera '(#\Abort #\End)
 236                      #-Genera nil))
 237     (let ((command (read-command-using-keystrokes
 238                      (frame-command-table reversi) abort-chars
 239                      :stream stream)))
 240       (if (characterp command)
 241           (frame-exit reversi)
 242         command))))
 243
 244 (define-presentation-type reversi-cell ()
 245  :inherit-from '(integer 11 88))
 246
 247 #-lispworks
 248 (define-presentation-method highlight-presentation ((type reversi-cell)
 249                                                     record stream state)
 250   state
 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+))))
 259
 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)))
 266               (set-msgbar frame
 267                           (format nil "Illegal move: ~a"
 268                                   (symbol-name (88->h8 move))))
 269             (progn
 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))))))))
 275
 276
 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)))
 281     (object)
 282     (list object))
 283
 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))
 289           t
 290         nil))))
 291
 292
 293
 294 (defun new-game-gui (frame)
 295   (setf (reversi-game frame)
 296     (make-game
 297      (gui-player-strategy (black-player frame))
 298      (gui-player-strategy (white-player frame))
 299      :record-game t
 300      :print nil
 301      :minutes (minutes frame)))
 302   (set-msgbar frame "New Game")
 303   (get-move-gui frame))
 304
 305
 306
 307 (defmethod initialize-reversi ((reversi reversi))
 308   (setf (black-player reversi)
 309     (make-gui-player :id black :searcher-id :human)
 310     )
 311   (setf (white-player reversi)
 312     (make-gui-player :id white
 313                      :searcher-id :alpha-beta3
 314                      :eval-id :iago
 315                      :ply 5)))
 316
 317
 318 (defun square-number (row column)
 319   (declare (fixnum row column))
 320   (+ (* 10 (1+ row))
 321      (1+ column)))
 322
 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)))
 326     (when game
 327       (if (null (player game))
 328           (progn
 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)))
 336       (when (clock 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))
 342           (let ((legal-moves
 343                  (loop for move in (legal-moves (gui-player-id gui-player)
 344                                                 (board game))
 345                      collect (symbol-name (88->h8 move)))))
 346             (if legal-moves
 347                 (format stream "Valid Moves~%~A"
 348                         (list-to-delimited-string legal-moves #\space)))))
 349         (when (null (player game))
 350           (cond
 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)))
 355             (t
 356              (format stream "White wins by ~d!" (- 0 (final-result game))))))))))
 357
 358
 359
 360 (defmethod add-debug ((reversi reversi) msg)
 361   (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
 362
 363 (defmethod set-msgbar ((reversi reversi) msg)
 364   (setf (msgbar-string reversi) msg))
 365
 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))
 370       (princ msg stream)
 371       (terpri stream))))
 372
 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)))
 377
 378
 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)))
 386               (when state
 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)
 393                         (format stream str)
 394                         (terpri stream))))))))))))
 395
 396 #+ignore
 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)))
 404               (when state
 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)
 411                         (format stream str)
 412                         (terpri stream))))))))))))
 413
 414
 415 #|
 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))))))
 422   |#
 423
 424
 425
 426
 427 (defvar *reversi-frame* nil)
 428
 429 (eval-when (:compile-toplevel :load-toplevel :execute)
 430   (defparameter *force*
 431   #+(and os-threads microsoft-32)
 432   t
 433   #-(and os-threads microsoft-32)
 434   nil))
 435
 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*)))
 440
 441
 442 (defun run-frame (frame-name frame)
 443   (flet ((do-it ()
 444            (when (or *force* (null frame))
 445              (setq frame (make-application-frame frame-name)))
 446            (run-frame-top-level frame)))
 447     #+allegro
 448     (mp:process-run-function (write-to-string frame-name) #'do-it)
 449     #-allegro
 450     (do-it))
 451   frame)
 452
 453
 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))))
 458
 459 (define-command-table reversi-help-table)
 460
 461
 462 (define-command (com-reversi-new :name "New Game"
 463                                  :command-table reversi-game-table
 464                                  :keystroke (:n :control)
 465                                  :menu ("New Game"
 466                                         :after :start
 467                                         :documentation "New Game"))
 468     ()
 469   (with-application-frame (frame)
 470     (new-game-gui frame)))
 471
 472 (define-command (com-reversi-recommend :name "Recommend Move"
 473                                        :command-table reversi-game-table
 474                                        :keystroke (:r :control)
 475                                        :menu ("Recommend Move"
 476                                               :after "New Game"
 477                                               :documentation "Recommend Move"))
 478     ()
 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)))
 486             (when pointer
 487               (setf (pointer-cursor pointer) :busy))
 488           (set-msgbar frame "Thinking...")
 489           (let ((move (funcall (iago 8) (gui-player-id player)
 490                                (board game))))
 491             (when pointer
 492               (setf (pointer-cursor pointer) :default))
 493             (when move
 494               (set-msgbar frame
 495                           (format nil "Recommend move to ~a"
 496                                   (symbol-name (88->h8 move))))))))))))
 497
 498 (define-command (com-reversi-backup :name "Backup Move"
 499                                     :command-table reversi-game-table
 500                                     :keystroke (:b :control)
 501                                     :menu ("Backup Move"
 502                                            :after "Recommend Move"
 503                                            :documentation "Backup Move"))
 504     ()
 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))))))
 509
 510
 511 (define-command (com-reversi-exit :name "Exit"
 512                                   :command-table reversi-game-table
 513                                   :keystroke (:q :control)
 514                                   :menu ("Exit"
 515                                          :after "Backup Move"
 516                                          :documentation "Quit application"))
 517     ()
 518   (clim:frame-exit clim:*application-frame*))
 519
 520
 521 (define-command (com-reversi-options :name "Game Options"
 522                                  :command-table reversi-game-table
 523                                  :menu ("Game Options" :documentation "Game Options"))
 524     ()
 525   (with-application-frame (frame)
 526     (game-dialog frame)))
 527
 528
 529
 530 ;(define-command-table reversi-game
 531 ;  :inherit-from (reversi-game-table)
 532 ;  :inherit-menu t)
 533
 534 ;(define-command-table reversi-help)
 535 ;    :inherit-from (reversi-help-commands)
 536 ;    :inherit-menu t)
 537
 538 (define-command (com-about :command-table reversi-help-table
 539                            :menu
 540                            ("About Reversi"
 541                             :after :start
 542                             :documentation "About Reversi"))
 543     ()
 544   t)
 545 ;;  (acl-clim::pop-up-about-climap-dialog *application-frame*))
 546
 547
 548
 549 (defun make-move-gui (game move player)
 550     (make-game-move game move player))
 551
 552 (defun get-move-gui (frame)
 553   (let ((gui-player (current-gui-player frame)))
 554     (when gui-player
 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)))))
 558
 559 (defun computer-move (gui-player frame)
 560   (let* ((game (reversi-game frame))
 561          (port (find-port))
 562          (pointer (port-pointer port)))
 563     (setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
 564     (when pointer
 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)
 571                                 (player game)
 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))
 578                (setf (player game)
 579                  (next-to-play (board game) (player game))))))
 580     (set-msgbar frame nil)
 581     (when pointer
 582       (setf (pointer-cursor pointer) :default)))
 583   (setq gui-player (current-gui-player frame))
 584
 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))
 588
 589
 590
 591
 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)))
 605
 606     (accepting-values (stream :own-window t
 607                               :label "Reversi Parameters")
 608       (setq minutes
 609         (accept 'integer
 610                 :stream stream
 611                 :prompt "Maximum minutes" :default minutes))
 612       (terpri stream)
 613       (format stream "White Player~%")
 614       (setq white-searcher
 615         (accept '(member :human :random :minimax :alpha-beta3)
 616                 :stream stream
 617                 :prompt "White Player Search" :default white-searcher))
 618       (terpri stream)
 619       (setq white-evaluator
 620         (accept '(member :difference :weighted :modified-weighted :iago)
 621                 :stream stream
 622                 :prompt "White Player Evaluator" :default white-evaluator))
 623       (terpri stream)
 624       (setq white-ply
 625         (accept 'integer
 626                 :stream stream
 627                 :prompt "White Ply" :default white-ply))
 628       (terpri stream)
 629       (terpri stream)
 630       (format stream "Black Player~%")
 631       (terpri stream)
 632       (setq black-searcher
 633         (accept '(member :human :random :minimax :alpha-beta3)
 634                 :stream stream
 635                 :prompt "Black Player Search" :default black-searcher))
 636       (terpri stream)
 637       (setq black-evaluator
 638         (accept '(member :difference :weighted :modified-weighted :iago)
 639                 :stream stream
 640                 :prompt "Black Player Evaluator" :default black-evaluator))
 641       (terpri stream)
 642             (setq black-ply
 643               (accept 'integer
 644                       :stream stream
 645                       :prompt "Black Ply" :default black-ply))
 646       (terpri stream)
 647       )
 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
 652                                          :ply white-ply))
 653     (setf (black-player frame) (make-gui-player :id black
 654                                          :searcher-id black-searcher
 655                                          :eval-id black-evaluator
 656                                          :ply black-ply))
 657     ))
 658
 659
 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)))
 664     (dotimes (i 8)
 665       (draw-text stream
 666                  (elt "abcdefgh" i)
 667                  (make-point
 668                   (+ label-width (* cell-width i)
 669                      half-cell-inner-width)
 670                   0)
 671                  :align-x :center :align-y :top))
 672     (dotimes (i 8)
 673       (draw-text stream
 674                  (format nil "~d" (1+ i))
 675                  (make-point
 676                   0
 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)
 683         (dotimes (row 8)
 684           (formatting-row (stream)
 685             (dotimes (column 8)
 686               (let* ((cell-id (square-number row column))
 687                      (value
 688                       (if game
 689                           (bref (board game) cell-id)
 690                         empty)))
 691                 (updating-output (stream :unique-id cell-id
 692                                          :cache-value value)
 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)
 697                       (cond
 698                        ((= value black)
 699                         (draw-circle*
 700                          stream
 701                          half-cell-inner-width
 702                          half-cell-inner-height
 703                          piece-radius :filled t :ink +black+))
 704                        ((= value white)
 705                         (draw-circle*
 706                          stream
 707                          half-cell-inner-width
 708                          half-cell-inner-height
 709                          piece-radius :filled t :ink +white+))))))))))))))
 710
 711
 712