;;;; Sudoku resitel
;;;; semestralni prace z 36JUI
;;;; spust: (solve)

;;;; soubor se vstupni mrizkou vypada napr.:
;;;; ((0 8 0 0 0 0 0 2 0)
;;;;  (0 0 1 0 0 0 6 0 0)
;;;;  (2 0 0 0 5 0 0 0 3)
;;;;  (0 0 6 5 0 1 2 0 0)
;;;;  (0 0 0 6 0 4 0 0 9)
;;;;  (0 0 4 7 0 9 3 0 0)
;;;;  (6 0 0 0 1 0 0 0 5)
;;;;  (0 0 7 0 0 0 9 0 0)
;;;;  (0 4 0 0 0 0 0 3 0))


;;; Globalni promenne
(defparameter *grid* nil) ;Vysledna mrizka
(defparameter *size* 0) ;Pocet sloupcu a radek v mrizce
(defparameter *subSize* 0) ;Pocet radku a sloupcu v podmrizce
(defparameter *numbers* nil) ;Souradnice sloupcu/radek
(defparameter *subNumbers* nil) ;Souradnice podmrizek

;;; Test na duplicity v seznamu
(defun hasDuplicates (ls)
  (labels ((hasDuplicatesTemp (ls acc)
             (cond ((null ls) nil)
                   ((member (car ls) acc) t)
                   (t (hasDuplicatesTemp (cdr ls) (cons (car ls) acc))))))
    (hasDuplicatesTemp ls nil)))

;;; Vraci seznam cisel pouzitych v radce
(defun usedInRow (i)
  (let ((res nil))
    (dotimes (n *size*)
      (let ((e (aref *grid* i n)))
        (if (not (= e 0)) (push e res))))
    res))  

;;; Vraci seznam cisel pouzitych v sloupci
(defun usedInCol (j)
  (let ((res nil))
    (dotimes (n *size*)
      (let ((e (aref *grid* n j)))
        (if (not (= e 0)) (push e res))))
    res))

;;; Vraci seznam cisel pouzitych v podmrizce
(defun usedInSubgrid (i j)
  (let ((res nil) 
        (gi (* (floor (/ i *subSize*)) *subSize*))
        (gj (* (floor (/ j *subSize*)) *subSize*)))
      (dotimes (k *subSize*)
        (dotimes (l *subSize*)
          (let ((e (aref *grid* (+ gi k) (+ gj l))))
            (if (not (= e 0)) (push e res)))))
      res))

