Solving Sudokus in Scheme Using Simulated Annealing

This program's purpose is to solve sudokus using simulated annealing. It first fills all the 3x3 blocks in the sudoku such that every block is filled with 1-9. It also builds a list of pairs of indices that may be switched, which is every pair of squares that were empty in the input, and are in the same block. So by design, before the simulated annealing starts, every block contains all it should contain, and whilst doing the simulated annealing we will not change the what's in the block, but will change the position within the block. In the end we want all rows and colums to be filled correctly as well. This is where the simulated annealing comes in. We assign a board a score: the sum of how many numbers are missing from every row and column. We want this to approach zero.

So, at random we will choose a pair of indices to switch. If this reduces the score (= fewer numbers missing) we will accept it. If not, we will accept it with a certain chance, being e^((oldscore-newscore)/c). c here is called the heat, and it will vary. Whilst the score is improving we decrease the heat, making for less randomness so we don't lose our progress. Whilst we're stuck, we will increase the heat, hoping that we will get out of the local minimum.

One uses the program as follows: One loads the definitions into the interpreter. Then one can use (parse-sudoku "a string which codifies a sudoku") to go from a string to a sudoku (examples of such a string included and explained in the code). Then one uses (simulated-annealing sudoku) to start the solving process. Examples are included so you could do (simulated-annealing (choice test-sudokus)) to test something immediatly after loading the definitions.

I have tried using a functional style, though here and there I have used some imperative programming to allow easier IO and some optimizations, but I've tried to contain it; IO only happens in the parser and the actual solver, and everything else is contained to the method, except for IO there should be no side effects anywhere.

Small disclaimer: This was tested in Chez-Scheme, and might not work in other Scheme implementations. Also, it uses (display "\033c") to refresh the terminal. If your terminal does not support this, it will probably look a bit weird.

Here's the code:

; Util

;;; Defines a function with the following identity:
;;; ((curry f . xs) . ys) = (f . (append xs ys))
(define (curry f . xs)
(lambda ys
(apply f (append xs ys))))

;;; Returns a list of numbers, starting at first, incrementing by jump, up to the
;;; last number below limit. jump is optional and 1 by default.
(define (range first limit . jump)
(set! jump
(if (not (null? jump))
(car jump)
1))
(if (>= first limit)
(list)
(cons first (range (+ jump first) limit jump))))

;;; Returns items, with all instances of item removed
(define (delete items item)
(if (null? items)
items
(if (equal? (car items) item)
(delete (cdr items) item)
(cons (car items) (delete (cdr items) item)))))

;;; Returns items, with everything in deletions removed
(define (delete-all items deletions)
(if (null? deletions)
items
(delete-all (delete items (car deletions))
(cdr deletions))))

;;; Returns a list of either (cons a b) or (cons b a) for all combination of any
;;; a and b in xs, except if a = b
;;; unordered-cartesian-product-without-indenticals is a bit long
(define (productish xs)
(define (do xs)
(if (or (null? xs) (null? (cdr xs)))
(list)
(append (map (lambda (x) (cons (car xs) x))
(cdr xs))
(productish (cdr xs)))))
(do xs))

;;; Returns a random item in items
(define (choice items)
(list-ref items (random (length items))))

; Sudoku model

;;; These are definitions related to the model of sudoku puzzles

;;; A sudoku is stored as a vector, which basically contains all the rows of
;;; the puzzle, concatenated.
;;; Actual values are stored as themselves, and empty values are stored as
;;; zeroes.
;;; A block of the sudoku is a 3x3 part of the sudoku, from left to right,
;;; top to bottom, 0 through 8.

;;; Indices:
;;;
;;; 0  1  2  3  4  5  6  7  8
;;; 9  10 11 12 13 14 15 16 17
;;; 18 19 20 21 22 23 24 25 26
;;; 27 28 29 30 31 32 33 34 35
;;; 36 37 38 93 40 41 42 43 44
;;; 45 46 47 48 49 50 51 52 53
;;; 54 55 56 57 58 59 60 61 62
;;; 63 64 65 66 67 68 69 70 71
;;; 72 73 74 75 76 77 78 79 80

;;; Blocks:
;;;
;;; o-oo-oo-o
;;; |0||1||2|
;;; o-oo-oo-o
;;; o-oo-oo-o
;;; |3||4||5|
;;; o-oo-oo-o
;;; o-oo-oo-o
;;; |6||7||8|
;;; o-oo-oo-o

;;; Maps a string of digits to a sudoku
(define (parse-sudoku input)
(define (chars->nums cs)
(map (lambda (x) (- x 48))
(map char->integer cs)))
(list->vector (chars->nums (string->list input))))

;;; Pretty-ish-prints the sudoku puzzle
(define (print-sudoku sudoku)
(define (print x)
(display x)
(newline))
(for-each print
(map (curry row sudoku) (range 0 9))))

;;; Get the number in the sudoku at the provided position
(define (pos sudoku position)
(vector-ref sudoku position))

