;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               mine-player.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This program plays Mine.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2008-05-16 <PJB> Created.
;;;;BUGS
;;;;    Doesn't work very well.
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal Bourguignon 2008 - 2008
;;;;
;;;;    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., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(in-package "COM.INFORMATIMAGO.GAME.MINE-PLAYER")



(defmacro safe-incf (&environment env place &optional (delta 1) (default 0))
  "Like INCF, but accepts a default value for when place is NIL."
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion place env)
    (when (cdr store-vars) (error "Can't expand this."))
    `(let* (,@(mapcar (function list) vars vals))
       (let ((,(car store-vars) (+ (or ,reader-form ,default) ,delta)))
         ,writer-form))))

(defmacro safe-decf (&environment env place &optional (delta 1) (default 0))
  "Like DECF, but accepts a default value for when place is NIL."
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion place env)
    (when (cdr store-vars) (error "Can't expand this."))
    `(let* (,@(mapcar (function list) vars vals))
       (let ((,(car store-vars) (- (or ,reader-form ,default) ,delta)))
         ,writer-form))))



(defconstant +unknown+ 3.0)
(defconstant +ignore+  2.0)



(defstruct cell
  x y                                   ; cell coordinates.
  (has-flag-p nil)
  mine-probability               ; probability of a mine in this cell.
  neighbor-count                        ; number of neighbors.
  neighbor-no-mine-count    ; number of neighbor who don't have mines.
  neighbor-mine-count      ; number of mines in the neighboring cells.
  (neighbor-flag-count 0)  ; number of flags in the neighboring cells.
  neighbor-unknown-count           ; number of free neighboring cells.
  (neighbor-cells '())                  ; neighboring cells.
  )

(setf *print-circle* t
      *print-level*  2)

(defun cell-neighbor-mine-count-known-p (cell)
  (cell-neighbor-mine-count cell))

(defun cell-neighbor-unknown-cells (cell)
  (remove-if (function cell-neighbor-mine-count-known-p )
             (cell-neighbor-cells cell)))

(defun make-cells (display)
  (loop
     :with width = (array-dimension display 0)
     :with height = (array-dimension display 1)
     :with cells = (loop
                      :with cells = (make-array (array-dimensions display))
                      :for x :from 0 :below width
                      :do (loop
                             :for y :from 0 :below height
                             :do (setf (aref cells x y) (make-cell :x x :y y)))
                      :finally (return cells))
     :for x :from 0 :below width
     :do (loop
            :for y :from 0 :below height
            :for cell = (aref cells   x y)
            :for disp = (aref display x y)
            :do (cond
                  ((member disp '(:nothing :beware)) #|no mine-count|#)
                  ((eq disp :flag) (setf (cell-mine-probability cell) 1.0
                                         (cell-has-flag-p cell) t))
                  ((integerp disp) (setf (cell-neighbor-mine-count cell) disp
                                          (cell-mine-probability cell) 0.0))
                  (t (error "Got an unexpected cell : ~S" cell)))
            :do (flet ((p (x) (1- x))
                       (i (x)     x)
                       (n (x) (1+ x))
                       (ref (x y)
                         (unless (or (< x 0) (< y 0) (<= width x) (<= height y))
                           (push (aref cells x y) (cell-neighbor-cells cell))
                           (safe-incf (cell-neighbor-count cell))
                           (let ((neigh (aref display x y)))
                             (cond
                               ((member neigh '(:nothing :beware))
                                (safe-incf (cell-neighbor-unknown-count cell)))
                               ((eq neigh :flag)
                                (safe-incf (cell-neighbor-flag-count cell)))
                               ((integerp neigh)
                                (safe-incf (cell-neighbor-no-mine-count cell)))
                               (t
                                (error "Got an unexpected cell : ~S" neigh)))))))
                  (declare (inline p i n))
                  (progn
                    (ref (p x) (p y)) (ref (i x) (p y)) (ref (n x) (p y))
                    (ref (p x) (i y))                   (ref (n x) (i y))
                    (ref (p x) (n y)) (ref (i x) (n y)) (ref (n x) (n y)))))
     :finally (return cells)))






(defun elements (array)
  "Returns a list of all the elements in the array."
  (loop
     :for i :from 0 :below (array-total-size array)
     :collect (row-major-aref array i)))

(defun random-element (sequence)
  (elt sequence (random (length sequence))))


(defun player (message &key display total-mine-count remaining-mine-count)
  "
Must return (values :step x y) or (values :flag x y) unless message is :explosion or :win.
"
  (com.informatimago.game.mine:TERMINAL-DISPLAY-BOARD display remaining-mine-count)
  (case message
    ((:explosion) (format t "~%;;    :-(   ~%") (values))
    ((:win)       (format t "~%;;    (-:   ~%") (values))
    (otherwise
     (let* ((cells (make-cells display))
            (cell-list (elements cells))
            (unknown-cell-count
             (count-if-not (function cell-neighbor-mine-count-known-p)
                           cell-list)))
       (macrolet ((infer (&body body)
                    (when (stringp (first body)) (pop body))
                    `(dolist (cell cell-list)
                       (when ,@body))))
         (flet ((flag-on (cell)
                  (unless (cell-has-flag-p cell)
                    (format t "~&Put flag on cell ~A,~A~%" (cell-x cell) (cell-y cell))
                    (return-from player (values :flag (cell-x cell) (cell-y cell)))))
                (step-on (cell)
                  (unless (cell-neighbor-mine-count cell)
                    (format t "~&Step on cell     ~A,~A~%" (cell-x cell) (cell-y cell))
                    (return-from player (values :step (cell-x cell) (cell-y cell)))))
                (automatic-on (cell)
                  (when (cell-neighbor-mine-count cell)
                    (format t "~&Step on cell     ~A,~A to discover trivial cells~%"
                            (cell-x cell) (cell-y cell))
                    (return-from player (values :step (cell-x cell) (cell-y cell))))))


           (infer (not (cell-neighbor-no-mine-count cell))
                  (setf (cell-neighbor-no-mine-count cell)
                        (- (+ (cell-neighbor-flag-count cell)
                              (cell-neighbor-unknown-count cell))
                           (cell-neighbor-count cell))))
           (infer (not (cell-neighbor-flag-count cell))
                  (setf (cell-neighbor-flag-count cell)
                        (- (+ (cell-neighbor-no-mine-count cell)
                              (cell-neighbor-unknown-count cell))
                           (cell-neighbor-count cell))))
           (infer (not (cell-neighbor-unknown-count cell))
                  (setf (cell-neighbor-unknown-count cell)
                        (- (+ (cell-neighbor-no-mine-count cell)
                              (cell-neighbor-flag-count cell))
                           (cell-neighbor-count cell))))

           (infer (and (cell-neighbor-mine-count-known-p cell)
                       (plusp (cell-neighbor-unknown-count cell))
                       (= (cell-neighbor-mine-count cell) (cell-neighbor-flag-count cell)))
                  (let ((new (first (remove-if (lambda (cell)
                                               (or (cell-neighbor-mine-count cell)
                                                   (cell-neighbor-flag-count cell)))
                                             (cell-neighbor-unknown-cells cell)))))
                    (when new (step-on new))))

           (infer (and (cell-neighbor-mine-count-known-p cell)
                       (> (cell-neighbor-unknown-count cell)
                          (- (cell-neighbor-mine-count cell) (cell-neighbor-flag-count cell))))
                  (loop
                     :for neighbor :in (cell-neighbor-unknown-cells cell)
                     :do (setf (cell-mine-probability neighbor)
                               (max (or (cell-mine-probability neighbor) 0.0)
                                    (/ (- (cell-neighbor-mine-count cell) (cell-neighbor-flag-count cell))
                                       (cell-neighbor-unknown-count cell))))
                     (format t "~&Cell at ~A,~A probability: ~F~%"
                             (cell-x neighbor) (cell-y neighbor)
                             (cell-mine-probability neighbor))))

           (infer "When there remains less-or-equal free neighbors than mine-flag,
                   then flag the remaining free neighbors."
                  (and (cell-neighbor-mine-count-known-p cell)
                       (<= (cell-neighbor-unknown-count cell)
                           (- (cell-neighbor-mine-count cell) (cell-neighbor-flag-count cell))))
                  (loop
                     :for neighbor :in (cell-neighbor-unknown-cells cell)
                     :do (flag-on neighbor)))

           (infer (not (cell-neighbor-mine-count-known-p cell))
                  (setf (cell-mine-probability cell)
                        (/ remaining-mine-count unknown-cell-count)))

           (format t "~&Remaining probability: ~F~%"
                   (/ remaining-mine-count unknown-cell-count))


           (loop
              :with min-cell
              :with min-prob = 1.0
              :for cell :in cell-list
              :when (< (or (cell-mine-probability cell) 1.0) min-prob)
              :do (setf min-cell cell min-prob (cell-mine-probability cell))
              :finally (when min-cell (step-on min-cell)))

           (step-on  (random-element (remove-if (function cell-neighbor-mine-count-known-p) cell-list)))))))))




#- (and)
(flet ((count-cells ()
         (loop
            :with flags = 0
            :with empty-cells = 0
            :with counters = (make-array 10 :initial-element 0)
            :with width  = (array-dimension display 0)
            :with height = (array-dimension display 1)
            :with total-cells = (* width height)
            :for i :from 0 :below (array-total-size display)
            :for cell = (row-major-aref display i)
            :do (cond
                  ((member cell '(nothing beware)) (incf empty-cells))
                  ((eq cell 'flag)                 (incf flags))
                  ((integerp cell)        (incf (aref counters cell)))
                  (t (error "Got an unexpected cell : ~S" cell)))
            :finally (values empty-cells flags counters width height total-cells))))
  (multiple-value-bind (empty-cells flags counters width height total-cells) (count-cells)
    (when (zerop empty-cells)
      (error "I should have won! empty-cells = ~D" empty-cells))
    (let ((prob-empty-cell (/ remaining-mine-count empty-cells))

          ))))

;; (and (or (and a (not b))          (and (not a) b))
;;      (or (and a (not b) (not c))  (and (not a) b (not c)) (and (not a) (not b) c)))
;;
;;
;; (and (or a b) (or a c)) = (or (and a a) (and a c) (and b a) (and (b c)))
;;
;; (and (or (and a (not b))          (and (not a) b))
;;      (or (and a (not b) (not c))  (and (not a) b (not c)) (and (not a) (not b) c)))
;;
;; (defun normalize-boolean (expression)
;;   (if (atom expression)
;;       expression
;;       (case (first expression)
;;         ((and))
;;          (mapcan (lambda (expr)
;;                    (if (and (listp expr) (eq 'or (first expr)))
;;                        (copy-seq (rest expr))
;;                        (list expr))))
;;         ((or)
;;          (cond
;;            ((every (lambda (expr) (and (listp expr) (eq 'and (first expr))))
;;                    (rest expression))
;;             (or (and a ...) (and b ...) ...)
;;             (and (or a))
;;             `(and ,@(cartesian-product ))
;;             )
;;            (t
;;             (mapcan (lambda (expr)
;;                       (if (and (listp expr) (eq 'or (first expr)))
;;                           (copy-seq (rest expr))
;;                           (list expr)))))))
;;         ((not)
;;          (let ((subexpression (normalize-boolean (second expression))))
;;            (if (atom subexpression)
;;                `(not ,subexpression)
;;                (case (first subexpression)
;;                  ((or)  `(and ,@(mapcar (lambda (expr) (normalize-boolean `(not ,expr)))
;;                                         (rest subexpression))))
;;                  ((not) (second subexpression))
;;                  (otherwise `(not ,subexpression)))))))))
;;
;;
;; (normalize-boolean '(not (not (not a))))
;;
;;
;;
;; (PLAYER ':PLAY ':DISPLAY '
;; #2A((:FLAG 2 :FLAG 1 0 0 0 0 0 0 0 0 1 :NOTHING :NOTHING)
;;     (:FLAG 2 1 1 0 0 0 0 0 0 0 0 2 :NOTHING :NOTHING)
;;     (2 2 0 0 0 0 0 0 0 0 0 0 1 :NOTHING :NOTHING)
;;     (:FLAG 1 0 0 1 1 1 0 0 0 0 0 1 2 2)
;;     (1 2 2 2 2 :NOTHING 2 1 1 0 0 0 0 0 0)
;;     (0 1 :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING 2 1 1 0 1 1 1)
;;     (0 1 2 2 1 1 :NOTHING :NOTHING :NOTHING :NOTHING 2 1 2 :NOTHING :NOTHING)
;;     (0 0 0 0 0 1 :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING)
;;     (0 0 1 1 1 2 :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING)
;;     (1 1 2 :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING 2 :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING)
;;     (:NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING
;;      :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING :NOTHING))
;; ':TOTAL-MINE-COUNT '40 ':REMAINING-MINE-COUNT '36)

(defun play ()
 (COM.INFORMATIMAGO.GAME.MINE:mine
  :player (function COM.INFORMATIMAGO.GAME.MINE-PLAYER)))


;;;; THE END ;;;;
ViewGit