;;; Mrizka vyplnena?
(defun isComplete ()
  (labels (
           ;; Radek vyplneny?
           (isCompleteRow (i)
             (= (length (remove-duplicates (usedInRow i))) *size*))

           ;; Sloupec vyplneny?
           (isCompleteCol (j)
             (= (length (remove-duplicates (usedInCol j))) *size*))


           ;; Podmrizka vyplnena?
           (isCompleteSubgrid (ij)
             (= (length (remove-duplicates (usedInSubgrid (car ij) (cadr ij))))
                *size*)))

  (and (every #'isCompleteCol *numbers*)
       (every #'isCompleteRow *numbers*)
       (every #'isCompleteSubgrid *subNumbers*)
       *grid*)))

;;; Vraci seznam cisel vhodnych na pozici i, j
(defun validAt (i j)
  (labels (
           ;; Vraci seznam cisel nevhodnych na pozici na i,j
           (usedIn (i j)
             (remove-duplicates 
              (append (usedInSubgrid i j) (usedInRow i) (usedInCol j)))))

    (set-difference (mapcar #'(lambda (x) (+ x 1)) *numbers*) (usedIn i j))))

;;; Vraci seznam souradnic, kterych se dotkne zmena na i,j
(defun affectedAt (i j)
  (labels (
           ;; Kartezsky soucin
           (cartesian (ls1 ls2)
             (cartesianTemp ls1 ls2 nil))

           (cartesianTemp (ls1 ls2 acc)
             (cond ((null ls1) acc)
                   (t (cartesianTemp (cdr ls1) ls2
                                      (append (mapcar #'(lambda (ele) (list (car ls1) ele)) ls2)
                                              acc)))))

           ;; Vraci seznam vysledku volani funkce fn s argumenty 0 az n-1
           (mapFn (fn n)
             (let ((acc nil))
               (dotimes (i n)
                 (push (funcall fn i) acc))
               (reverse acc))))

    (let ((gi (* (floor (/ i *subSize*)) *subSize*))
          (gj (* (floor (/ j *subSize*)) *subSize*)))
      (remove-duplicates 
       (append (mapFn #'(lambda (n) (list i n)) *size*) ; sloupce
               (mapFn #'(lambda (n) (list n j)) *size*) ; radky
               (cartesian (mapFn #'(lambda (n) (+ gi n)) *subSize*)
                          (mapFn #'(lambda (n) (+ gj n)) *subSize*))) ; podmrizka
       :test #'equal))))

;;; Odstrani cislo na pozici i,j z pole array
(defun setAffected (array i j)
  (mapc #'(lambda (ij)
            (setf (aref array (car ij) (cadr ij)) 
                  (remove (aref *grid* i j) (aref array (car ij) (cadr ij)))))
        (affectedAt i j)) ; odstrani z radku,sloupce,podmrizky
  (setf (aref array i j) nil) ; odstrani z pozice i,j
  array)

(defun solveGrid (array)
  (labels (
           ;; Vraci podle delek serazeny seznam vhodnych kandidatu na pozice v mrize array.
           ;; Polozka seznamu = (delka seznamu vhodnych kandidatu, i , j)
           (tryPositions (array)
             (let ((res nil))
               (dotimes (i *size*)
                 (dotimes (j *size*)
                   (if (aref array i j) ; pouze pro nevyresena policka
                       (push (list (length (aref array i j)) i j) res))))
               (sort res #'< :key #'car)))

           ;; kopiruje pole
           (copyArray (array)
             (let ((new (make-array (array-dimensions array) :displaced-to array)))
               (adjust-array new (array-dimensions array) :displaced-to nil))))
    
  (let* ((tryList (tryPositions array))
         (i (cadar tryList))
         (j (caddar tryList)))
    (cond  ((null tryList)
            (isComplete))
           (t 
            (dolist (ele (aref array i j)) ; zkus nastavit a resit dal
              (setf (aref *grid* i j) ele)
              (if (solveGrid (setAffected (copyArray array) i j))
                (return-from solveGrid *grid*)))
            (setf (aref *grid* i j) 0) ; slepa ulicka
            nil)))))

;;; Nahraj mrizku a res
(defun solve ()
  (labels (
           ;; Load grid and set sizes from file
           (readFromFile (filename)
             (with-open-file (str filename :direction :input)
               (read str)))

           ;; Vytvori mrizku s vhodnymi kandidaty na pozicich
           (makeValid ()
             (let ((array (make-array (list *size* *size*) :initial-element nil)))
               (dotimes (i *size*)
                 (dotimes (j *size*)
                   (if (= (aref *grid* i j) 0) (setf (aref array i j) (validAt i j)))))
               array)))

  (princ "Jmeno souboru: ")
  (if (not (setGrid (readFromFile (format nil "~A" (read)))))
      (return-from solve nil)) ; spatny vstupni soubor
  (if (isBad)
      (return-from solve nil)) ; spatna mrizka s duplicitami

  ;; inicializace
  (setf *numbers* nil)
  (setf *subNumbers* nil)
  (dotimes (i *size*)
    (setf *numbers* (cons i *numbers*)))
  (do ((i 0 (+ i *subSize*)))
      ((>= i *size*))
    (do ((j 0 (+ j *subSize*)))
        ((>= j *size*))
      (setf *subNumbers* (cons (list i j) *subNumbers*))))

  (if (solveGrid (makeValid)) ;; reseni
      (printGrid))))

;;; nastavi mrizku a promene podle pole
(defun setGrid (content)
  (let ((line 0))
    (setf *size* (length content))
    (setf *subSize* (sqrt *size*))
    (if (= *subSize* (round *subSize*))
        (setf *subSize* (round *subSize*))
        (progn
          (princ "Velikost musi byt mocnina 2 nebo 3, 4 ...")
          (return-from setGrid nil)))
    (mapcar #'(lambda (S)
                (if (= *size* (length S))
                    (progn
                      (incf line)
                      (mapcar #'(lambda (i)
                                  (if (not (and (>= i 0) (<= i *size*)))
                                      (progn
                                        (format t "Na radku ~A je cislo ~A mimo meze (0-~A)" line i *size*)
                                        (return-from setGrid nil))))
                              S))
                    (progn
                      (format t "Delka radku ~A (~A) nesouhlasi s ~A, ale je ~A" line S *size*  (length S))
                      (return-from setGrid nil))))
            content)
    (setf *grid* (make-array (list *size* *size*)
                             :initial-contents content)))
  t
)

;;; Test, zda mrizka obsahuje duplicity. Nuly se nepocitji
(defun isBad ()
  (labels (
           ;; Hleda duplicity v radce
           (isBadRow (i)
             (if (hasDuplicates (usedInRow i))
                 (progn
                   (format t "V radce ~A je duplicita" (+ i 1))
                   t)))

           ;; Hleda duplicity v sloupci
           (isBadCol (j)
             (if (hasDuplicates (usedInCol j))
                 (progn
                   (format t "V sloupci ~A je duplicita" (+ j 1))
                   t)))

           ;; Hleda duplicity v podmrizce
           (isBadSubgrid (ij)
             (if (hasDuplicates (usedInSubgrid (car ij) (cadr ij)))
                 (progn
                   (format t "V podmrizce ~A,~A je duplicita" (+ (car ij) 1) (+ (cadr ij) 1))
                   t))))


    (or (some #'isBadRow *numbers*)
        (some #'isBadCol *numbers*)
        (some #'isBadSubgrid *subNumbers*))))

;;; vytiskne mrizku
(defun printGrid()
  (mapcar #'(lambda (line)
              (mapcar #'(lambda (row)
                          (format t "~A " (aref *grid* line row)))
                      (reverse *numbers*))
              (format t  "~%"))
          (reverse *numbers*))
  t)