;;; Congklak - Indonesian Mancala
;;; Copyright (C) 2011 Peter Salvi <vukung@yahoo.com>

;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;;; MA 02110-1301, USA.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :ltk))

(in-package #:cl-user)

(defpackage #:congklak
  (:use #:common-lisp #:iterate)
  (:export #:ltk-gui))

(in-package #:congklak)

;;; Front player is called Black, the other player is White.
;;; A seed size of -1 means that the hole is not used in this phase.
;;; Indexing:
;; |    |  8 |  9 | 10 | 11 | 12 | 13 | 14 |    |
;; |  7 |    |    |    |    |    |    |    | 15 |
;; |    |  6 |  5 |  4 |  3 |  2 |  1 |  0 |    |

(defun setup-board (&optional (black 49) (white 49))
  "BLACK and WHITE contain the initial number of seeds.
If the function returns NIL the game has ended."
  (assert (= (+ black white) 98) (black white) "The seed total should be 98")
  (when (>= (min black white) 7)
    (let ((board (iter (repeat 16) (collect -1))))
      (flet ((initial-sow (seeds silo)
               (iter (for i upfrom 1)
                     (for remaining first seeds then (- remaining 7))
                     (while (and (>= remaining 7) (< i 8)))
                     (setf (elt board (- silo i)) 7)
                     (finally (setf (elt board silo) remaining)))))
        (initial-sow black 7)
        (initial-sow white 15))
      board)))

(defun print-board (board)
  "For testing."
  (flet ((stringify (x) (if (= x -1) "  " (format nil "~2d" x))))
    (format t "~&+----+----+----+----+----+----+----+----+----+~%~
             |    |~{ ~a |~}    |~%~
             | ~a |    |    |    |    |    |    |    | ~a |~%~
             |    |~{ ~a |~}    |~%~
             +----+----+----+----+----+----+----+----+----+~%"
            (mapcar #'stringify (subseq board 8 15))
            (stringify (elt board 7)) (stringify (elt board 15))
            (mapcar #'stringify (reverse (subseq board 0 7))))))

(defparameter *display-fn* #'print-board)

(defun player-silo (board player)
  (elt board (if (eq player 'black) 7 15)))

(defun (setf player-silo) (value board player)
  (setf (elt board (if (eq player 'black) 7 15)) value))

(defun silop (index)
  (or (= index 7) (= index 15)))

(defun own-side-p (player index)
  (eq (if (> index 7) 'white 'black) player))

(defun opposite-hole (index)
  (- 14 index))

(defun other-player (player)
  (if (eq player 'black) 'white 'black))

(defun sowablep (board player index)
  (and (not (silop index)) (own-side-p player index) (> (elt board index) 0)))

(defun can-sow-p (board player)
  (iter (for i from 0 below 16)
        (thereis (sowablep board player i))))

(defun game-ended-p (board)
  (= (+ (player-silo board 'black) (player-silo board 'white)) 98))

(defun sow-one-step (board player index displayp)
  "Destructively modifies BOARD and returns the index of the hole sown to.
INDEX is the previous hole."
  (let ((next (mod (1+ index) 16)))
    (cond ((or (and (silop next) (not (own-side-p player next)))
               (= (elt board next) -1))
           (sow-one-step board player next displayp))
          (t (when displayp
               (funcall *display-fn* board))
             (incf (elt board next)) next))))

(defun handle-last-seed (board player last displayp)
  "Destructively modifies BOARD and returns the next player to move."
  (let ((opposite (opposite-hole last)))
    (cond ((silop last) player)
          ((> (elt board last) 1)
           (sow-seeds board player last displayp))
          ((not (own-side-p player last))
           (other-player player))
          ((not (> (elt board opposite) 0))
           (other-player player))
          (t (incf (player-silo board player)
                   (+ (elt board last)
                      (elt board opposite)))
             (setf (elt board last) 0
                   (elt board opposite) 0)
             (other-player player)))))

(defun sow-seeds (board player from &optional displayp)
  "Destructively modifies BOARD and returns the next player to move."
  (let ((seeds (elt board from)))
    (setf (elt board from) 0)
    (iter (repeat seeds)
          (for next first from then last)
          (for last = (sow-one-step board player next displayp))
          (finally (return (handle-last-seed board player last displayp))))))

;;; Test:
#+nil
(let* ((board (setup-board 76 22))
       (next (sow-seeds board 'black 1 t)))
  (print-board board)
  (format t "Next player: ~a~%" next))


;;; Minimax AI opponent:

(defun random-select (lst)
  (elt lst (random (length lst))))

(defun ai-player% (board player original-player depth)
  (cond ((or (game-ended-p board) (= depth 0))
         (list (- (player-silo board original-player)
                  (player-silo board (other-player original-player)))))
        ((not (can-sow-p board player))
         (ai-player% board (other-player player) original-player depth))
        (t (iter (with moves = '())
                 (for i from 0 below 16)
                 (when (sowablep board player i)
                   (for after-move = (copy-list board))
                   (for next = (sow-seeds after-move player i))
                   (for score = (first (ai-player% after-move next
                                                   original-player (1- depth))))
                   (push (list score i) moves))
                 (finally
                  (let* ((my-max (if (eq player original-player) #'max #'min))
                         (max (reduce my-max (mapcar #'first moves))))
                    (return (random-select
                             (remove-if-not (lambda (x)
                                              (= (first x) max))
                                            moves)))))))))

(defun ai-player (board player &optional (depth 5))
  "Simple minimax algorithm.
Recommended values for DEPTH: 1-6."
  (second (ai-player% board player player depth)))

;;; Test AI vs. AI
#+nil
(let ((board (setup-board)))
  (flet ((depths (player) (if (eq player 'black) 2 6)))
    (iter (for player first 'black then
               (or (and (can-sow-p board next-player) next-player)
                   (other-player next-player)))
          (for next-move = (ai-player board player (depths player)))
          (format t "~%~a's move: ~d~%" player next-move)
          (while next-move)
          (for next-player = (sow-seeds board player next-move))
          (print-board board))))

;;; Results:
;;; 90 -  8 [depth: 6 - 2]
;;; 35 - 63 [depth: 2 - 6]
;;; ... which is OK, since the starting player has the advantage


;;; Simple LTk GUI:

(defparameter *board* nil)
(defparameter *player* nil)

(defun handle-next-move ()
  (cond ((game-ended-p *board*)
         (let* ((black (player-silo *board* 'black))
                (white (player-silo *board* 'white))
                (diff (- black white))
                (msg (cond ((< diff 0) "You lost this round.")
                           ((> diff 0) "You won this round.")
                           (t "This round was a draw."))))
           (ltk:message-box msg "Round Ended" :ok :info) 
           (setf *player* (if (< black white) 'black 'white)
                 *board* (setup-board black white))
           (if *board*
               (progn
                 (funcall *display-fn* *board*)
                 (handle-next-move))
               (let ((msg (if (< black white) "You lost." "You won.")))
                 (ltk:message-box msg "Game Ended" :ok :info)
                 (setf ltk:*exit-mainloop* t)))))
        ((eq *player* 'white)
         (if (can-sow-p *board* *player*)
             (let ((move (ai-player *board* *player*)))
               (setf *player* (sow-seeds *board* *player* move t))
               (funcall *display-fn* *board*)
               (handle-next-move))
             (setf *player* (other-player *player*))))
        (t (unless (can-sow-p *board* *player*)
             (setf *player* (other-player *player*))
             (handle-next-move)))))

(defun button-clicked (index)
  (when (sowablep *board* *player* index)
    (setf *player* (sow-seeds *board* *player* index t))
    (funcall *display-fn* *board*)
    (handle-next-move)))

(defun ltk-gui (&optional (wait 0.5))
  (ltk:with-ltk ()
    (let* ((buttons
            (iter (for i from 0 below 16)
                  (collect
                      (make-instance 'ltk:button
                                     :command (let ((j i))
                                                (lambda ()
                                                  (button-clicked j))))))))
      (iter (for i from 0 below 7)
            (ltk:grid (elt buttons i) 2 (- 7 i)))
      (ltk:grid (elt buttons 7) 1 0)
      (iter (for i from 0 below 7)
            (ltk:grid (elt buttons (+ 8 i)) 0 (1+ i)))
      (ltk:grid (elt buttons 15) 1 8)
      (ltk:wm-title ltk:*tk* "Congklak")
      (setf *player* (if (eq (ltk:message-box "Do you want to play first?"
                                              "First Player" :yesno :question)
                             :yes)
                         'black 'white))
      (labels ((stringify (x) (if (= x -1) "  " (format nil "~2d" x)))
               (display-board (board)
                 (iter (for i from 0 below 16)
                       (setf (ltk:text (elt buttons i))
                             (stringify (elt board i)))))
               (display-board-and-wait (board)
                 (display-board board)
                 (sleep wait)))
        (setf *display-fn* #'display-board-and-wait
              *board* (setup-board))
        (display-board *board*)
        (handle-next-move)))))