Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.

Programming Challenge - SUDOKU

hak_vz
Advisor

Programming Challenge - SUDOKU

hak_vz
Advisor
Advisor

Hello everyone!

Merry Christmas and Happy New Year!

Attached is a skeleton lisp for the Sudoku game. After you start the SUDOKU command, a grid is created and you can choose from random games depending on how difficult a challenge you want, easy, moderate or hard.

What I would like to solve in this programming task is the following:

1) Create text entity reactors to test if your input is correct

2) Add automatic candidates to empty cells

3) Solver.

 

You can play the game as is, but as a community effort we can create something beautiful.

To play another set, undo everything and restart command SUDOKU!

 

Happy programming!

 

sudoku.PNG

 

 

Miljenko Hatlak

EESignature

Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
0 Likes
Reply
389 Views
5 Replies
Replies (5)

marko_ribar
Advisor
Advisor

There are several topics about SUDOKU on world wide web. Here is the one I participated... My solution is coded like I am to solve it with paper and pencil, so I know if it finds solution I'd find it too, only in some time longer than with PC... Stefan's version of solver is very much advanced and it can solve the hardest one, which me and Stefan can't do with paper and pencil... So here is the link for those interested : https://www.theswamp.org/index.php?topic=53547.0 

Regards, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes

doaiena
Collaborator
Collaborator

This will brute force its way through every sudoku ...eventually. 😂

 

 

