;;;; Name: io-clim.lisp
;;;; Purpose: CLIM GUI for reversi
;;;; Programer: Kevin M. Rosenberg
;;;; Date Started: 1 Nov 2001
;;;;
;;;; Name: io-clim.lisp
;;;; Purpose: CLIM GUI for reversi
;;;; Programer: Kevin M. Rosenberg
;;;; Date Started: 1 Nov 2001
;;;;
;;;;
;;;; Reversi users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;;***************************************************************************
;;;;
;;;; Reversi users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;;***************************************************************************
- :name name :strategy strategy
- :searcher-id searcher-id :eval-id eval-id))
- (search-func
- (cond
- ((eq searcher-id :human)
- #'human)
- ((eq searcher-id :minimax)
- #'minimax-searcher)
- ((eq searcher-id :alpha-beta)
- #'alpha-beta-searcher)
- ((eq searcher-id :alpha-beta2)
- #'alpha-beta-searcher2)
- ((eq searcher-id :alpha-beta3)
- #'alpha-beta-searcher3)
- ((eq searcher-id :random)
- #'random-strategy)))
- (eval-func
- (cond
- ((eq eval-id :difference)
- #'count-difference)
- ((eq eval-id :weighted)
- #'weighted-squares)
- ((eq eval-id :modified-weighted)
- #'modified-weighted-squares)
- ((eq eval-id :iago)
- #'iago-eval))))
+ :name name :strategy strategy
+ :searcher-id searcher-id :eval-id eval-id))
+ (search-func
+ (cond
+ ((eq searcher-id :human)
+ #'human)
+ ((eq searcher-id :minimax)
+ #'minimax-searcher)
+ ((eq searcher-id :alpha-beta)
+ #'alpha-beta-searcher)
+ ((eq searcher-id :alpha-beta2)
+ #'alpha-beta-searcher2)
+ ((eq searcher-id :alpha-beta3)
+ #'alpha-beta-searcher3)
+ ((eq searcher-id :random)
+ #'random-strategy)))
+ (eval-func
+ (cond
+ ((eq eval-id :difference)
+ #'count-difference)
+ ((eq eval-id :weighted)
+ #'weighted-squares)
+ ((eq eval-id :modified-weighted)
+ #'modified-weighted-squares)
+ ((eq eval-id :iago)
+ #'iago-eval))))
- :display-function 'draw-board
- :text-style '(:sans-serif :bold :very-large)
-;; :incremental-redisplay t
- :text-cursor nil
- :background +green+
- :borders nil
- :scroll-bars nil
- :width (+ label-width board-width)
- :height (+ label-height board-height)
- :min-width board-width
- :min-height board-height
- :max-width +fill+
- :max-height +fill+
- )
+ :display-function 'draw-board
+ :text-style '(:sans-serif :bold :very-large)
+;; :incremental-redisplay t
+ :text-cursor nil
+ :background +green+
+ :borders nil
+ :scroll-bars nil
+ :width (+ label-width board-width)
+ :height (+ label-height board-height)
+ :min-width board-width
+ :min-height board-height
+ :max-width +fill+
+ :max-height +fill+
+ )
- :display-function 'draw-status
- :text-style '(:sans-serif :bold :large)
- :incremental-redisplay t
- :text-cursor nil
- :background +white+
- :scroll-bars nil
- :width status-width
- :max-width +fill+
- :max-height +fill+
- :height :compute)
+ :display-function 'draw-status
+ :text-style '(:sans-serif :bold :large)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background +white+
+ :scroll-bars nil
+ :width status-width
+ :max-width +fill+
+ :max-height +fill+
+ :height :compute)
- :display-function 'draw-history
- :text-style '(:fix :roman :normal)
- :incremental-redisplay t
- :text-cursor nil
- :background +white+
- :width 220
- :height :compute
- :min-width 100
- :initial-cursor-visibility :on
- :scroll-bars :vertical
- :max-width +fill+
- :max-height +fill+
+ :display-function 'draw-history
+ :text-style '(:fix :roman :normal)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background +white+
+ :width 220
+ :height :compute
+ :min-width 100
+ :initial-cursor-visibility :on
+ :scroll-bars :vertical
+ :max-width +fill+
+ :max-height +fill+
- :display-function 'draw-debug-window
- :text-style '(:serif :roman :normal)
- :incremental-redisplay t
- :text-cursor nil
- :background +white+
- :width :compute
- :height :compute
- :scroll-bars :vertical
- :max-width +fill+
- :max-height +fill+
- :end-of-page-action :scroll
- :end-of-line-action :scroll
- )
+ :display-function 'draw-debug-window
+ :text-style '(:serif :roman :normal)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background +white+
+ :width :compute
+ :height :compute
+ :scroll-bars :vertical
+ :max-width +fill+
+ :max-height +fill+
+ :end-of-page-action :scroll
+ :end-of-line-action :scroll
+ )
- :display-function 'draw-msgbar
- :text-style '(:sans-serif :roman :normal)
- :incremental-redisplay t
- :text-cursor nil
- :background (make-rgb-color 0.75 0.75 0.75)
- :foreground +red+
- :scroll-bars nil
- :width :compute
- :height 25
- :max-width +fill+
- :max-height +fill+
- :end-of-page-action :scroll
- :end-of-line-action :scroll))
+ :display-function 'draw-msgbar
+ :text-style '(:sans-serif :roman :normal)
+ :incremental-redisplay t
+ :text-cursor nil
+ :background (make-rgb-color 0.75 0.75 0.75)
+ :foreground +red+
+ :scroll-bars nil
+ :width :compute
+ :height 25
+ :max-width +fill+
+ :max-height +fill+
+ :end-of-page-action :scroll
+ :end-of-line-action :scroll))
- :inherit-from (user-command-table
- reversi-game-table
- reversi-help-table)
- :menu (("Game"
- :menu reversi-game-table
- :mnemonic #\G
- :documentation "Game commands")
- ("Help"
- :menu reversi-help-table
- :mnemonic #\H
- :documentation "Help Commands"))))
+ :inherit-from (user-command-table
+ reversi-game-table
+ reversi-help-table)
+ :menu (("Game"
+ :menu reversi-game-table
+ :keystroke #\G
+ :documentation "Game commands")
+ ("Help"
+ :menu reversi-help-table
+ :keystroke #\H
+ :documentation "Help Commands"))))
(defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
(let ((abort-chars #+Genera '(#\Abort #\End)
(defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
(let ((abort-chars #+Genera '(#\Abort #\End)
- (+ left xoff) (+ top yoff)
- (+ right xoff) (+ bottom yoff)
- :ink +flipping-ink+))))
+ (+ left xoff) (+ top yoff)
+ (+ right xoff) (+ bottom yoff)
+ :ink +flipping-ink+))))
- (when (and game gui-player (gui-player-human? gui-player))
- (if (not (legal-p move (gui-player-id gui-player) (board game)))
- (set-msgbar frame
- (format nil "Illegal move: ~a"
- (symbol-name (88->h8 move))))
- (progn
- (decf (elt (clock game) (player game))
- (- (get-internal-real-time) (gui-player-start-time gui-player)))
- (make-move-gui game move (gui-player-id gui-player))
- (setf (player game) (next-to-play (board game) (player game)))
- (get-move-gui frame))))))))
-
+ (when (and game gui-player (gui-player-human? gui-player))
+ (if (not (legal-p move (gui-player-id gui-player) (board game)))
+ (set-msgbar frame
+ (format nil "Illegal move: ~a"
+ (symbol-name (88->h8 move))))
+ (progn
+ (decf (elt (clock game) (player game))
+ (- (get-internal-real-time) (gui-player-start-time gui-player)))
+ (make-move-gui game move (gui-player-id gui-player))
+ (setf (player game) (next-to-play (board game) (player game)))
+ (get-move-gui frame))))))))
+
:documentation "Select cell"
:tester ((object frame window) (cell-selectable-p object frame window)))
(object)
:documentation "Select cell"
:tester ((object frame window) (cell-selectable-p object frame window)))
(object)
- (progn
- (setf (final-result game) (count-difference black (board game)))
- (format stream "Game Over~2%"))
- (format stream "Move Number ~d~2%" (move-number game)))
+ (progn
+ (setf (final-result game) (count-difference black (board game)))
+ (format stream "Game Over~2%"))
+ (format stream "Move Number ~d~2%" (move-number game)))
- (title-of black) (count black (board game))
- (title-of white) (count white (board game))
- (count-difference black (board game)))
+ (title-of black) (count black (board game))
+ (title-of white) (count white (board game))
+ (count-difference black (board game)))
- (format stream "Time Remaining~% ~a ~a~% ~a ~a~2%"
- (title-of black) (time-string (elt (clock game) black))
- (title-of white) (time-string (elt (clock game) white))))
+ (format stream "Time Remaining~% ~a ~a~% ~a ~a~2%"
+ (title-of black) (time-string (elt (clock game) black))
+ (title-of white) (time-string (elt (clock game) white))))
- (when (and gui-player (gui-player-human? gui-player))
- (let ((legal-moves
- (loop for move in (legal-moves (gui-player-id gui-player)
- (board game))
- collect (symbol-name (88->h8 move)))))
- (if legal-moves
- (format stream "Valid Moves~%~A"
- (list-to-delimited-string legal-moves #\space)))))
- (when (null (player game))
- (if (plusp (final-result game))
- (format stream "Black wins by ~d!" (final-result game))
- (format stream "White wins by ~d!" (- 0 (final-result game)))))))))
+ (when (and gui-player (gui-player-human? gui-player))
+ (let ((legal-moves
+ (loop for move in (legal-moves (gui-player-id gui-player)
+ (board game))
+ collect (symbol-name (88->h8 move)))))
+ (if legal-moves
+ (format stream "Valid Moves~%~A"
+ (list-to-delimited-string legal-moves #\space)))))
+ (when (null (player game))
+ (cond
+ ((zerop (final-result game))
+ (format stream "It's a draw!"))
+ ((plusp (final-result game))
+ (format stream "Black wins by ~d!" (final-result game)))
+ (t
+ (format stream "White wins by ~d!" (- 0 (final-result game))))))))))
(let ((game (reversi-game reversi)))
(when (and game (> (move-number game) 1))
(formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 1)
(let ((game (reversi-game reversi)))
(when (and game (> (move-number game) 1))
(formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 1)
- (dotimes (i (1- (move-number game)))
- (let ((state (aref (moves game) i)))
- (when state
- (let ((str (format nil "~2d: ~5a ~2a"
- (1+ i) (title-of (state-player state))
- (88->h8 (state-move state)))))
- (updating-output (stream :unique-id i :cache-value str)
- (with-end-of-page-action (stream :scroll)
- (formatting-cell (stream :align-x :right :align-y :top)
- (format stream str)
- (terpri stream))))))))))))
+ (dotimes (i (1- (move-number game)))
+ (let ((state (aref (moves game) i)))
+ (when state
+ (let ((str (format nil "~2d: ~5a ~2a"
+ (1+ i) (title-of (state-player state))
+ (88->h8 (state-move state)))))
+ (updating-output (stream :unique-id i :cache-value str)
+ (with-end-of-page-action (stream :scroll)
+ (formatting-cell (stream :align-x :right :align-y :top)
+ (format stream str)
+ (terpri stream))))))))))))
(let ((game (reversi-game reversi)))
(when (and game (> (move-number game) 1))
(formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 2)
(let ((game (reversi-game reversi)))
(when (and game (> (move-number game) 1))
(formatting-item-list (stream :move-cursor t :row-wise nil :n-columns 2)
- (dotimes (i (1- (move-number game)))
- (let ((state (aref (moves game) i)))
- (when state
- (let ((str (format nil "~2d: ~5a ~2a"
- (1+ i) (title-of (state-player state))
- (88->h8 (state-move state)))))
- (updating-output (stream :unique-id i :cache-value str)
- (with-end-of-page-action (stream :scroll)
- (formatting-cell (stream :align-x :right :align-y :top)
- (format stream str)
- (terpri stream))))))))))))
+ (dotimes (i (1- (move-number game)))
+ (let ((state (aref (moves game) i)))
+ (when state
+ (let ((str (format nil "~2d: ~5a ~2a"
+ (1+ i) (title-of (state-player state))
+ (88->h8 (state-move state)))))
+ (updating-output (stream :unique-id i :cache-value str)
+ (with-end-of-page-action (stream :scroll)
+ (formatting-cell (stream :align-x :right :align-y :top)
+ (format stream str)
+ (terpri stream))))))))))))
- (multiple-value-bind (x y) (stream-cursor-position stream)
- (add-debug reversi (format nil "~d ~d: ~s" x y viewport))
- (if (> y (bounding-rectangle-bottom viewport))
- (decf y (bounding-rectangle-bottom viewport)))
- (window-set-viewport-position stream 0 0))))))
- |#
-
-
+ (multiple-value-bind (x y) (stream-cursor-position stream)
+ (add-debug reversi (format nil "~d ~d: ~s" x y viewport))
+ (if (> y (bounding-rectangle-bottom viewport))
+ (decf y (bounding-rectangle-bottom viewport)))
+ (window-set-viewport-position stream 0 0))))))
+ |#
+
+
- (when (or *force* (null frame))
- (setq frame (make-application-frame frame-name)))
- (run-frame-top-level frame)))
+ (when (or *force* (null frame))
+ (setq frame (make-application-frame frame-name)))
+ (run-frame-top-level frame)))
- :command-table reversi-game-table
- :keystroke (:n :control)
- :menu ("New Game"
- :after :start
- :documentation "New Game"))
+ :command-table reversi-game-table
+ :keystroke (:n :control)
+ :menu ("New Game"
+ :after :start
+ :documentation "New Game"))
- :command-table reversi-game-table
- :keystroke (:r :control)
- :menu ("Recommend Move"
- :after "New Game"
- :documentation "Recommend Move"))
+ :command-table reversi-game-table
+ :keystroke (:r :control)
+ :menu ("Recommend Move"
+ :after "New Game"
+ :documentation "Recommend Move"))
- (when (gui-player-human? player)
- (let* ((port (find-port))
- (pointer (port-pointer port)))
- (when pointer
- (setf (pointer-cursor pointer) :busy))
- (set-msgbar frame "Thinking...")
- (let ((move (funcall (iago 8) (gui-player-id player)
- (board game))))
- (when pointer
- (setf (pointer-cursor pointer) :default))
- (when move
- (set-msgbar frame
- (format nil "Recommend move to ~a"
- (symbol-name (88->h8 move))))))))))))
+ (when (gui-player-human? player)
+ (let* ((port (find-port))
+ (pointer (port-pointer port)))
+ (when pointer
+ (setf (pointer-cursor pointer) :busy))
+ (set-msgbar frame "Thinking...")
+ (let ((move (funcall (iago 8) (gui-player-id player)
+ (board game))))
+ (when pointer
+ (setf (pointer-cursor pointer) :default))
+ (when move
+ (set-msgbar frame
+ (format nil "Recommend move to ~a"
+ (symbol-name (88->h8 move))))))))))))
- :command-table reversi-game-table
- :keystroke (:b :control)
- :menu ("Backup Move"
- :after "Recommend Move"
- :documentation "Backup Move"))
+ :command-table reversi-game-table
+ :keystroke (:b :control)
+ :menu ("Backup Move"
+ :after "Recommend Move"
+ :documentation "Backup Move"))
()
(with-application-frame (frame)
(let ((game (reversi-game frame)))
(when (and game (> (move-number game) 2))
()
(with-application-frame (frame)
(let ((game (reversi-game frame)))
(when (and game (> (move-number game) 2))
- :command-table reversi-game-table
- :keystroke (:q :control)
- :menu ("Exit"
- :after "Backup Move"
- :documentation "Quit application"))
+ :command-table reversi-game-table
+ :keystroke (:q :control)
+ :menu ("Exit"
+ :after "Backup Move"
+ :documentation "Quit application"))
()
(clim:frame-exit clim:*application-frame*))
(define-command (com-reversi-options :name "Game Options"
()
(clim:frame-exit clim:*application-frame*))
(define-command (com-reversi-options :name "Game Options"
(defun get-move-gui (frame)
(let ((gui-player (current-gui-player frame)))
(when gui-player
(if (gui-player-human? gui-player)
(defun get-move-gui (frame)
(let ((gui-player (current-gui-player frame)))
(when gui-player
(if (gui-player-human? gui-player)
- (setf (gui-player-start-time gui-player) (get-internal-real-time))
- (computer-move gui-player frame)))))
+ (setf (gui-player-start-time gui-player) (get-internal-real-time))
+ (computer-move gui-player frame)))))
(setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
(when pointer
(setf (pointer-cursor pointer) :busy))
(set-msgbar frame "Thinking...")
(while (eq gui-player (current-gui-player frame))
(setq pointer nil) ;; pointer causes crash in CLIM. ? port value wrong
(when pointer
(setf (pointer-cursor pointer) :busy))
(set-msgbar frame "Thinking...")
(while (eq gui-player (current-gui-player frame))
- (setf (gui-player-start-time gui-player)
- (get-internal-real-time))
- (let ((move (funcall (gui-player-strategy gui-player)
- (player game)
- (replace-board *board* (board game)))))
- (when (and move (legal-p move (player game) (board game)))
- (decf (elt (clock game) (player game))
- (- (get-internal-real-time)
- (gui-player-start-time gui-player)))
- (make-move-gui game move (player game))
- (setf (player game)
- (next-to-play (board game) (player game))))))
+ (setf (gui-player-start-time gui-player)
+ (get-internal-real-time))
+ (let ((move (funcall (gui-player-strategy gui-player)
+ (player game)
+ (replace-board *board* (board game)))))
+ (when (and move (legal-p move (player game) (board game)))
+ (decf (elt (clock game) (player game))
+ (- (get-internal-real-time)
+ (gui-player-start-time gui-player)))
+ (make-move-gui game move (player game))
+ (setf (player game)
+ (next-to-play (board game) (player game))))))
- ;; (white-strategy-id (white-strategy-id frame)
- ;; (black-strategy-id (black-strategy-id frame))
- (wh (white-player frame))
- (bl (black-player frame))
- (white-searcher (gui-player-searcher-id wh))
- (white-evaluator (gui-player-eval-id wh))
- (white-ply (gui-player-ply wh))
- (black-searcher (gui-player-searcher-id bl))
- (black-evaluator (gui-player-eval-id bl))
- (black-ply (gui-player-ply bl))
- (minutes (minutes frame)))
-
+ ;; (white-strategy-id (white-strategy-id frame)
+ ;; (black-strategy-id (black-strategy-id frame))
+ (wh (white-player frame))
+ (bl (black-player frame))
+ (white-searcher (gui-player-searcher-id wh))
+ (white-evaluator (gui-player-eval-id wh))
+ (white-ply (gui-player-ply wh))
+ (black-searcher (gui-player-searcher-id bl))
+ (black-evaluator (gui-player-eval-id bl))
+ (black-ply (gui-player-ply bl))
+ (minutes (minutes frame)))
+
- (accept '(member :human :random :minimax :alpha-beta3)
- :stream stream
- :prompt "White Player Search" :default white-searcher))
+ (accept '(member :human :random :minimax :alpha-beta3)
+ :stream stream
+ :prompt "White Player Search" :default white-searcher))
- (accept '(member :difference :weighted :modified-weighted :iago)
- :stream stream
- :prompt "White Player Evaluator" :default white-evaluator))
+ (accept '(member :difference :weighted :modified-weighted :iago)
+ :stream stream
+ :prompt "White Player Evaluator" :default white-evaluator))
- (accept '(member :human :random :minimax :alpha-beta3)
- :stream stream
- :prompt "Black Player Search" :default black-searcher))
+ (accept '(member :human :random :minimax :alpha-beta3)
+ :stream stream
+ :prompt "Black Player Search" :default black-searcher))
- (accept '(member :difference :weighted :modified-weighted :iago)
- :stream stream
- :prompt "Black Player Evaluator" :default black-evaluator))
+ (accept '(member :difference :weighted :modified-weighted :iago)
+ :stream stream
+ :prompt "Black Player Evaluator" :default black-evaluator))
- (setf (white-player frame) (make-gui-player :id white
- :searcher-id white-searcher
- :eval-id white-evaluator
- :ply white-ply))
- (setf (black-player frame) (make-gui-player :id black
- :searcher-id black-searcher
- :eval-id black-evaluator
- :ply black-ply))
+ (setf (white-player frame) (make-gui-player :id white
+ :searcher-id white-searcher
+ :eval-id white-evaluator
+ :ply white-ply))
+ (setf (black-player frame) (make-gui-player :id black
+ :searcher-id black-searcher
+ :eval-id black-evaluator
+ :ply black-ply))
- (draw-text stream
- (format nil "~d" (1+ i))
- (make-point
- 0
- (+ label-height (* cell-height i)
- half-cell-inner-height))
- :align-x :left :align-y :center))
+ (draw-text stream
+ (format nil "~d" (1+ i))
+ (make-point
+ 0
+ (+ label-height (* cell-height i)
+ half-cell-inner-height))
+ :align-x :left :align-y :center))
(stream-set-cursor-position stream label-width label-height)
(surrounding-output-with-border (stream)
(formatting-table (stream :y-spacing 0 :x-spacing 0)
(stream-set-cursor-position stream label-width label-height)
(surrounding-output-with-border (stream)
(formatting-table (stream :y-spacing 0 :x-spacing 0)
- (dotimes (row 8)
- (formatting-row (stream)
- (dotimes (column 8)
- (let* ((cell-id (square-number row column))
- (value
- (if game
- (bref (board game) cell-id)
- empty)))
- (updating-output (stream :unique-id cell-id
- :cache-value value)
- (formatting-cell (stream :align-x :right :align-y :top)
- (with-output-as-presentation (stream cell-id 'reversi-cell)
- (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
- (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
- (cond
- ((= value black)
- (draw-circle*
- stream
- half-cell-inner-width
- half-cell-inner-height
- piece-radius :filled t :ink +black+))
- ((= value white)
- (draw-circle*
- stream
- half-cell-inner-width
- half-cell-inner-height
- piece-radius :filled t :ink +white+))))))))))))))
+ (dotimes (row 8)
+ (formatting-row (stream)
+ (dotimes (column 8)
+ (let* ((cell-id (square-number row column))
+ (value
+ (if game
+ (bref (board game) cell-id)
+ empty)))
+ (updating-output (stream :unique-id cell-id
+ :cache-value value)
+ (formatting-cell (stream :align-x :right :align-y :top)
+ (with-output-as-presentation (stream cell-id 'reversi-cell)
+ (draw-rectangle* stream 0 0 cell-width cell-height :filled t :ink +green+)
+ (draw-rectangle* stream 0 0 cell-width cell-height :filled nil)
+ (cond
+ ((= value black)
+ (draw-circle*
+ stream
+ half-cell-inner-width
+ half-cell-inner-height
+ piece-radius :filled t :ink +black+))
+ ((= value white)
+ (draw-circle*
+ stream
+ half-cell-inner-width
+ half-cell-inner-height
+ piece-radius :filled t :ink +white+))))))))))))))