+;;;;***************************************************************************
+;;;;
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: io-clim.cl
+;;;; Purpose: CLIM GUI for reversi
+;;;; Programer: Kevin M. Rosenberg, M.D.
+;;;; Date Started: 1 Nov 2001
+;;;; CVS Id: $Id: io-clim.lisp,v 1.1 2002/10/25 08:36:42 kevin Exp $
+;;;;
+;;;;***************************************************************************
+
+(in-package :reversi)
+
+(defparameter cell-inner-width 40)
+(defparameter cell-inner-height 40)
+(defparameter half-cell-inner-width 20)
+(defparameter half-cell-inner-height 20)
+(defparameter line-thickness 2)
+(defparameter piece-radius 16)
+(defparameter cell-width (+ line-thickness cell-inner-width))
+(defparameter cell-height (+ line-thickness cell-inner-height))
+(defparameter label-height 42)
+(defparameter label-width 42)
+
+(defparameter board-width (+ 30 (* 8 cell-width)))
+(defparameter board-height (+ 30 (* 8 cell-height)))
+
+(defparameter status-width 300)
+
+
+(defstruct (gui-player (:constructor make-gui-player-struct))
+ id name searcher eval ply strategy start-time
+ searcher-id eval-id)
+
+(defun make-gui-player (&key id name strategy searcher-id eval-id ply)
+ (let ((p (make-gui-player-struct :id id :ply ply
+ :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))))
+ (unless strategy
+ (cond
+ ((eq search-func #'human)
+ )
+ ((eq search-func #'random-strategy)
+ (setf (gui-player-strategy p) search-func))
+ (t
+ (setf (gui-player-strategy p)
+ (funcall search-func ply eval-func)))))
+ p))
+
+
+(defun gui-player-human? (gp)
+ (eql (gui-player-searcher-id gp) :human))
+
+(defun current-gui-player (frame)
+ (if frame
+ (aif (reversi-game frame)
+ (cond
+ ((null (player it))
+ nil)
+ ((= (player it) black)
+ (black-player frame))
+ ((= (player it) white)
+ (white-player frame))
+ (t
+ nil))
+ nil)
+ nil))
+
+(defun current-gui-player-human? (frame)
+ #+ignore
+ (aif (current-gui-player frame)
+ (gui-player-human? it)
+ nil)
+ (gui-player-human? (current-gui-player frame))
+ )
+
+(define-application-frame reversi ()
+ ((game :initform nil
+ :accessor reversi-game)
+ (minutes :initform 30
+ :accessor minutes)
+ (black-player :initform nil
+ :accessor black-player)
+ (white-player :initform nil
+ :accessor white-player)
+ (debug-messages :initform nil
+ :accessor debug-messages)
+ (msgbar-string :initform nil
+ :accessor msgbar-string)
+ (human-time-start :initform nil
+ :accessor reversi-human-time-start))
+ (:panes
+ (board :application
+ :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+
+ )
+ (status :application
+ :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)
+ (history :application
+ :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+
+ :end-of-page-action :scroll
+ :end-of-line-action :scroll)
+ (debug-window :application
+ :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
+ )
+ (msgbar :application
+ :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))
+ (:pointer-documentation nil)
+ (:command-table (reversi
+ :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"))))
+ (:menu-bar t)
+ (:layouts
+ (default
+ (horizontally ()
+ (vertically ()
+ (horizontally ()
+ board status)
+ msgbar
+ debug-window)
+ history)
+ ))
+ )
+
+ ;;(:spacing 3)
+
+(defmethod frame-standard-input ((reversi reversi))
+ (get-frame-pane reversi 'debug-window))
+
+(defmethod frame-standard-output ((reversi reversi))
+ (get-frame-pane reversi 'debug-window))
+
+(defmethod run-frame-top-level :before ((reversi reversi) &key)
+ (initialize-reversi reversi))
+
+
+(defmethod read-frame-command ((reversi reversi) &key (stream *standard-input*))
+ (let ((abort-chars #+Genera '(#\Abort #\End)
+ #-Genera nil))
+ (let ((command (read-command-using-keystrokes
+ (frame-command-table reversi) abort-chars
+ :stream stream)))
+ (if (characterp command)
+ (frame-exit reversi)
+ command))))
+
+(define-presentation-type reversi-cell ()
+ :inherit-from '(integer 11 88))
+
+#-lispworks
+(define-presentation-method highlight-presentation ((type reversi-cell)
+ record stream state)
+ state
+ (multiple-value-bind (xoff yoff)
+ (convert-from-relative-to-absolute-coordinates
+ stream (output-record-parent record))
+ (with-bounding-rectangle* (left top right bottom) record
+ (draw-rectangle* stream
+ (+ left xoff) (+ top yoff)
+ (+ right xoff) (+ bottom yoff)
+ :ink +flipping-ink+))))
+
+(define-reversi-command com-select-cell ((move 'reversi-cell))
+ (with-application-frame (frame)
+ (with-slots (game) frame
+ (let ((gui-player (current-gui-player 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))))))))
+
+
+(define-presentation-to-command-translator select-cell
+ (reversi-cell com-select-cell reversi
+ :documentation "Select cell"
+ :tester ((object frame window) (cell-selectable-p object frame window)))
+ (object)
+ (list object))
+
+(defun cell-selectable-p (object frame window)
+ (when (and (eq (get-frame-pane frame 'board) window)
+ (reversi-game frame))
+ (let ((game (reversi-game frame)))
+ (if (legal-p object (player game) (board game))
+ t
+ nil))))
+
+
+
+(defun new-game-gui (frame)
+ (setf (reversi-game frame)
+ (make-game
+ (gui-player-strategy (black-player frame))
+ (gui-player-strategy (white-player frame))
+ :record-game t
+ :print nil
+ :minutes (minutes frame)))
+ (set-msgbar frame "New Game")
+ (get-move-gui frame))
+
+
+
+(defmethod initialize-reversi ((reversi reversi))
+ (setf (black-player reversi)
+ (make-gui-player :id black :searcher-id :human)
+ )
+ (setf (white-player reversi)
+ (make-gui-player :id white
+ :searcher-id :alpha-beta3
+ :eval-id :iago
+ :ply 5)))
+
+
+(defun square-number (row column)
+ (declare (fixnum row column))
+ (+ (* 10 (1+ row))
+ (1+ column)))
+
+(defmethod draw-status ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (let ((game (reversi-game reversi)))
+ (when game
+ (if (null (player 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)))
+ (format stream "Pieces~% ~a ~2d~% ~a ~2d~% Difference ~2d~2&"
+ (title-of black) (count black (board game))
+ (title-of white) (count white (board game))
+ (count-difference black (board game)))
+ (when (clock 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))))
+ (let ((gui-player (current-gui-player reversi)))
+ (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)))))))))
+
+
+
+(defmethod add-debug ((reversi reversi) msg)
+ (setf (debug-messages reversi) (append (debug-messages reversi) (list msg))))
+
+(defmethod set-msgbar ((reversi reversi) msg)
+ (setf (msgbar-string reversi) msg))
+
+(defmethod draw-debug-window ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (filling-output (stream)
+ (dolist (msg (debug-messages reversi))
+ (princ msg stream)
+ (terpri stream))))
+
+(defmethod draw-msgbar ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (when (msgbar-string reversi)
+ (princ (msgbar-string reversi) stream)))
+
+
+(defmethod draw-history ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (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))))))))))))
+
+#+ignore
+(defmethod draw-history ((reversi reversi) stream &key max-width max-height)
+ (declare (ignore max-width max-height))
+ (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))))))))))))
+
+
+#|
+ (let ((viewport (window-viewport 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))))))
+ |#
+
+
+
+
+(defvar *reversi-frame* nil)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *force*
+ #+(and os-threads microsoft-32)
+ t
+ #-(and os-threads microsoft-32)
+ nil))
+
+(defun g ()
+ (greversi))
+
+(defun greversi ()
+ (unless (or *force* (null *reversi-frame*))
+ (setq *reversi-frame* (make-application-frame 'reversi)))
+ (setq *reversi-frame* (run-frame 'reversi *reversi-frame*)))
+
+
+(defun run-frame (frame-name frame)
+ (flet ((do-it ()
+ (when (or *force* (null frame))
+ (setq frame (make-application-frame frame-name)))
+ (run-frame-top-level frame)))
+ #+allegro
+ (mp:process-run-function (write-to-string frame-name) #'do-it)
+ #-allegro
+ (do-it))
+ frame)
+
+
+(define-command-table reversi-game-table
+ :menu (("New" :command com-reversi-new)
+ ("Backup" :command (com-reversi-backup))
+ ("Exit" :command (com-reversi-exit))))
+
+(define-command-table reversi-help-table)
+
+
+(define-command (com-reversi-new :name "New Game"
+ :command-table reversi-game-table
+ :keystroke (:n :control)
+ :menu ("New Game"
+ :after :start
+ :documentation "New Game"))
+ ()
+ (with-application-frame (frame)
+ (new-game-gui frame)))
+
+(define-command (com-reversi-recommend :name "Recommend Move"
+ :command-table reversi-game-table
+ :keystroke (:r :control)
+ :menu ("Recommend Move"
+ :after "New Game"
+ :documentation "Recommend Move"))
+ ()
+ (with-application-frame (frame)
+ (let ((game (reversi-game frame))
+ (player (current-gui-player frame)))
+ (when (and game player)
+ (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))))))))))))
+
+(define-command (com-reversi-backup :name "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))
+ (reset-game game (- (move-number game) 2))))))
+
+
+(define-command (com-reversi-exit :name "Exit"
+ :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"
+ :command-table reversi-game-table
+ :menu ("Game Options" :documentation "Game Options"))
+ ()
+ (with-application-frame (frame)
+ (game-dialog frame)))
+
+
+
+;(define-command-table reversi-game
+; :inherit-from (reversi-game-table)
+; :inherit-menu t)
+
+;(define-command-table reversi-help)
+; :inherit-from (reversi-help-commands)
+; :inherit-menu t)
+
+(define-command (com-about :command-table reversi-help-table
+ :menu
+ ("About Reversi"
+ :after :start
+ :documentation "About Reversi"))
+ ()
+ t)
+;; (acl-clim::pop-up-about-climap-dialog *application-frame*))
+
+
+
+(defun make-move-gui (game move player)
+ (make-game-move game move 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)))))
+
+(defun computer-move (gui-player frame)
+ (let* ((game (reversi-game frame))
+ (port (find-port))
+ (pointer (port-pointer port)))
+ (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))))))
+ (set-msgbar frame nil)
+ (when pointer
+ (setf (pointer-cursor pointer) :default)))
+ (setq gui-player (current-gui-player frame))
+
+ (if (and gui-player (not (gui-player-human? gui-player)))
+ (redisplay-frame-pane frame (get-frame-pane frame 'board)))
+ (get-move-gui frame))
+
+
+
+
+(defun game-dialog (frame)
+ (let* ((stream (get-frame-pane frame 'debug-window))
+ ;; (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)))
+
+ (accepting-values (stream :own-window t
+ :label "Reversi Parameters")
+ (setq minutes
+ (accept 'integer
+ :stream stream
+ :prompt "Maximum minutes" :default minutes))
+ (terpri stream)
+ (format stream "White Player~%")
+ (setq white-searcher
+ (accept '(member :human :random :minimax :alpha-beta3)
+ :stream stream
+ :prompt "White Player Search" :default white-searcher))
+ (terpri stream)
+ (setq white-evaluator
+ (accept '(member :difference :weighted :modified-weighted :iago)
+ :stream stream
+ :prompt "White Player Evaluator" :default white-evaluator))
+ (terpri stream)
+ (setq white-ply
+ (accept 'integer
+ :stream stream
+ :prompt "White Ply" :default white-ply))
+ (terpri stream)
+ (terpri stream)
+ (format stream "Black Player~%")
+ (terpri stream)
+ (setq black-searcher
+ (accept '(member :human :random :minimax :alpha-beta3)
+ :stream stream
+ :prompt "Black Player Search" :default black-searcher))
+ (terpri stream)
+ (setq black-evaluator
+ (accept '(member :difference :weighted :modified-weighted :iago)
+ :stream stream
+ :prompt "Black Player Evaluator" :default black-evaluator))
+ (terpri stream)
+ (setq black-ply
+ (accept 'integer
+ :stream stream
+ :prompt "Black Ply" :default black-ply))
+ (terpri stream)
+ )
+ (setf (minutes frame) minutes)
+ (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))
+ ))
+
+
+(defmethod draw-board ((reversi reversi) stream &key max-width max-height)
+ "This should produce a checkerboard pattern."
+ (declare (ignore max-width max-height))
+ (let ((game (reversi-game reversi)))
+ (dotimes (i 8)
+ (draw-text stream
+ (elt "abcdefgh" i)
+ (make-point
+ (+ label-width (* cell-width i)
+ half-cell-inner-width)
+ 0)
+ :align-x :center :align-y :top))
+ (dotimes (i 8)
+ (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)
+ (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+))))))))))))))
+
+
+