;;; Map a list of positions to a list of the numbers at these positions
(define (positions sudoku locs)
(list->vector
(map (curry pos sudoku) locs)))

;;; Get a list of all the numbers in a certain row of the sudoku
(define (row sudoku n)
(positions sudoku (range (* 9 n) (* 9 (+ n 1)) 1)))

;;; Get a list of all the numbers in a certain column of the sudoku
(define (col sudoku n)
(positions sudoku (range n 81 9)))

;;; Get a list of all the indices of numbers in a certain 3x3 block
(define (block-indices n)
(apply append
(map (lambda (x) (list x (+ x 9) (+ x 18)))
(let* ((x (mod n 3))
(y (div n 3))
(m (+ (* 3 x) (* 27 y))))
(list m (+ m 1) (+ m 2))))))

;;; Get a list of all the numbers in a certain 3x3 block of the sudoku
(define (block sudoku n)
(positions (block-indices n)))

;;; Given some collection that should contain the numbers 1-9, rate
;;; Lower is better
(define (score-set items)
(define items-list (vector->list items))
(define (condition x)
(member x items-list))
(- 9 (length (filter condition (range 1 10)))))

;;; Assign a score (lower is better) to the sudoku
(define (score sudoku)
(define rows
(map (curry row sudoku) (range 0 9)))
(define cols
(map (curry col sudoku) (range 0 9)))
(apply + (map score-set (append rows cols))))

;;; Get the indices of empties/zeroes in a block
(define (empties-of-block sudoku n)
(filter (lambda (x) (= 0 (vector-ref sudoku x)))
(block-indices n)))

;;; All allowed switches (within block, keep original intact)
(define (switches sudoku)
(define (switch sudoku n m)
(define new (vector-copy sudoku))
(vector-set! new n (vector-ref sudoku m))
(vector-set! new m (vector-ref sudoku n))
new)
(define pairs
(apply append
(map (lambda (x) (productish (empties-of-block sudoku x)))
(range 0 9))))
(map (lambda (pair)
(lambda (sudoku)
(switch sudoku (car pair) (cdr pair))))
pairs))

;;; Fill all blocks with 1-9, not mutating the original numbers
(define (fill sudoku)
(define new (vector-copy sudoku))
(define (fill-block! sudoku n)
(define empties (empties-of-block sudoku n))
(define filling (delete-all (range 1 10)
(map (curry vector-ref sudoku)
(delete-all (block-indices n)
empties))))
(define (set-position! pos val)
(vector-set! new pos val))
(define (fill! empties filling)
(if (null? empties)
values
(begin (set-position! (car empties) (car filling))
(fill! (cdr empties) (cdr filling)))))
(fill! empties filling))
(for-each (curry fill-block! new)
(range 0 9))
new)

; Algorithm and Test-Cases

(define test-sudokus
(map parse-sudoku
(list
"700100000020000015000006390200018000040090070000750003078500000560000040000001002"
"003020600900305001001806400008102900700000008006708200002609500800203009005010300"
"200080300060070084030500209000105408000000000402706000301007040720040060004010003"
"000000907000420180000705026100904000050000040000507009920108000034059000507000000"
"030050040008010500460000012070502080000603000040109030250000098001020600080060020"
"020810740700003100090002805009040087400208003160030200302700060005600008076051090"
"100920000524010000000000070050008102000000000402700090060000000000030945000071006"
"043080250600000000000001094900004070000608000010200003820500000000000005034090710"
"480006902002008001900370060840010200003704100001060049020085007700900600609200018"
"000900002050123400030000160908000000070000090000000205091000050007439020400007000"
)))

(define (simulated-annealing sudoku)
(define (print-info sudoku score lowscore heat)
(display "\033c")
(print-sudoku sudoku)
(newline)
(display "Score: ")
(display score)
(newline)
(display "Best: ")
(display lowscore)
(newline)
(display "Heat: ")
(display heat)
(newline))
(define moves (switches sudoku))
(define streak-treshold 40)
(define (cool-down c)
(* c 0.99))
(define (heat-up c)
(* c 1.05))
(define (accept? old new heat)
(< (random 1.0)
(exp (/ (- old new) heat))))
(define (go old heat streak lowscore)
(let* ((move (choice moves))
(new (move old))
(oldscore (score old))
(newscore (score new)))
(print-info old oldscore lowscore heat)
(if (= oldscore 0)
(begin (display "\033c")
(print-sudoku old))
(let ((newlowscore (if (< oldscore lowscore) oldscore lowscore))
(streak-reached (> streak streak-treshold)))
(if (accept? oldscore newscore heat)
(go new (cool-down heat) 0 newlowscore)
(go old
(if streak-reached
(heat-up heat)
heat)
(if streak-reached
0
(+ streak 1))
newlowscore))))))
(go (fill sudoku) 1 0 162))
• Why is index 66 not used in the documentation on "Indices"? – Roland Illig Oct 30 '16 at 6:53
• Because I made a mistake :( – Wysaard Oct 30 '16 at 7:05