;;;;  randomly generate a number-placement puzzle.

;;;;  This consists of an N x N array of cells.  Each cell is assigned
;;;;  one of N colours such that there are exactly N cells of any
;;;;  given colour (for ease of reading, these regions are usually
;;;;  contiguous).

;;;;  We now assign a numeric value from 1 to N to each cell such that
;;;;  no number repeats in any row, any column, or any colour.

;;;;  Algorithm used is somewhat brute-force, but at each step of the
;;;;  recursion we look for a cell with as few choices open to it as
;;;;  possible, so as to reduce the complexity.  Assigning a value to
;;;;  a cell will change the available values of other cells in the
;;;;  row, column, or colour.

(defpackage "NUMBER-PUZZLE"
  (:use "COMMON-LISP")
  (:export "MAKE-PUZZLE" "SHOW-PUZZLE" "SHOW-SOLUTION" "PRINTED-PUZZLES"
           "*COLOUR-ARRAY*"))

(in-package "NUMBER-PUZZLE")



;; Checks "assertion".  If false, signals an error on the rest of the
;; arguments.
(defmacro debug-check (assertion &rest error-args) 
  (declare (ignore assertion error-args)))

; (defmacro debug-check (assertion &rest error-args)
;       `(unless ,assertion (error ,@error-args))))



;; The random state
(defparameter *ran-state* nil)

;; The number of rows, columns, etc.  In other words, "N".
(defparameter *puzzle-size* 9)

;; The colour array.  Should consist of numbers from 0 to N-1
(defparameter *colour-array*
  #2A ((0 0 0 1 1 1 2 2 2)
       (0 0 0 1 1 1 2 2 2)
       (0 0 0 1 1 1 2 2 2)
       (3 3 3 4 4 4 5 5 5)
       (3 3 3 4 4 4 5 5 5)
       (3 3 3 4 4 4 5 5 5)
       (6 6 6 7 7 7 8 8 8)
       (6 6 6 7 7 7 8 8 8)
       (6 6 6 7 7 7 8 8 8)))

;; a vector of lists of coordinates
(defparameter *colour-to-coords* (make-array *puzzle-size*))

;; a list of cells by number of candidates remaining
(defparameter *cells-by-count* (make-array (1+ *puzzle-size*) :initial-element nil :element-type 'list))



;; Run this as (nested-loops ((i 10) (j 20) (k 30)) ...) to run the
;; body in those nested loops (i outermost)
(defmacro nested-loops (varblocks &body body)
  "Run this as (nested-loops ((i 10) (j 20) (k 30)) ...) to run the
body in those nested loops (i outermost)"
  (if (endp (rest varblocks))
      `(dotimes ,(first varblocks) ,@body)
      `(dotimes ,(first varblocks) (nested-loops ,(rest varblocks) ,@body))))



;; a cell class.  It contains:
;;    value        -- either nil, if not yet assigned, or a value from 1 to N
;;    reservations -- a vector, from 1 to N, of the number of cells
;;                    restricting a given value from being chosen.
;;                    Only if '0' could that number could appear in
;;                    this cell.
(defclass cell-data ()
  ((value               :reader get-value
                        :writer set-value
                        :initform nil)
   (reservations        :initform (make-array (1+ *puzzle-size*) 
                                              :element-type 'fixnum
                                              :initial-element 0)
                        :type	(simple-array fixnum))))


(defgeneric reserve (cell number)
  (:documentation "Reserve a number.  Declares that the presence of a
number in another cell will prevent this cell from holding the same
value.  Returns non-nil if this reservation has forbidden a value
formerly allowed. "))

(defgeneric unreserve (cell number)
  (:documentation "Clears the reservation on a number.  Returns
non-nil if the clearing has allowed a value formerly forbidden."))

(defgeneric possible-values (cell)
  (:documentation "Returns an array holding the non-forbidden values
for the given cell."))

(defgeneric copy-cell (cell)
  (:documentation "Produces a new object, a copy of the given cell"))


;; reserve a number.  Returns non-nil if the number of available
;; values has now changed (always returns nil if the value is set)
(defmethod reserve ((cell cell-data) number)
  (debug-check (<= 1 number *puzzle-size*) 
               "Bad reservation number ~D" number)
  (and (= 1 (incf (aref (slot-value cell 'reservations) number)))
       (not (get-value cell))))

;; clear a reservation on a number.  Returns non-nil if the number of
;; available values has now changed (always returns nil if the value is set)
(defmethod unreserve ((cell cell-data) number)
  (debug-check (<= 1 number *puzzle-size*)
               "Bad unreservation number ~D" number)
  (debug-check (> (aref (slot-value cell 'reservations) number) 0)
               "Attempt to unreserve a value not reserved")
  (and (zerop (decf (aref (slot-value cell 'reservations) number)))
       (not (get-value cell))))
      

;; return an array of possible values for the cell
(defmethod possible-values ((cell cell-data))
  (declare (optimize (speed 3) (safety 0)))
  (debug-check (not (get-value cell))
               "Call to possible-values on assigned cell with value ~D" (get-value cell))
  (let ((retval '()))
    (do ((i 1 (1+ i)))
        ((> i (the fixnum *puzzle-size*)) (make-array (length retval) 
                                         :initial-contents retval))
        (if (zerop (the fixnum (aref (the (simple-array fixnum) (slot-value cell 'reservations)) i)))
            (push i retval)))))

(defmethod copy-cell ((cell cell-data))
  (declare (optimize (speed 3) (safety 0)))
  (let ((retval (make-instance 'cell-data)))
    (set-value (get-value cell) retval)
    (setf (slot-value retval 'reservations)
          (copy-seq (the (simple-array fixnum) (slot-value cell 'reservations))))
    retval))



(defparameter *all-cells* (make-array (list *puzzle-size* *puzzle-size*)
                                      :element-type 'cell-data))
(defparameter *all-cells-loaded* nil)


(defparameter *solution* (make-array (list *puzzle-size* *puzzle-size*)
                                     :element-type 'cell-data))


(defun copy-solution (to from)
  (nested-loops ((i *puzzle-size*) (j *puzzle-size*))
                (setf (aref to i j) (copy-cell (aref from i j)))))

(defun copy-counts (to from)
  (do ((i 1 (1+ i)))
      ((> i *puzzle-size*) t)
      (setf (aref to i) (copy-list (aref from i)))))


;; fill the *all-cells* array with separate instances of cell-data
;; objects.
(defun load-all-cells ()
  (setf *all-cells-loaded* t)
  (nested-loops ((i *puzzle-size*) (j *puzzle-size*))
                (setf (aref *all-cells* i j) (make-instance 'cell-data))))


;; perform a Knuth shuffle on "vector" (which is modified).  The
;; elements in the vector are rearranged in a random order following
;; the invocation
(defun knuth-shuffle (vector &optional (index 0))
  (let ((max (length vector)))
    (debug-check (< -1 index max)
                 "Index ~D out of bounds in shuffle.  Giving up." index)
    (if (= index (1- max)) 
        vector
        (let ((swap (+ index (random (- max index) *ran-state*))))
          (psetf (aref vector index) (aref vector swap)
                 (aref vector swap) (aref vector index))
          (knuth-shuffle vector (1+ index))))))

;; we need the colour array in a more convenient form.  For a given
;; colour, what are the coordinates of all of the cells of that
;; colour?
(defun fill-colour-map ()
  (dotimes (i *puzzle-size*)
    (setf (aref *colour-to-coords* i) nil))
  (nested-loops ((i *puzzle-size*) (j *puzzle-size*))
                (push (cons i j) (aref *colour-to-coords* (aref *colour-array* i j)))))


(defun load-cells-by-count ()
  (unless *all-cells-loaded*
    (load-all-cells))
  (dotimes (i *puzzle-size*)
    (setf (aref *cells-by-count* i) nil))
  (nested-loops ((i *puzzle-size*) (j *puzzle-size*))
                (push (cons i j) (aref *cells-by-count* (length (possible-values (aref *all-cells* i j)))))))

(defun initialize()
  (setq *ran-state* (make-random-state t))
  (fill-colour-map)
  (load-all-cells)
  (load-cells-by-count))


(defun make-puzzle ()
  (initialize)
  (generate-puzzle)
  (copy-solution *solution* *all-cells*)
  (mask-entries))


;; OK, the (recursive) algorithm:
;;
;; 1) find the lowest non-nil *cells-by-count* entry, and get coords
;; 2) find all possible values at those coords, randomize the list
;; 3) go through the list of possible values in order.  Try setting
;;    the cell to that value, modifying the eligible lists on all
;;    other cells, then recurse.  If the recursed function returns
;;    nil, undo everything we did and go to the next possible value.
;; 4) if no value can satisfy the array, return nil
;; 5) if all cells are filled in, return true
(defun generate-puzzle ()
  (let ((low-index (position-if-not #'not *cells-by-count* :start 1)))
    (unless low-index
      (progn
        (nested-loops ((i *puzzle-size*) (j *puzzle-size*))
                      (when (not (get-value (aref *all-cells* i j)))
                        (return-from generate-puzzle nil)))
        (return-from generate-puzzle t)))
    (let* ((coords (car (aref *cells-by-count* low-index)))
           (row (car coords))
           (col (cdr coords)))
      ;; now, we work on "row" "col"
      (let ((list1 (possible-values (aref *all-cells* row col))))
        (debug-check list1
                     "Bad flow in generate-puzzle")
	;; mark the cell as unavailable for iteration
	(move-count row col low-index 0)
	;; walk the list
        (let ((candidates (knuth-shuffle list1)))
          (dotimes (trial (length candidates))
            (if (fill-in-value (aref candidates trial) row col)
                (if (generate-puzzle) 
                    (return-from generate-puzzle t)
		    (unfill-in-value (aref candidates trial) 
				     row col))
		(unfill-in-value (aref candidates trial) row col)))
          (move-count row col 0 low-index)
          nil)))))

(defun fill-in-value (trial row col)
  (set-value trial (aref *all-cells* row col))
  (let ((good-value t))
    ;; now, strike that trial value out of all other cells in the row,
    ;; column, and colour
    ;; first, the row
    (dotimes (i *puzzle-size*)
      (when (/= i col)
        (if (reserve (aref *all-cells* row i) trial)
            (let ((curlen (length (possible-values 
                                   (aref *all-cells* row i)))))
              (move-count row i (1+ curlen) curlen)
              (when (and (zerop curlen)
                         (not (get-value (aref *all-cells* row i))))
                  (setq good-value nil))))))
				  
    ;; next, the column
    (dotimes (i *puzzle-size*)
      (when (/= i row)
        (if (reserve (aref *all-cells* i col) trial)
            (let ((curlen (length (possible-values 
                                   (aref *all-cells* i col)))))
              (move-count i col (1+ curlen) curlen)
              (when (and (zerop curlen)
                         (not (get-value (aref *all-cells* i col))))
                (setq good-value nil))))))

    ;; next, the colour
    (let ((colour (aref *colour-array* row col)))
      (dolist (coords (aref *colour-to-coords* colour))
	(let ((row1 (car coords))
	      (col1 (cdr coords)))
	  (unless (and (= row1 row)
                       (= col1 col))
            (if (reserve (aref *all-cells* row1 col1) trial)
                (let ((curlen (length (possible-values 
                                       (aref *all-cells* row1 col1)))))
                  (move-count row1 col1 (1+ curlen) curlen)
                  (when (and (zerop curlen)
                             (not (get-value (aref *all-cells* row1 col1))))
                    (setq good-value nil))))))))
    good-value))

(defun unfill-in-value (trial row col)
  (set-value nil (aref *all-cells* row col))
  ;; now, replace that trial value in all other cells in the row,
  ;; column, and colour
  ;; first, the row
  (dotimes (i *puzzle-size*)
    (when (/= i col)
      (if (unreserve (aref *all-cells* row i) trial)
          (let ((curlen (length (possible-values 
                                 (aref *all-cells* row i)))))
            (move-count row i (1- curlen) curlen)))))
  ;; next, the column
  (dotimes (i *puzzle-size*)
    (when (/= i row)
      (if (unreserve (aref *all-cells* i col) trial)
          (let ((curlen (length (possible-values 
                                 (aref *all-cells* i col)))))
          (move-count i col (1- curlen) curlen)))))
  ;; next, the colour
  (let ((colour (aref *colour-array* row col)))
    (dolist (coords (aref *colour-to-coords* colour))
      (let ((row1 (car coords))
            (col1 (cdr coords)))
        (unless (and (= row1 row)
                     (= col1 col))
          (if (unreserve (aref *all-cells* row1 col1) trial)
              (let ((curlen (length (possible-values 
                                     (aref *all-cells* row1 col1)))))
                (move-count row1 col1 (1- curlen) curlen))))))))

(defun move-count (row col old-count new-count)
  (declare (type (simple-array list (*)) number-puzzle::*cells-by-count*)
           (optimize (speed 3) (safety 0)))
  (let ((coords (cons row col)))
;; Remove the error trap, this is a hot spot function
;;     (unless (find coords (aref *cells-by-count* old-count) :test 'equal)
;;       (error (format nil "Tried to move (~D,~D) from ~D to ~D"
;;                      row col old-count new-count)))
    (setf (aref *cells-by-count* old-count) (delete coords (aref *cells-by-count* old-count) :test 'equal :count 1))
    (push coords (aref *cells-by-count* new-count))))
    

(defun xor (a b)
  #+clisp (ext:xor a b)
  #-clisp (or (and (null a) b)
              (and a (null b))))

(defun show-puzzle (&optional row col)
  (if (xor row col)
      (error "Either supply row+col, or nothing"))
  (if (null row)
      (dump-puzzle *all-cells*)
    (get-value (aref *all-cells* row col))))


(defun show-solution (&optional row col)
  (if (xor row col)
      (error "Either supply row+col, or nothing"))
  (if (null row)
      (dump-puzzle *solution*)
    (get-value (aref *solution* row col))))

(defun dump-puzzle (puzzle-data)
  (let ((puzzle-string (make-array 10240 :element-type 'character :fill-pointer 0)))
    (format puzzle-string "~%")
    (dotimes (i *puzzle-size*)
      (dotimes (j *puzzle-size*)
        (format puzzle-string " ~3D " (get-value (aref puzzle-data i j)))
        (if (= (mod j 3) 2) (format puzzle-string "  ")))
      (format puzzle-string "~%")
      (if (= (mod i 3) 2) (format puzzle-string "~%")))
    puzzle-string))

      

;;;;  Now, the function to produce the "puzzle" part.  We create a
;;;;  random list of coordinates in the puzzle, and walk it.  When we
;;;;  reach a cell the following sequence of operations occurs:
;;;;
;;;;  1) unset the cell
;;;;  2) reserve the value which was in the cell
;;;;  3) attempt to construct a new puzzle based on this partial puzzle
;;;;  4) if the attempt succeeds, don't mask the cell, leave it alone
;;;;  5) if the attempt fails, unreserve the value and continue
;;;;
;;;;  This guarantees that we will produce a puzzle with a unique
;;;;  solution, but that it will be as difficult as possible.

(defun mask-entries ()
  (let* ((n-cells (* *puzzle-size* *puzzle-size*))
         (index 0)
         (coord-list (make-array n-cells)))
    (nested-loops ((i *puzzle-size*) (j *puzzle-size*))
                  (setf (aref coord-list index) (cons i j))
                  (incf index))
    (knuth-shuffle coord-list)
    (dotimes (i n-cells)
      (let* ((row (car (aref coord-list i)))
             (col (cdr (aref coord-list i)))
             (old-value (get-value (aref *all-cells* row col))))
        (setup-trial row col old-value)
        (let ((backup (make-array (list *puzzle-size* *puzzle-size*)
                                  :element-type 'cell-data))
              (backup-count (make-array (1+ *puzzle-size*))))
          (copy-solution backup *all-cells*)
          (copy-counts backup-count *cells-by-count*)
          (if (generate-puzzle) 
              (progn (copy-solution *all-cells* backup)
                     (copy-counts *cells-by-count* backup-count)
                     (unset-trial row col old-value))
	      (if (unreserve (aref *all-cells* row col) old-value)
		  (let ((curval (length (possible-values (aref *all-cells* row col)))))
		    (move-count row col (1- curval) curval)))))))))

(defun setup-trial (row col old-value)
  (set-value nil (aref *all-cells* row col))
  (reserve (aref *all-cells* row col) old-value)
  (move-count row col 0 (length (possible-values (aref *all-cells* row col))))
  (unfill-in-value old-value row col))

(defun unset-trial (row col old-value)
  (let ((curpos (length (possible-values (aref *all-cells* row col)))))
    (set-value old-value (aref *all-cells* row col))
    (unreserve (aref *all-cells* row col) old-value)
    (move-count row col curpos 0)
    (fill-in-value old-value row col)))