Helloo every1 i have written a sudoku puzzle for 4x4 matrix which generates random solutions. But in the same program i'd like to modify the solve function by using two constraints
Rule 1: If in any unfilled grid cells (1x1) only a single number can be placed without conflicts that number should be fixed.
Rule 2: If a number can be placed in just one grid cell (1x1) in an entire row, column, or N-sized cell it should be fixed.
But i am unable to do so, if any1 can help me out with that and tell me wat all changes we hav2 make in the program to make it solve not only for random but also using the two constraints . I am attaching the code below for your reference.
Waiting for the reply,
Thanks.
(defun shuffle (l)
(do ((oldl l) (newl nil) (i 0 (+ i 1)) (elt 0))
((= i (length l)) newl)
(setf elt (random (length oldl)))
(setf newl (cons (nth elt oldl) newl))
(setf oldl (remove (nth elt oldl) oldl))))
(defun make-sudoku-4x4 (curr)
(let ((i nil) (j nil) (k nil) (elt nil))
(setf elt (shuffle '(1 2 3 4)))
(dotimes (j 4)
(setf k (aref curr 0 j))
(setf (aref curr 0 j) (nth (- k 1) elt)))
(solve-4x4 curr)
(format t "~% BOARD: ~A" curr)
(do ((done 0))
((>= done 16) curr)
(setf i (random 4))
(setf j (random 4))
(setf elt (aref curr i j))
;; (format t "~% hello: ~A ~A" i j)
(cond (elt (setf (aref curr i j) nil)
(cond ((> (howmany-sol-4x4 curr) 1) (incf done) (setf (aref curr i j) elt))
(t nil)))
(t nil)))))
;; return true if the elements share a column, a row, or a 2x2 cell
(defun conflict-4x4 (l1 l2)
(cond ((eq (first l1) (first l2)) t)
((eq (second l1) (second l2)) t)
((or (and (<= (first l1) 1) (> (second l1) 1) (<= (first l2) 1) (> (second l2) 1)) ;; 0-1 X 2-3
(and (<= (first l1) 1) (<= (second l1) 1) (<= (first l2) 1) (<= (second l2) 1)) ;; 0-1 X 0-1
(and (> (first l1) 1) (<= (second l1) 1) (> (first l2) 1) (<= (second l2) 1)) ;; 2-3 X 0-1
(and (> (first l1) 1) (> (second l1) 1) (> (first l2) 1) (> (second l2) 1))) ;; 2-3 X 2-3
t)
(t nil)))
(defun my-copy-list (l)
(let ((new-l nil) (l1 nil) (l2 nil))
(dolist (elt l)
(setf l1 (copy-list (first elt)))
(setf l2 (copy-list (second elt)))
(setf new-l (cons (list l1 l2) new-l)))
new-l))
;; count solutions for given val at loc
(defun count-solutions (loc val old-empty)
;; (format t "~%loc: ~A, val = ~A, CALLED: empty = ~A" loc val old-empty)
(let ((num-sol 0) (fail nil) (new-empty (my-copy-list old-empty)))
(dolist (e-elt new-empty)
(if (conflict-4x4 (first e-elt) loc)
(setf (second e-elt) (remove val (second e-elt))))
(if (null (second e-elt)) (setf fail t)))
;; (format t "~%MID-Empty: ~A" new-empty)
;; (format t "~% FIRST OF EMPTY: ~A " (first new-empty))
(cond (fail (setf num-sol 0))
((null new-empty) (setf num-sol 1))
(t (dolist (e-elt (second (first new-empty)))
(setf num-sol (+ num-sol (count-solutions (first (first new-empty)) e-elt (rest new-empty)))))))
;; (format t "~%AFTER: Empty: ~A" new-empty)
;; (format t "~%num-sol: ~A" num-sol)
num-sol
))
(defun howmany-sol-4x4 (curr)
(let ((fixed nil) (empty nil) (elt nil) (num-sol 0))
;; initialize empty and fixed lists
(dotimes (i 4)
(dotimes (j 4)
(setf elt (aref curr i j))
(if elt (setf fixed (cons (list (list i j) elt) fixed))
(setf empty (cons (list (list i j) (list 1 2 3 4)) empty)))))
;; fill in allowable values for empty
(dolist (f-elt fixed)
(dolist (e-elt empty)
(if (conflict-4x4 (first f-elt) (first e-elt))
(setf (second e-elt) (remove (second f-elt) (second e-elt))))))
;; find if there is a unique solution
;; (format t "~%Fixed: ~A" fixed)
;; (format t "~%FIRST:Empty: ~A" empty)
(dolist (e-elt (second (first empty)))
;; (format t "~% MAIN: loc = ~A, val = ~A, empty = ~A" (first (first empty)) e-elt (rest empty))
(setf num-sol (+ num-sol (count-solutions (first (first empty)) e-elt (my-copy-list (rest empty))))))
num-sol
))
(defun make-4x4 ()
(let ((curr (make-array '(4 4))))
(setf curr #2a((1 2 3 4) (nil nil nil nil) (nil nil nil nil) (nil nil nil nil)))
(setf (aref curr 0 0) 1)
(setf (aref curr 0 1) 2)
(setf (aref curr 0 2) 3)
(setf (aref curr 0 3) 4)
(setf (aref curr 1 0) nil)
(setf (aref curr 1 1) nil)
(setf (aref curr 1 2) nil)
(setf (aref curr 1 3) nil)
(setf (aref curr 2 0) nil)
(setf (aref curr 2 1) nil)
(setf (aref curr 2 2) nil)
(setf (aref curr 2 3) nil)
(setf (aref curr 3 0) nil)
(setf (aref curr 3 1) nil)
(setf (aref curr 3 2) nil)
(setf (aref curr 3 3) nil)
(make-sudoku-4x4 curr)
curr))
;; find solutions for given val at loc
(defun find-solutions (loc val old-empty)
;; (format t "~%loc: ~A, val = ~A, CALLED: empty = ~A" loc val old-empty)
(let ((fail nil) (new-empty (my-copy-list old-empty)) (success nil) (elt nil))
(dolist (e-elt new-empty)
(if (conflict-4x4 (first e-elt) loc)
(setf (second e-elt) (remove val (second e-elt))))
(if (null (second e-elt)) (setf fail t)))
;; (format t "~%MID-Empty: ~A" new-empty)
;; (format t "~% FIRST OF EMPTY: ~A " (first new-empty))
(cond (fail nil)
((null new-empty) (list (list loc val)))
(t (do ((l (shuffle (second (first new-empty)))) (res nil))
((or success (null l)) res)
(setf elt (first l))
(setf l (rest l))
(setf res (find-solutions (first (first new-empty)) elt (my-copy-list (rest new-empty))))
(cond ((null res) nil)
(t (setf res (cons (list loc val) res))
(setf success t))))))
))
(defun solve-4x4 (curr)
;; (format t "~% curr = ~A" curr)
(let ((fixed nil) (empty nil) (elt nil))
;; initialize empty and fixed lists
(dotimes (i 4)
(dotimes (j 4)
(setf elt (aref curr i j))
(if elt (setf fixed (cons (list (list i j) elt) fixed))
(setf empty (cons (list (list i j) (list 1 2 3 4)) empty)))))
;; fill in allowable values for empty
(dolist (f-elt fixed)
(dolist (e-elt empty)
(if (conflict-4x4 (first f-elt) (first e-elt))
(setf (second e-elt) (remove (second f-elt) (second e-elt))))))
;; find if there is a unique solution
;; (format t "~%Fixed: ~A" fixed)
;; (format t "~%FIRST:Empty: ~A" empty)
(dolist (e-elt (second (first empty)))
;; (format t "~% MAIN: loc = ~A, val = ~A, empty = ~A" (first (first empty)) e-elt (rest empty))
(setf fixed (append fixed (find-solutions (first (first empty)) e-elt (my-copy-list (rest empty))))))
;; (format t "~% fixed = ~A" fixed)
(dolist (f-elt fixed)
;; (format t "~% f-elt = ~A" f-elt)
(setf (aref curr (first (first f-elt)) (second (first f-elt))) (second f-elt)))
curr
))
