;;;; Connect 4 game by David Christiansen
(defpackage connect4
  (:nicknames :connect4)
  (:use :common-lisp-user :clim :clim-lisp)
  (:export run-connect4))

(in-package :connect4)

;;; Establish various options prior to evaluating forms that depend on
;;; them.  Think of this section as being analogous to a C program's
;;; config.h file.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (declaim (optimize (speed 3) (safety 0) (debug 0)))
  (defparameter *cols* 7)
  (defparameter *rows* 6)
  ;; I have empirically determined that searches to a depth of seven
  ;; always take less that 30 seconds on my computer.  This number can
  ;; be modified to adjust the difficulty of the game.
  (defparameter *default-depth* 7)
  (proclaim '(type (integer 0 30) *rows* *cols* *default-depth*))
  (defconstant infinity 5000)
  (defparameter *piece-radius* 20)
  (proclaim '(type (integer 0 50) *piece-radius*))
  (defparameter *player-colors* (list +BLUE+ +RED+ +BLACK+)))


;;;; Implementing basic data structures.

;;; Basic error to act as a superclass.
(define-condition game-error () ()
  (:documentation "Superclass not meant to be instantiated.")
  (:report (lambda (condition stream)
             (declare (ignore condition))
             (format stream "An error has occurred with the game."))))

;;; Error object representing an illegal move.
(define-condition invalid-move (game-error)
  ((where :initarg :at :reader invalid-move-at))
  (:documentation "Condition to represent an illegal move.")
  (:report (lambda (condition stream)
             (format stream "~A is an invalid move."
                     (invalid-move-at condition)))))


;;; Structure representing a board.  Basically an array of pieces with
;;; some book keeping stuff for efficiency reasons.
(defstruct board
  "Connect Four board structure"
  (pieces (make-array `(,*rows* ,*cols* )  ;`(,*rows* ,*cols*)
                                :initial-element 0
                                :element-type '(integer 0 2)))
          ;:type (array fixnum `(,*rows* ,*cols*)))
  (remaining-moves (* *rows* *cols*) :type (integer 0 100))
  (tops (make-array *cols* :initial-element 0 :element-type '(integer 0 50))
        :type (array (integer 0 50))))

;;; Convenience function to make later code more readable.
(declaim (inline col-top))
(defun col-top (board col)
  "Return the index of the top piece in a column."
  (aref (board-tops board) col))


(defun move (board col player)
  "Drop a piece into the specified column.  If the column is
  full, generate an instance of INVALID-MOVE."
  (let ((row (aref (board-tops board) col)))
    (if (>= row *rows*)
        (error 'invalid-move :at col)
        (progn (setf (aref (board-pieces board) row col) player)
               (incf (aref (board-tops board) col))
               (decf (board-remaining-moves board))
               (1- (aref (board-tops board) col))))))


(defun unmove (board col)
  "Back out the top move in a given column."
  (with-slots (pieces tops remaining-moves) board
    (when (/= (aref tops col) 0)
      (decf (aref tops col))
      (incf remaining-moves)
      (setf (aref pieces (aref tops col) col) 0))))


(defun print-board (board &optional (stream t))
  "Nicely table-formats a board configuration and dumps it to a stream."
  (loop for i from (1- *rows*) downto 0
       do (progn (loop for j from 0 to (1- *cols*)
                      do (format stream " ~A " (aref (board-pieces board) i j)))
                 (format stream "~%"))))


;;; Function checks to see if column is full.
(defun valid-move-p (board col)
  "Returns t if a column has spaces open, nil otherwise."
  (< (aref (board-tops board) col) *rows*))
(declaim (inline valid-move-p))


;;;; Functions related to game rules and semantics

(defun drawp (board)
  "Checks a board for a draw"
  (loop for c from 0 to (1- *cols*)
       always (/= (aref (board-pieces board) (1- *rows*) c) 0)))


(defun winning-piece-p (board row col)
  "Checks whether the piece at a particular index into a board is part
  of a winner.  Checking the whole board is usually not required."
  (let ((num-seen 0)
        (num-seen-d1 0)
        (num-seen-d2 0)
        (piece (aref (board-pieces board) row col)))
    ;;Check vertically
    (loop for r from 0 to (1- *rows*)
       do (progn (if (= (aref (board-pieces board) r col) piece)
                     (incf num-seen)
                     (setq num-seen 0))
                 (when (>= num-seen 4) (return-from winning-piece-p t))))
    ;;Check diagonals and horizontally.  Row nums are functions of col nums.
    (setq num-seen 0)
    (loop for c from 0 to (1- *cols*)
       for r1 = (+ c (- row col))
       for r2 = (- (+ row col) c)
       do (progn (if (and (<= 0 r1 (1- *rows*))
                          (= (aref (board-pieces board) r1 c) piece))
                     (incf num-seen-d1)
                     (setq num-seen-d1 0))
                 (if (and (<= 0 r2 (1- *rows*))
                          (= (aref (board-pieces board) r2 c) piece))
                     (incf num-seen-d2)
                     (setq num-seen-d2 0))
                 (if (= (aref (board-pieces board) row c) piece)
                     (incf num-seen)
                     (setq num-seen 0))
                 (when (or (>= num-seen-d1 4) (>= num-seen-d2 4)
                           (>= num-seen 4))
                   (return-from winning-piece-p t)))))
  ;;If none succeed, eval to nil
  nil)



;;;; Searches and such.  The agent.


;;; I noticed that the goodness function contained a lot of
;;; nearly-identical loops and decided to factor them out into this
;;; macro.  The first parameter is a list of things that initialize
;;; the looping (like for and such), the second is the form to
;;; evaluate to get the current one (presumably based on the looping
;;; keywords from the first arg), and the optional third argument is a
;;; condition that is tested before binding current and, if true,
;;; causes the loop to terminate and return the current score.  THIS
;;; MACRO IS NOT GENERAL UTILITY!  EXPANSIONS CONTAIN NASTY FREE
;;; VARIABLES!
(defmacro goodness-loop ((&rest loop-keywords-for-init)
                         current-form
                         &optional bail-form)
  `(loop
      ,@loop-keywords-for-init
      with score = 0.0
      ,@(if bail-form `(when ,bail-form return score) nil)
      do (let ((current ,current-form))
           (cond ((= current player) (incf score))
                 ((= current 0) (return (+ score .25)))
                 (t (return score))))
      finally (return score)))


;;; The score is the sum of the scores for horizonal, vertical, and
;;; diagonal directions.  The score for a direction is the number of
;;; pieces in a row belonging to the player in a direction and 3/4 the
;;; number of empty pieces at each end of the row.  Four pieces in a
;;; row has the arbitrary score of 10, and so does three in a row with
;;; a blank on each end, as these are guaranteed wins.  This function
;;; is long and repetetive, and would be much worse if not for the
;;; above helper macro.
(defun goodness (board row col)
  "Return the utility of a particular piece for its owner."
  (when (winning-piece-p board row col) (return-from goodness infinity))
  (let* ((player (aref (board-pieces board) row col))
         (score-h
          (+ (goodness-loop (for c from (1- col) downto 0)
                            (aref (board-pieces board) row c))
              1 ;the current piece
             (goodness-loop (for c from (1+ col) to (1- *cols*))
                            (aref (board-pieces board) row c))))
         (score-v
          (+ (goodness-loop (for r from (1- row) downto 0)
                            (aref (board-pieces board) r col))
             1 ;current piece
             (goodness-loop (for r from (1+ row) to (1- *rows*))
                            (aref (board-pieces board) r col))))
         (score-d1
          (+ (goodness-loop (for c from (1- col) downto 0
                             for r = (+ c (- row col)))
                            (aref (board-pieces board) r c)
                            (< r 0))
             1
             (goodness-loop (for c from (1+ col) to (1- *cols*)
                             for r = (+ c (- row col)))      ;row as function of col
                            (aref (board-pieces board) r c)
                            (>= r *rows*))))
         (score-d2
          (+ (goodness-loop (for c from (1- col) downto 0
                             for r = (- (+ row col) c))      ;row a func of col again
                            (aref (board-pieces board) r c)
                            (>= r *rows*))
             1
             (goodness-loop (for c from (1+ col) to (1- *cols*)
                             for r = (- (+ row col) c))
                            (aref (board-pieces board) r c)
                            (< r 0)))))
         (flet ((eval-score (score)
                  (if (>= score 4.0) infinity score)))
           (+ (eval-score score-h)
              (eval-score score-v)
              (eval-score score-d1)
              (eval-score score-d2)))))



;;; Random opponent.  DEPTH argument included to allow for a future
;;; generic agent interface.
(defun random-move (board player depth)
  "Return a random move."
  (declare (ignore depth))
  (let ((move (random (1- *cols*))))
    (if (valid-move-p board move)
        (progn (move board move player) move)
        (loop for c from 0 to *cols*
           when (valid-move-p board c)
           do (progn (move board c player) c)
           finally (error "No moves found.")))))


(declaim (inline other-player))
(defun other-player (p)
  "When passed a player number, other-player returns the opposite."
  (if (= p 1) 2 1))


(defun state-goodness (board player)
  "Loop across a state considering all possible moves for PLAYER.
  Return the score of the best one found and the location of it."
  (let ((best-score 0) (best-move 3))
    (loop for c from 0 to (1- *cols*)
       when (valid-move-p board c)
       do (let ((this-score ;score for this column
                 ;; The unwind-protect form makes sure that unmove gets called even
                 ;; if there is a nonlocal exit
                 (unwind-protect
                      (let ((r (move board c player)))
                        (goodness board r c)) ;this value returned from unwind-protect
                   (unmove board c))))
            (when (> this-score best-score)
              (setq best-score this-score
                    best-move c))))
    (values best-score best-move)))


;;; Minmax algorithm.  Because good for one player is bad for the
;;; other, minmax can be transformed into a single function that
;;; negates the result of the recursive call.  An optional depth
;;; argument may be supplied. The keyword :bail-out-time causes the
;;; search to terminate at a particular time, returning a bogus, tiny
;;; little value.
(defun minmax (board player &optional (depth *default-depth*)
               (alpha (- infinity)) (beta infinity) (bail-out-time 100 bail-p))
  "Perform alpha-beta minmax search on BOARD starting with PLAYER.  If
  the BAIL-OUT-TIME is given, get out quickly when that time is
  exceeded."
  ;;If max time exceeded, bail out.  Note that bail-p is true iff the
  ;;final optional argument was provided. Callers using bail-out-time
  ;;must establish a catch for the 'too-long tag.  This feature is not
  ;;currently used, but can be used to implement time-limited bail-out.
  (when (and bail-p (> (get-internal-real-time) bail-out-time)
             (throw 'too-long (values nil nil))))
  ;; If a leaf in the search tree, return score and location of
  ;; best move,
  (if (or (<= depth 0)
          (= (board-remaining-moves board) 2))
      (state-goodness board player)
      ;; Otherwise, recurse.
      (loop for m from 0 to (1- *cols*)
         with where = 0
         ;; For each valid move, make the move, evaluate it, then unmake it
         when (valid-move-p board m)
         do (let ((score (unwind-protect
                              (progn (move board m player)
                                     ;; If a win, prune tree.  Otherwise, recurse.
                                     (if (winning-piece-p board (1- (col-top board m)) m)
                                         (values (- infinity 1) m)
                                         (- (minmax board (other-player player)
                                                    (1- depth)
                                                    (- beta) (- alpha)))))
                           (unmove board m))))
              (when (> score alpha) (setq alpha score
                                      where m))
              (when (>= alpha beta) (return-from minmax (values alpha where))))
         finally (return (values alpha where)))))


;;;; Graphical Object Definitions & Methods

;;; This class' usefulness is solely in being different in identity from
;;; the default view.
(defclass board-view (view)
  ()
  (:documentation "Simple view class used to distinguish board panes from others."))
(defparameter *board-view* (make-instance 'board-view)
  "Instance of BOARD-VIEW used in drawing functions.")


;;; This is the major window for the application.  It has slots representing
;;; the state of the game, such as the board and whose turn it is.  It also
;;; contains the panes that represent this state to the user.
(define-application-frame connect4-frame ()
  ;;Slots:
  ((turn :accessor turn :initform 1) ;Whose turn is it?
   ;;Holds the array representing the board state
   (board :initform (make-board)
         :accessor connect4-frame-board)
   ;;String holding the status message
   (status-msg :initform "Player 1." :accessor status-msg)
   ;;Boolean value that is false when a game is in progress and the number
   ;; of the winning player when it has been won.  If a draw has occurred,
   ;; it is set to the symbol DRAW.
   (game-won :accessor game-won :initform nil)
   ;;Cons cell holding players one and two, identified either by a function
   ;; returning two values: a score and a 0-indexed column to move to, or
   ;; the symbol PLAYER denoting that a human is playing that role.
   (players :accessor players :initform (cons 'human 'human)))
  (:panes
   (player1-menu (make-pane 'option-pane
                            :id :p1-menu
                            :value "Human"
                            :mode :one-of
                            :items '("Human" "Random" "Search")
                            :test 'string=))
   (player2-menu (make-pane 'option-pane
                            :id :p2-menu
                            :mode :one-of
                            :value "Human"
                            :items '("Human" "Random" "Search")))
   (go-button (make-pane 'push-button-pane
                         :id :go-button
                         :label "Go!"
                         :show-as-default t
                         :activate-callback 'next-move))
   ;;The graphical display of the board
   (board-pane :application
               :default-view '+board-view+
               :background +yellow+
               :scroll-bars nil
               :display-function 'board-pane-redisplay
               :incremental-redisplay t)
   ;;The line telling players state such as invalid moves and whose turn
   ;; it is
   (status-pane :stream
                :scroll-bars nil
                :incremental-redisplay t
                :display-function 'status-pane-redisplay)
   ;;The context-sensitive help menu at the bottom
   (pointer-help :pointer-documentation))
  ;;Stack panes vertically
  (:layouts (default
                (vertically (:width 310)
                  (25 (horizontally (:x-spacing 3 :y-spacing 3)
                        (2/5 player1-menu)
                        (2/5 player2-menu)
                        (1/5 go-button)))
                  (275 board-pane)
                  (25 status-pane)
                  (50 pointer-help)))))


;;; These are the callbacks that cause the change in application state
;;; when menu options are selected.  Unfortunately, I needed to write
;;; two nearly identical functions because specialization occurs with
;;; an EQL specializer and writing a combined gadget is overkill.
(defmethod value-cHanged-callback :after
    (option-pane client (id (eql :p1-menu)) val)
  (declare (ignore client option-pane))
  (with-slots (players) *application-frame*
    (setf (car players)
          (cdr (assoc val
                      '(("Human" . human)
                        ("Random" . random)
                        ("Search" . search))
                      :test #'string=)))))
(defmethod value-changed-callback :after
    (option-pane client (id (eql :p2-menu)) val)
  (declare (ignore client option-pane))
  (with-slots (players) *application-frame*
    (setf (cdr players)
          (cdr (assoc val
                      '(("Human" . human)
                        ("Random" . random)
                        ("Search" . search))
                      :test #'string=)))))


;;; This is the callback function for the "Go!" button. It selects the
;;; appropriate action to take based on the current state.
(defun next-move (button)
  "Callback for `Go!' button."
  (declare (ignore button))
  (with-slots (players turn) *application-frame*
    (let ((who (if (= turn 1) (car players) (cdr players))))
      (case who
        ((human)
         (update-status-msg *application-frame*
                            (format nil "Player ~A: Click a column to move."
                                    turn)))
        ((random)
         (com-move (+ (random (1- *cols*)) 1)))
        ((search)
         (with-slots (board turn) *application-frame*
           (multiple-value-bind (score where)
               (minmax board turn)
             (declare (ignore score))
             (com-move (+ where 1)))))
        (t (update-status-msg *application-frame*
                              "unimplemented")))
      ;;Redisplay is called because normally status is updated only by
      ;; the command loop.
      (redisplay-frame-panes *application-frame*))))


;;; A presentation type for columns, allowing them to be accepted properly
;;; by commands.
(define-presentation-type column ()
  :inherit-from `(integer 1 ,*cols*))


;;; How to draw columns to a text stream
(define-presentation-method present
    (object (type column) stream (view textual-view)
            &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (format stream "Column ~A" object))


;;; How to draw columns to the boad pane
(define-presentation-method present
    (object (type column) stream (view board-view)
            &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (draw-column *application-frame*
               stream
               object))


;;; This is the function that draws the board into the window.  It is
;;; called automatically when needed.
(defmethod board-pane-redisplay ((frame connect4-frame) pane)
  (loop for x from 1 to *cols*
     do (present x 'column :stream pane :view *board-view*)))


;;; This is the function that writes the status to the status line.
;;; It is called when needed.
(defmethod status-pane-redisplay ((frame connect4-frame) pane)
  (format pane (status-msg frame)))


;;; This function resets the state held in the application frame.
(defmethod initialize-frame ((frame connect4-frame))
  (update-status-msg frame "Player 1")
  (setf (turn frame) 1
        (connect4-frame-board frame) (make-board)
        (game-won frame) nil
        (pane-needs-redisplay (get-frame-pane frame 'board-pane)) t))


;;; Convenience function to set the status message and tell the pane
;;; to redraw.
(defmethod update-status-msg ((frame connect4-frame) message)
  (setf (status-msg frame)
        message
        (pane-needs-redisplay (get-frame-pane frame 'status-pane))
        t))


;;; Draws the specified column into the pane.
(defmethod draw-column ((frame connect4-frame) pane col)
  ;;Calculate column position and size based on column number.
  (let* ((pieces (board-pieces (connect4-frame-board frame)))
         (col-width (ceiling (* *piece-radius*
                                2.2)))
         (middle-x (ceiling (+ (/ col-width 2) (* (1- col) col-width)))))
    ;;Iterate over pieces, drawing them at the appropriate y position.
    (loop
       for row from (1- *rows*) downto 0
       for y-mult from 0 to (1- *rows*)
       do (draw-piece frame pane
                      middle-x
                      (ceiling (+ (/ col-width 2)
                                  (* y-mult col-width)))
                      (aref pieces row (1- col))))))


;;; Draw a piece at specified x and y postion with a color indexed by the
;;; player number.
(defmethod draw-piece ((frame connect4-frame) pane x y player)
  (declare (ignore frame))
  (let ((color (nth player *player-colors*)))
    (draw-circle* pane x y *piece-radius* :filled t :ink color)))


;;;; CLIM command definitions

;;; Place piece.
(define-connect4-frame-command (com-move :name t :menu "Move")
    ((col 'column))
  ;;If game is already won, do nothing
  (unless (game-won *application-frame*)
    ;;Make the move, remembering where the piece landed
    (handler-case
        (let ((player (turn *application-frame*))
              (row (move (connect4-frame-board *application-frame*)
                         (1- col)
                         (turn *application-frame*))))
          ;;Update the turn counter
          (setf (turn *application-frame*)
                (if (= (turn *application-frame*) 1) 2 1))
          ;;Update the status message
          (update-status-msg *application-frame*
                             (format nil "Player ~A."
                                     (turn *application-frame*)))
          ;;Check for a draw
          (when (drawp (connect4-frame-board *application-frame*))
            (update-status-msg *application-frame* "A draw has occurred.")
            (setf (game-won *application-frame*) 'draw))
          ;;Use remembered location to determine whether there was a win
          (when (winning-piece-p (connect4-frame-board *application-frame*)
                                 row
                                 (1- col))
            (update-status-msg *application-frame*
                               (format nil "Player ~A has won." player))
            (setf (game-won *application-frame*) (turn *application-frame*))))
      (invalid-move (condition)
        (declare (ignore condition))
        (update-status-msg *application-frame* (format nil "~A is invalid." col))))
    ;;Redisplay the output panes
    (setf (pane-needs-redisplay (get-frame-pane *application-frame*
                                                'board-pane))
          t)))


;;; Re-initialize the state of the game.
(define-connect4-frame-command (com-reset-game :name t :menu "Reset")
    ()
  ;;Reset state
  (initialize-frame *application-frame*)
  ;;Redraw window
  (setf (pane-needs-redisplay (get-frame-pane *application-frame*
                                                'board-pane))
        t
        (pane-needs-redisplay (get-frame-pane *application-frame*
                                              'status-pane))
        t))


;;; Quit command.
(define-connect4-frame-command (com-quit-frame :name t :menu "Quit")
    ()
  (frame-exit *application-frame*))


;;;Enable clicking on columns to move in them.  The column
;;;presentation type is mapped to a command on that type.
(define-presentation-to-command-translator column-move-translator
    (column com-move connect4-frame
             :gesture :select
             :menu t
             :documentation "Move in column"
             :pointer-documentation "Move here")
  (object)
  (list object))


;;;Convenience function to run the toplevel.
(defun run-connect4 ()
  (run-frame-top-level
   (make-application-frame 'connect4-frame :pretty-name "Connect 4")))