(defun c:test ( / LM:SubstNth LM:sublst LM:group<n Solve IsValid GetRow GetCol Get3x3 WriteNum result sudoku nums lastRow lastCol)

;;---------------------=={ Subst Nth }==----------------------;;
;;                                                            ;;
;;  Substitutes an item at the nth position in a list.        ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  a - item to substitute                                    ;;
;;  n - position in list to make the substitution             ;;
;;  l - list in which to make the substitution                ;;
;;------------------------------------------------------------;;
;;  Returns:  Resultant list following the substitution       ;;
;;------------------------------------------------------------;;

(defun LM:SubstNth ( a n l / i )
    (setq i -1)
    (mapcar '(lambda ( x ) (if (= (setq i (1+ i)) n) a x)) l)
);defun


;; Sublst  -  Lee Mac
;; The list analog of the substr function
;; lst - [lst] List from which sublist is to be returned
;; idx - [int] Zero-based index at which to start the sublist
;; len - [int] Length of the sublist or nil to return all items following idx

(defun LM:sublst ( lst idx len / rtn )
    (setq len (if len (min len (- (length lst) idx)) (- (length lst) idx))
          idx (+  idx len)
    )
    (repeat len (setq rtn (cons (nth (setq idx (1- idx)) lst) rtn)))
);defun


;; Group by Number  -  Lee Mac
;; Groups a list 'l' into a list of lists, each of max length 'n'

(defun LM:group<n ( l n / a b m )
    (while l
        (setq m n)
        (while (and l (< 0 m))
            (setq a (cons (car l) a)
                  l (cdr l)
                  m (1- m)
            )
        )
        (setq b (cons (reverse a) b)
              a nil
        )
    )
    (reverse b)
);defun


(defun Solve (sudoku row col)

  (if (= row 9)
    T
    (if	(= col 9)
      (Solve sudoku (1+ row) 0)
      (if (/= (nth col (nth row sudoku)) 0)
	(Solve sudoku row (1+ col))
	(progn
	  (foreach num nums
	    (if	(IsValid sudoku row col num)
	      (Solve (setq sudoku (WriteNum sudoku row col num)) row (1+ col))
	    )
	  )
	  (if (and (= lastRow row) (= lastCol col))
	    (setq result sudoku)
	  )
	)
      )
    )
  )
  result
);defun


(defun IsValid (sudoku row col num)

(and
(not (vl-position num (GetRow sudoku row)))
(not (vl-position num (GetCol sudoku col)))
(not (vl-position num (Get3x3 sudoku row col)))
)

);defun


(defun GetRow (sudoku row)
(nth row sudoku)
);defun


(defun GetCol (sudoku col)
(mapcar '(lambda (n) (nth col n)) sudoku)
);defun


(defun Get3x3 (sudoku row col / lst)

(setq row (1- (* (/ row 3) 3)))
(repeat 3
(setq lst (cons (LM:sublst (nth (setq row (1+ row)) sudoku) (* (/ col 3) 3) 3) lst))
)
(apply 'append (reverse lst))
);defun


(defun WriteNum (sudoku row col num / lst)
(setq lst (GetRow sudoku row))
(LM:SubstNth (LM:SubstNth num col lst) row sudoku)
);defun


(defun FindLastEmptyCell (sudoku / row)

(setq row 8 lastCol nil)
(while (and (not lastCol) (>= row 0))
(setq lastRow row)
(if (setq cell (vl-position 0 (reverse (GetRow sudoku row))))
(setq lastCol (- 8 cell))
)
(setq row (1- row))
)
);defun



(setq nums (list 1 2 3 4 5 6 7 8 9))
(setq sudoku '((2 0 0) (0 8 0) (3 0 0) (0 6 0) (0 7 0) (0 8 4) (0 3 0) (5 0 0) (2 0 9) (0 0 0) (1 0 5) (4 0 8) (0 0 0) (0 0 0) (0 0 0) (4 0 2) (7 0 6) (0 0 0) (3 0 1) (0 0 7) (0 4 0) (7 2 0) (0 4 0) (0 6 0) (0 0 4) (0 1 0) (0 0 3)))

;my solver takes the sudoku in the form:
;((2 0 0 0 8 0 3 0 0) (0 6 0 0 7 0 0 8 4) (0 3 0 5 0 0 2 0 9) (0 0 0 1 0 5 4 0 8) (0 0 0 0 0 0 0 0 0) (4 0 2 7 0 6 0 0 0) (3 0 1 0 0 7 0 4 0) (7 2 0 0 4 0 0 6 0) (0 0 4 0 1 0 0 0 3))
(setq sudoku (LM:group<n (apply 'append sudoku) 9))

(FindLastEmptyCell sudoku);sets lastRow lastCol
(Solve sudoku 0 0)
);defun

 

0 Likes

doaiena
Collaborator
Collaborator

The speed of my previous code was unacceptable even for my low standards. 😂

 

Instead of modifying existing lists and pushing them up and down the stack, i decided to work on a static list this time. The list is made up of global symbols that are set individually so that list manipulation is down to a minimum. This code is still a brute force approach, but it should run in a reasonable ammount of time even for the worst case puzzles. Its probably x100+ times faster than the previous version i posted.

EDIT:
I made another slight optimization in my code, but it wasn't worth making another post, so i just edited this one. It now runs another 20-30% faster. It's still possible to make it a further 9-10% faster by removing the functoin calls and inlining everything, but that makes the code harder to read and understand.

 

 

 

 

 

 

 

(defun SolveSudoku (lst / ClearVars PrepSudoku GetRow GetCol Get3x3 IsValid WriteNum Solve sudoku nums lastRow lastCol done result rows cols)

(defun ClearVars ( / ctr)
(setq ctr 0)
(repeat 100
(set (read (strcat "n" (itoa ctr))) nil)
(set (read (strcat "row" (itoa ctr))) nil)
(set (read (strcat "col" (itoa ctr))) nil)
(set (read (strcat "grid" (itoa ctr))) nil)
(setq ctr (1+ ctr))
)
(setq rows nil cols nil)
);defun

(defun PrepSudoku (lst / ctr rowCtr colCtr)

(ClearVars)

(setq ctr 0 sudoku nil)
(foreach num lst
(set (read (strcat "n" (itoa ctr))) num)
(setq sudoku (cons (read (strcat "n" (itoa ctr))) sudoku))
(setq ctr (1+ ctr))
)
(setq sudoku (reverse sudoku))

(setq ctr 0 rowCtr 0)
(repeat 9
(repeat 9
(set (read (strcat "row" (itoa rowCtr))) (cons (read (strcat "n" (itoa ctr))) (vl-symbol-value (read (strcat "row" (itoa rowCtr))))))
(setq ctr (1+ ctr))
)
(setq rowCtr (1+ rowCtr))
)

(setq colCtr 0)
(repeat 9
(setq ctr colCtr)
(repeat 9
(set (read (strcat "col" (itoa colCtr))) (cons (read (strcat "n" (itoa ctr))) (vl-symbol-value (read (strcat "col" (itoa colCtr))))))
(setq ctr (+ ctr 9))
)
(setq colCtr (1+ colCtr))
)

(setq
grid0 '(n0 n1 n2 n9 n10 n11 n18 n19 n20)
grid1 '(n3 n4 n5 n12 n13 n14 n21 n22 n23)
grid2 '(n6 n7 n8 n15 n16 n17 n24 n25 n26)
grid3 '(n27 n28 n29 n36 n37 n38 n45 n46 n47)
grid4 '(n30 n31 n32 n39 n40 n41 n48 n49 n50)
grid5 '(n33 n34 n35 n42 n43 n44 n51 n52 n53)
grid6 '(n54 n55 n56 n63 n64 n65 n72 n73 n74)
grid7 '(n57 n58 n59 n66 n67 n68 n75 n76 n77)
grid8 '(n60 n61 n62 n69 n70 n71 n78 n79 n80)
)

(setq rows (list row0 row1 row2 row3 row4 row5 row6 row7 row8))
(setq cols (list col0 col1 col2 col3 col4 col5 col6 col7 col8))
(setq nums (list 1 2 3 4 5 6 7 8 9))
(GetLastCell)
);defun

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun GetLastCell ( / pos)
(setq pos (- 80 (vl-position 0 (mapcar 'vl-symbol-value (reverse sudoku)))) lastCol (rem pos 9) lastRow (/ pos 9))
);defun

(defun GetRow (row)
(mapcar 'vl-symbol-value (nth row rows))
);defun

(defun GetCol (col)
(mapcar 'vl-symbol-value (nth col cols))
);defun

(defun Get3x3 (row col)
(mapcar 'vl-symbol-value
(cond
((< row 3) (cond ((< col 3) grid0) ((< col 6) grid1) (T grid2)))
((< row 6) (cond ((< col 3) grid3) ((< col 6) grid4) (T grid5)))
(T (cond ((< col 3) grid6) ((< col 6) grid7) (T grid8)))
)
)
);defun

(defun IsValid (row col num)
(and
(not (vl-position num (GetRow row)))
(not (vl-position num (GetCol col)))
(not (vl-position num (Get3x3 row col)))
)
);defun

(defun WriteNum (row col num)
(set (nth (+ (* row 9) col) sudoku) num)
);defun

(defun Solve (row col)
  (if (/= row 9)
    (if	(/= col 9)
      (if (= (vl-symbol-value (nth (+ (* row 9) col) sudoku)) 0)
	(foreach num nums
	    (if	(IsValid row col num)
	      (progn
		(WriteNum row col num)
		(if (and (= lastRow row) (= lastCol col))
		  (setq	result (mapcar 'vl-symbol-value sudoku) done T)
		)
		(Solve row (1+ col))
		(if (not done)
		  (WriteNum row col 0)
		)
	      )
	    )
	  )
	(Solve row (1+ col))
      )
      (Solve (1+ row) 0)
    )
  )
  result
);defun

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(PrepSudoku lst)
(setq result (Solve 0 0))
(ClearVars)

result
);defun




;this time the solver takes the sudoku in the form:
(setq sudoku '(2 0 0 0 8 0 3 0 0 0 6 0 0 7 0 0 8 4 0 3 0 5 0 0 2 0 9 0 0 0 1 0 5 4 0 8 0 0 0 0 0 0 0 0 0 4 0 2 7 0 6 0 0 0 3 0 1 0 0 7 0 4 0 7 2 0 0 4 0 0 6 0 0 0 4 0 1 0 0 0 3))
(SolveSudoku sudoku)

 

 

 

 

 

 

0 Likes

doaiena
Collaborator
Collaborator

A bit less code, a bit less readable, a tiny bit faster.

 

(defun SolveSudoku (lst / ClearVars PrepSudoku GetRow GetCol Get3x3 IsValid WriteNum Solve sudoku nums lastRow lastCol done result rows cols pos row col)

(defun ClearVars ( / ctr)
(setq ctr 0)
(repeat 80
(set (read (strcat "n" (itoa ctr))) nil)
(set (read (strcat "row" (itoa ctr))) nil)
(set (read (strcat "col" (itoa ctr))) nil)
(set (read (strcat "grid" (itoa ctr))) nil)
(setq ctr (1+ ctr))
)
);defun

(defun PrepSudoku (lst / ctr ctr2 rowCtr colCtr)

(ClearVars)

(setq ctr 0)
(foreach num lst
(set (read (strcat "n" (itoa ctr))) num)
(setq sudoku (cons (read (strcat "n" (itoa ctr))) sudoku))
(setq ctr (1+ ctr))
)

(setq ctr 0 ctr2 0 rowCtr 0 colCtr 0)
(repeat 9
(setq ctr2 colCtr)
(repeat 9
(set (read (strcat "row" (itoa rowCtr))) (cons (read (strcat "n" (itoa ctr))) (vl-symbol-value (read (strcat "row" (itoa rowCtr))))))
(set (read (strcat "col" (itoa colCtr))) (cons (read (strcat "n" (itoa ctr2))) (vl-symbol-value (read (strcat "col" (itoa colCtr))))))
(setq ctr (1+ ctr) ctr2 (+ ctr2 9))
)
(setq rowCtr (1+ rowCtr) colCtr (1+ colCtr))
)

(setq
grid0 '(n0 n1 n2 n9 n10 n11 n18 n19 n20)
grid1 '(n3 n4 n5 n12 n13 n14 n21 n22 n23)
grid2 '(n6 n7 n8 n15 n16 n17 n24 n25 n26)
grid3 '(n27 n28 n29 n36 n37 n38 n45 n46 n47)
grid4 '(n30 n31 n32 n39 n40 n41 n48 n49 n50)
grid5 '(n33 n34 n35 n42 n43 n44 n51 n52 n53)
grid6 '(n54 n55 n56 n63 n64 n65 n72 n73 n74)
grid7 '(n57 n58 n59 n66 n67 n68 n75 n76 n77)
grid8 '(n60 n61 n62 n69 n70 n71 n78 n79 n80)
)

(setq rows (list row0 row1 row2 row3 row4 row5 row6 row7 row8))
(setq cols (list col0 col1 col2 col3 col4 col5 col6 col7 col8))
(setq nums (list 1 2 3 4 5 6 7 8 9))
(setq pos (- 80 (vl-position 0 (mapcar 'vl-symbol-value sudoku))) lastCol (rem pos 9) lastRow (/ pos 9) sudoku (reverse sudoku))
);defun

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun IsValid (num)
(and
(not (vl-position num (mapcar 'vl-symbol-value (nth row rows))))
(not (vl-position num (mapcar 'vl-symbol-value (nth col cols))))
(not (vl-position num (mapcar 'vl-symbol-value
(cond
((< row 3) (cond ((< col 3) grid0) ((< col 6) grid1) (T grid2)))
((< row 6) (cond ((< col 3) grid3) ((< col 6) grid4) (T grid5)))
(T (cond ((< col 3) grid6) ((< col 6) grid7) (T grid8)))
)
)))
)
);defun

(defun Solve (row col / idx)
  (if (/= row 9)
    (if	(/= col 9)
      (if (= (vl-symbol-value (nth (setq idx (+ (* row 9) col)) sudoku)) 0)
	(foreach num (vl-remove-if-not 'IsValid nums)
	  (set (nth idx sudoku) num)
	  (if (and (= lastRow row) (= lastCol col))
	    (setq result (mapcar 'vl-symbol-value sudoku))
	  )
	  (Solve row (1+ col))
	  (if (not result) (set (nth idx sudoku) 0))
	)
	(Solve row (1+ col))
      )
      (Solve (1+ row) 0)
    )
  )
  result
);defun

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(PrepSudoku lst)
(setq result (Solve 0 0))
(ClearVars)

result
);defun
0 Likes

john.uhden
Mentor
Mentor

Thank you @hak_vz .

My wife and I both like Sudoku.  We use different techniques.

It looks like fun and probably requires lists like ROW, COLUMN, and BOX.

Being unemployed, I have plenty of time for my hobby except my wife counts spending my time with AutoLisp as dawdling, eg. "Can't you see that the sofa cushions need arranging?" or "Haven't you noticed that my foot hurts a lot today?  Do something!" or "The car needs to be moved 6 inches to the right!" or "That TV I never use isn't working.  Fix it!" or "Get all those shopping bags out of the car." followed shortly by "Get those shopping bags in the car; we have to go to the supermarket!" or "Can't you do something more useful than looking for a job?"

John F. Uhden