;;;  A program taught my techniques for solving sudoku puzzles, and
;;;  using them to evaluate the difficulty of a puzzle.
;;;

; (require "generate" "./generate")

(defpackage "EVAL-DIFF"
  (:use "COMMON-LISP" "NUMBER-PUZZLE")
  (:import-from :NUMBER-PUZZLE *COLOUR-ARRAY* MAKE-PUZZLE SHOW-PUZZLE)
  (:export "DIFFICULTY-STRING"))

(in-package "EVAL-DIFF")

(defparameter *puzzle-size* (first (array-dimensions *colour-array*)))
(defparameter *workspace* (make-array (array-dimensions *colour-array*) :initial-element nil))
(defparameter *digits-known-in-colour* (make-array *puzzle-size* :initial-element nil))
(defparameter *coords-by-colour* (make-array *puzzle-size* :initial-element nil))
(defparameter *unknown-count* (* *puzzle-size* *puzzle-size*))

;; Phantoms.  These are digits which, while their positions are not
;; precisely known, have been narrowed down to a particular row/column
;; within a colour block.  Indexed by colour, each entry consists of a
;; list of fields.  One field is ( digit :row row )
(defparameter *phantoms* (make-array *puzzle-size* :initial-element nil))

;; a list of difficulty level strings.
(defparameter *difficulty-levels* '("EASY" "MEDIUM" "HARD"))

(defmacro forever (&body body)
  `(do () (nil) ,@body))

;; performs the tests in order, looping continuously, returns only
;; when all tests return nil.  Returns non-nil if any test returned
;; non-nil.
(defmacro test-while-non-nil (&rest tests)
  (let ((result (gensym))
        (ever (gensym)))
    `(do ((,result t) (,ever nil)) 
      ((not ,result) ,ever)
      (setf ,result (/= 0 (count-if-not #'null (mapcar #'funcall ,@tests))))
      (when (and ,result (not ,ever))
        (setf ,ever t)))))

(defmacro while (test &body body)
  `(do ()
    ((not ,test))
    ,@body))

;; Iterate 'variable' from 1 to num-iters (not from 0 to num-iters
;; less 1).
(defmacro dotimes+1 ((variable num-iters) &body body)
  `(do ((,variable 1 (1+ ,variable)))
    ((> ,variable ,num-iters))
    ,@body))

(defmacro repeat-while-successful (successvar &body body)
  "Executes the body repeatedly.  If, when the body completes,
'successvar' has been set to non-nil, it will be set to nil and the
body will be run again.  Eventually, when 'successvar' is not reset to
non-nil, the loop will exit, with a return value of non-nil if there
was at least one success prior to exit."
  (let ((retval (gensym))
        (stumped (gensym)))
    `(let (,retval ,stumped (,successvar nil))
      (setf ,retval nil)
      (setf ,stumped nil)
      (while (not ,stumped)
        (setf ,stumped t)
        (setf ,successvar nil)
        ,@body
        (when ,successvar
          (setf ,stumped nil)
          (setf ,retval t)))
      ,retval)))


(labels ((proper-listp (list)
           (or (null list)
               (and (consp list)
                    (proper-listp (cdr list)))))

         (rewrite-helper (old new form-list)
           (macrolet ((prefix? (form)
                        `(when (keywordp ,form) ":")))
             (let ((closure #'(lambda(x) (rewrite-helper old new x))))
               (cond
                 ((atom form-list)
                  (if (symbolp form-list)
                      (read-from-string (concatenate 'string (prefix? form-list) (perform-replacement (symbol-name form-list) old new)))
                      (concatenate 'string (prefix? form-list) form-list)))
                 ((listp form-list)
                  (if (proper-listp form-list)
                      (mapcar closure form-list)
                      (append (mapcar closure (butlast form-list)) (cons (funcall closure (car (last form-list))) (funcall closure (cdr (last form-list)))))))))))

         (perform-replacement (string old new)
           (let* ((s2 (string-upcase string))
                  (o2 (string-upcase old))
                  (n2 (string-upcase new))
                  (posn (search o2 s2)))
             (if posn
                 (let ((s3 (concatenate 'string (subseq s2 0 posn) n2 (subseq s2 (+ posn (length o2))))))
                   (perform-replacement s3 old new))
                 s2))))

  (defmacro rewrite-symbols (old new &body body)
    (rewrite-helper old new (car body)))

  (defmacro rowcol-substitute (type &body body)
    (cond
      ((eq type :ROW)
       (rewrite-helper "ROWORCOL" "ROW" (rewrite-helper "ROWORCOLPRIME" "COL" (car body))))
      ((eq type :COL)
       (rewrite-helper "ROWORCOL" "COL" (rewrite-helper "ROWORCOLPRIME" "ROW" (car body))))
      (t
       (error "Bad call to rowcol-substitute")))))




(defparameter *easy-rules* '())
(defparameter *medium-rules* '())
(defparameter *hard-rules* '())

(defmacro create-easy-rule (name &body body)
  `(progn
    (defun ,name () ,@body)
    (unless (member ',name *easy-rules*)
      (push ',name *easy-rules*))))

(defmacro create-medium-rule (name &body body)
  `(progn
    (defun ,name () ,@body)
    (unless (member ',name *medium-rules*)
      (push ',name *medium-rules*))))

(defmacro create-hard-rule (name &body body)
  `(progn
    (defun ,name () ,@body)
    (unless (member ',name *hard-rules*)
      (push ',name *hard-rules*))))



;;;  Different rules will massage down a set of coordinates and
;;;  possible values at those points.  They will pass a structure:
;;;  (((row col) (1 2 3 4)) ((row col) (2 4 8)) ...)
;;;  This data may be modified/destroyed.
(defun locate-values (where-and-what)
  (labels ((coords-of-unique-digit (data digit)
             "Returns the coordinates of the only cell in the list in
which 'digit' appears."
             (let ((retval (remove-if-not #'(lambda(x) (find digit (second x))) data)))
               (when (list-of-one retval)
                 (first retval))))
           (remove-occurences (data digit)
             "Returns a list like 'data', but with all occurences of
the number 'digit' removed."
             (mapcar #'(lambda(x) (list (first x) (remove digit (second x)))) data))
           (remove-coords (data x y)
             "Returns a list like 'data', but with the data at x,y
removed."
             (remove (cons x y) data :key 'first :test 'equal)))
    (repeat-while-successful good
      (dolist (obj where-and-what)
        (destructuring-bind ((row . col) vals) obj
          (when (list-of-one vals)
            (setf good t)
            (place-digit (first vals) row col)
            (setf where-and-what (remove-occurences (remove-coords where-and-what row col) (first vals)))
            (return))))
      (dotimes+1 (digit *puzzle-size*)
        (let ((one-obj (coords-of-unique-digit where-and-what digit)))
          (when one-obj
            (let ((row (car (first one-obj)))
                  (col (cdr (first one-obj))))
              (setf good t)
              (place-digit digit row col)
              (setf where-and-what (remove-occurences (remove-coords where-and-what row col) digit))
              (return))))))))

(defun initialize-vars ()
  (setf *digits-known-in-colour* (make-array *puzzle-size* :initial-element nil))
  (setf *coords-by-colour* (make-array *puzzle-size* :initial-element nil))
  (setf *unknown-count* (* *puzzle-size* *puzzle-size*))
  (dotimes (row *puzzle-size*)
    (dotimes (col *puzzle-size*)
      (let ((colour (aref *colour-array* row col)))
        (when (setf (aref *workspace* row col) (show-puzzle row col))
          (decf *unknown-count*)
          (push (show-puzzle row col) (aref *digits-known-in-colour* colour)))
        (push (cons row col) (aref *coords-by-colour* colour))))))

(defun clear-phantoms ()
  (setf *phantoms* (make-array *puzzle-size* :initial-element nil)))

(defun compute-all-phantoms ()
  (clear-phantoms)
  (dotimes+1 (digit *puzzle-size*)
    (compute-phantoms digit)))

(defun phantom-digit-in-col (digit col colour)
  "Checks to see if there is a phantom digit of the same type in the
given column, but not in the given colour."
  (dotimes (col-iter *puzzle-size*)
    (unless (= col-iter colour)
      (let ((candidate (phantom-colour-present digit col-iter)))
        (when (and candidate
                   (eq (second candidate) :col)
                   (= (third candidate) col))
          (return-from phantom-digit-in-col t))))))

(defun phantom-digit-in-row (digit row colour)
  "Checks to see if there is a phantom digit of the same type in the
given row, but not in the given colour."
  (dotimes (col-iter *puzzle-size*)
    (unless (= col-iter colour)
      (let ((candidate (phantom-colour-present digit col-iter)))
        (when (and candidate
                   (eq (second candidate) :row)
                   (= (third candidate) row))
          (return-from phantom-digit-in-row t))))))

(defun phantom-colour-present (digit colour)
  (find-if #'(lambda (x) (equal digit (first x))) (aref *phantoms* colour)))

(defun compute-phantoms (digit)
  (let ((done nil))
    (while (not done)
      (setf done t)
      (dotimes (colour *puzzle-size*)
        (unless (phantom-colour-present digit colour)
          (let* ((candidates (digit-by-coords-in-colour digit colour))
                 (phantom-row (coords-all-in-row candidates))
                 (phantom-col (coords-all-in-col candidates)))
            (when phantom-row
              (push (list digit :row phantom-row) (aref *phantoms* colour))
              (setf done nil))
            (when phantom-col
              (push (list digit :col phantom-col) (aref *phantoms* colour))
              (setf done nil))))))))

(defun difficulty-string ()
  (initialize-vars)
  (let ((difficulty 0))  ;; keep track of highest difficulty rule used
    (do ()
        ((or (eq difficulty (1- (length *difficulty-levels*)))
             (= *unknown-count* 0)) (values (nth difficulty *difficulty-levels*) difficulty))
      (cond
        ((easy-rules) (setf difficulty (max difficulty 0)))
        ((medium-rules) (setf difficulty (max difficulty 1)))
        ((hard-rules) (setf difficulty (max difficulty 2)))))))

(defun list-of-one (list)
  (and (listp list)
       list
       (endp (cdr list))))

(defun coords-at-colour (colour)
  (aref *coords-by-colour* colour))

(defun colour-of-coords (row col)
  (aref *colour-array* row col))

(defun known-value (row col)
  (aref *workspace* row col))

(defun unordered-permutations (num values)
  "Given a number and a list of unique integers, returns a list of all
unique lists of 'num' integers (order unimportant)."
  (if (= num 1) 
      (mapcar 'list values)
      (let ((retval nil))
        (do* ((one-val (car values) (car next-list))
              (next-list (cdr values) (cdr next-list)))
             ((endp next-list) retval)
          (setf retval (append retval (mapcar #'(lambda(x) (append (list one-val) x)) (unordered-permutations (1- num) next-list))))))))

(defun values-known-in-cells (trial-list vector)
  "Checks to see if all elements in 'trial-list' appear only within a
number of elements of 'vector' equal to the length of 'trial-list'."
  (let ((contains-all (remove-if-not #'(lambda(x) (subsetp trial-list x)) vector)))
    (when (= (length contains-all) (length trial-list))
      (dolist (num trial-list)
        (when (/= (length trial-list) (length (remove-if-not #'(lambda(x) (member num x)) vector)))
          (return-from values-known-in-cells nil)))
      (return-from values-known-in-cells t))))

(defun eliminate-known-absent (trial-list vector)
  (let ((retval (make-array *puzzle-size* :initial-element nil)))
    (dotimes (i *puzzle-size*)
      (if (subsetp trial-list (aref vector i))
          (setf (aref retval i) trial-list)
          (setf (aref retval i) (aref vector i))))
    retval))


(defun permute-reduce-lists (vector)
  "For all non-nil lists in the vector, find out if there exists a
pair of numbers which must be placed exclusively within two cells, a
trio which must be within three cells, etc.  If so, strike those
values out of other cells.  So, we get a list of all numbers
appearing, then we run over permutations of them...  pairs, triplets,
etc., and see if there are two cells holding the pair exclusively,
three on a triplet, and so on."
  (let ((uniq-vals (remove-duplicates (reduce 'union vector)))
        (num-nil (count-if 'null vector))
        (retval (make-array *puzzle-size* :initial-element nil))
        (early-exit nil))
    (do ((i 2 (1+ i)))
        ((or early-exit (= i num-nil)) retval)
      (let ((trial (unordered-permutations i uniq-vals)))
        (dolist (one-try trial)
          (when (values-known-in-cells one-try vector)
            (setf retval (eliminate-known-absent one-try vector))
            (setf early-exit t)
            (return)))))))

;; If all coords are in the same row, returns the row number, else
;; returns nil
(defun coords-all-in-row (coords-list)
  (let ((rows (remove-duplicates (mapcar #'car coords-list))))
    (when (= 1 (length rows))
      (first rows))))

(defun coords-all-in-col (coords-list)
  (let ((cols (remove-duplicates (mapcar #'cdr coords-list))))
    (when (= 1 (length cols))
      (first cols))))

(defun digit-by-coords-in-colour (digit colour)
  "Returns the coordinates within the given colour where the given
'digit' may be placed without conflicting with the known state."
  (unless (digit-in-colour digit colour)
    (let (retval)
      (dolist (coord (coords-at-colour colour))
        (unless (or (known-value (car coord) (cdr coord))
                    (digit-in-row digit (car coord))
                    (digit-in-col digit (cdr coord))
                    (phantom-digit-in-row digit (car coord) colour)
                    (phantom-digit-in-col digit (cdr coord) colour))
          (push coord retval)))
      retval)))

(defun allowed-digits-at-coords (row col)
  "Returns a list of numbers not forbidden at the given row/col.  If
we already know what's there, returns NIL."
  (when (not (known-value row col))
    (let (retval
          (colour (colour-of-coords row col)))
      (dotimes+1 (digit *puzzle-size*)
        (unless (or (digit-in-colour digit colour)
                    (digit-in-row digit row)
                    (digit-in-col digit col)
                    (phantom-digit-in-row digit row colour)
                    (phantom-digit-in-col digit col colour))
          (push digit retval)))
      retval)))

(defun digit-in-colour (digit colour)
  (find digit (aref *digits-known-in-colour* colour)))

(defun digit-in-row (digit row)
  (dotimes (col *puzzle-size*)
    (when (and (known-value row col)
               (= digit (known-value row col)))
      (return-from digit-in-row t)))
  nil)

(defun digit-in-col (digit col)
  (dotimes (row *puzzle-size*)
    (when (and (known-value row col)
               (= digit (known-value row col)))
      (return-from digit-in-col t)))
  nil)

(defun get-possible-values-by-row (row)
  (let ((retval (make-array *puzzle-size* :initial-element nil)))
    (dotimes (col *puzzle-size*)
      (setf (aref retval col) (allowed-digits-at-coords row col)))
    retval))

(defun get-possible-values-by-col (col)
  (let ((retval (make-array *puzzle-size* :initial-element nil)))
    (dotimes (row *puzzle-size*)
      (setf (aref retval row) (allowed-digits-at-coords row col)))
    retval))

(defun get-possible-values-by-colour (colour)
  (let ((retval (make-array *puzzle-size* :initial-element nil))
        (mapping (make-array *puzzle-size* :initial-element nil))
        (i 0))
    (dolist (coord (aref *coords-by-colour* colour))
      (setf (aref retval i) (allowed-digits-at-coords (car coord) (cdr coord)))
      (setf (aref mapping i) coord)
      (incf i))
    (values retval mapping)))

(defun place-digit (digit row col)
  (setf (aref *workspace* row col) digit)
  (decf *unknown-count*)
  (push digit (aref *digits-known-in-colour* (colour-of-coords row col))))


(create-easy-rule scan-puzzle
  (clear-phantoms)
  (scan-puzzle-worker))

(defun scan-puzzle-worker ()
  "Simple scan, looks for pieces forced into certain places because of
other known digits cutting off all other choices by scans."
  (repeat-while-successful retval
    (dotimes+1 (digit *puzzle-size*)
      (dotimes (colour *puzzle-size*)
        (let ((possibilities (digit-by-coords-in-colour digit colour)))
          (when (list-of-one possibilities)
            (place-digit digit (caar possibilities) (cdar possibilities))
            (setf retval t)))))))

(create-easy-rule scan-with-phantoms
  (let (retval)
    (dotimes+1 (digit *puzzle-size*)
               (clear-phantoms)
               (compute-phantoms digit)
               (when (scan-puzzle-worker)
                 (setf retval t)))
    retval))

(create-easy-rule reduce-5+
  "Do reduce operation on all rows/cols with no more than 4 unknowns."
  (clear-phantoms)
  (repeat-while-successful retval
    ;; rows
    (dotimes (row *puzzle-size*)
      (let (datalist)
        (dotimes (col *puzzle-size*)
          (unless (known-value row col)
            (push (list (cons row col) (allowed-digits-at-coords row col)) datalist)))
        (when (and datalist
                   (< (length datalist) 5)
                   (locate-values datalist))
          (setf retval t))))
    ;; columns
    (dotimes (col *puzzle-size*)
      (let (datalist)
        (dotimes (row *puzzle-size*)
          (unless (known-value row col)
            (push (list (cons row col) (allowed-digits-at-coords row col)) datalist)))
        (when (and datalist
                   (< (length datalist) 5)
                   (locate-values datalist))
          (setf retval t))))))
          
(create-easy-rule reduce-5+-block
  "Do reduce operations on all colour blocks with no more than 4 unknowns."
  (clear-phantoms)
  (repeat-while-successful retval
    (dotimes (col *puzzle-size*)
      (let (datalist)
        (dotimes (row *puzzle-size*)
          (unless (known-value row col)
            (push (list (cons row col) (allowed-digits-at-coords row col)) datalist)))
        (when (and datalist
                   (< (length datalist) 5)
                   (locate-values datalist))
          (setf retval t))))))

(create-medium-rule reduce-4-
  "Do reduce operations on all rows/cols blocks with no more than 6
unknowns, and with all phantoms known."
  (compute-all-phantoms)
  (repeat-while-successful retval
    ;; rows
    (dotimes (row *puzzle-size*)
      (let (datalist)
        (dotimes (col *puzzle-size*)
          (unless (known-value row col)
            (push (list (cons row col) (allowed-digits-at-coords row col)) datalist)))
        (when (and datalist
                   (< (length datalist) 7)
                   (locate-values datalist))
          (setf retval t))))
    ;; columns
    (dotimes (col *puzzle-size*)
      (let (datalist)
        (dotimes (row *puzzle-size*)
          (unless (known-value row col)
            (push (list (cons row col) (allowed-digits-at-coords row col)) datalist)))
        (when (and datalist
                   (< (length datalist) 7)
                   (locate-values datalist))
          (setf retval t))))))

(create-medium-rule reduce-4-block
  (compute-all-phantoms)
  (repeat-while-successful retval
    (dotimes (col *puzzle-size*)
      (let (datalist)
        (dotimes (row *puzzle-size*)
          (unless (known-value row col)
            (push (list (cons row col) (allowed-digits-at-coords row col)) datalist)))
        (when (and datalist
                   (< (length datalist) 7)
                   (locate-values datalist))
          (setf retval t))))))

(create-medium-rule reduce-by-permutations
  "OK, here's a fun one.  Sometimes, in a row/col, I can decide that
certain combinations must occur in certain positions.  For example, I
might not know where 1 or 4 go in a row, but I might know that they
must sit in two specific cells, so there can't be a 1 or 4 in any
other unassigned cells in the row."
  (compute-all-phantoms)
  (repeat-while-successful retval
    (dotimes (row *puzzle-size*)
      (let ((candidates (get-possible-values-by-row row)))
        (when (< 3 (count-if 'null candidates) 7) ;; Humans do it for 4 to 6 unknowns
          (setf candidates (permute-reduce-lists candidates))
          (let ((reduced nil))
            (dotimes (col *puzzle-size*)
              (push (list (cons row col) (aref candidates col)) reduced))
            (when (locate-values reduced)
              (setf retval t))))))
    (dotimes (col *puzzle-size*)
      (let ((candidates (get-possible-values-by-col col)))
        (when (< 3 (count-if 'null candidates) 7) ;; Humans do it for 4 to 6 unknowns
          (setf candidates (permute-reduce-lists candidates))
          (let ((reduced nil))
            (dotimes (row *puzzle-size*)
              (push (list (cons row col) (aref candidates row)) reduced))
            (when (locate-values reduced)
              (setf retval t))))))))

(create-medium-rule reduce-by-permutations-block ()
  "Sometimes, in a colour, I can decide that certain combinations must
occur in certain positions.  For example, I might not know where 1 or
4 go, but I might know that they must sit in two specific cells, so
there can't be a 1 or 4 in any other unassigned cells in the colour."
  (compute-all-phantoms)
  (let ((new-phantom-found nil))
    (or (repeat-while-successful retval
          (dotimes (colour *puzzle-size*)
            (multiple-value-bind (candidates mapping) (get-possible-values-by-colour colour)
              (when (< 3 (count-if 'null candidates) 7) ;; Humans do it for 4 to 6 unknowns
                (setf candidates (permute-reduce-lists candidates))
                (let ((reduced nil))
                  (dotimes (i *puzzle-size*)
                    (push (list (aref mapping i) (aref candidates i)) reduced))
                  ;; look for new phantoms deriving from this reduction
                  (dotimes (i *puzzle-size*)
                    (let* ((new-list (mapcar 'car (remove-if-not #'(lambda(x) (member i (cadr x))) reduced)))
                           (phantom-row (coords-all-in-row new-list))
                           (phantom-col (coords-all-in-col new-list)))
                      (when phantom-row
                        (push (list i :row phantom-row) (aref *phantoms* colour))
                        (setf new-phantom-found t))
                      (when phantom-col
                        (push (list i :col phantom-col) (aref *phantoms* colour))
                        (setf new-phantom-found t))))
                  (when (locate-values reduced)
                    (setf retval t)))))))
        (when new-phantom-found
          (repeat-while-successful ret2
            (when (scan-puzzle-worker)
              (setf ret2 t)))))))


(defun easy-rules ()
  (if *easy-rules*
      (test-while-non-nil *easy-rules*)
      t))
; '(scan-puzzle scan-with-phantoms reduce-5+ reduce-5+-block)))

(defun medium-rules ()
  (if *medium-rules*
      (test-while-non-nil *medium-rules*)
      t))
; 'reduce-4- reduce-4-block 'reduce-by-permutations
;                       'reduce-by-permutations-block))

(defun hard-rules () 
  (if *hard-rules*
      (test-while-non-nil *hard-rules*)
      t))


(defun dump-workspace ()
  (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 " (aref *workspace* i j))
        (if (= (mod j 3) 2) (format puzzle-string "  ")))
      (format puzzle-string "~%")
      (if (= (mod i 3) 2) (format puzzle-string "~%")))
    puzzle-string))


(defmacro ntimes (n &rest body)
  (let ((g (gensym))
        (h (gensym)))
    `(let ((,h ,n))
      (do ((,g 0 (+ ,g 1)))
          ((>= ,g ,h))
        ,@body))))

(defun hi ()
  (ntimes 5 (princ "hi")))