318 lines
8.3 KiB
Scheme
318 lines
8.3 KiB
Scheme
;; In Emacs, open this file in -*- Scheme -*- mode.
|
|
|
|
;; brute force sudoku solver using backtracking
|
|
|
|
|
|
;; some list functions
|
|
|
|
(defrec flat-map
|
|
(fun (f l)
|
|
(if (list-empty? l)
|
|
l
|
|
(list-append (f (list-head l)) (flat-map f (list-tail l))))))
|
|
|
|
(defrec index-of
|
|
(fun (p i l)
|
|
(if (list-empty? l)
|
|
-1
|
|
(if (p (list-head l))
|
|
i
|
|
(index-of p (+ i 1) (list-tail l))))))
|
|
|
|
(defrec list-n
|
|
(fun (init n)
|
|
(list-tabulate n (fun (i) init))))
|
|
|
|
(defrec list-get-value
|
|
(fun (list index)
|
|
(if (= 1 index)
|
|
(list-head list)
|
|
(list-get-value (list-tail list) (- index 1)))))
|
|
|
|
(defrec list-set-value
|
|
(fun (list index value)
|
|
(if (= 1 index)
|
|
(list-prepend value (list-tail list))
|
|
(list-prepend
|
|
(list-head list)
|
|
(list-set-value (list-tail list) (- index 1) value)))))
|
|
|
|
|
|
;; functions on tables
|
|
|
|
|
|
(def create-table
|
|
(fun (n)
|
|
(let ((size (* n n)))
|
|
(list-n (list-n 0 size) size))))
|
|
|
|
|
|
(defrec transpose
|
|
(fun (table)
|
|
(if (list-empty? (list-head table))
|
|
table
|
|
(list-prepend
|
|
(list-map (fun (row) (list-head row)) table)
|
|
(transpose (list-map (fun (row) (list-tail row)) table))))))
|
|
|
|
|
|
(defrec table-get-value
|
|
(fun (table cell)
|
|
(if (= 1 (list-head cell))
|
|
(list-get-value (list-head table) (list-tail cell))
|
|
(table-get-value
|
|
(list-tail table)
|
|
(list-prepend (- (list-head cell) 1) (list-tail cell))))))
|
|
|
|
|
|
(defrec table-set-value
|
|
(fun (table cell value)
|
|
(if (= 1 (list-head cell)) ;; current row?
|
|
(list-prepend
|
|
(list-set-value (list-head table) (list-tail cell) value)
|
|
(list-tail table))
|
|
(list-prepend
|
|
(list-head table)
|
|
(table-set-value
|
|
(list-tail table)
|
|
(list-prepend (- (list-head cell) 1) (list-tail cell))
|
|
value)))))
|
|
|
|
|
|
(defrec table-init
|
|
(fun (table cells values)
|
|
(if (list-empty? cells)
|
|
table
|
|
(table-init
|
|
(table-set-value table (list-head cells) (list-head values))
|
|
(list-tail cells)
|
|
(list-tail values)))))
|
|
|
|
|
|
(defrec table-get-row
|
|
(fun (table i)
|
|
(if (= 1 i)
|
|
(list-head table)
|
|
(table-get-row (list-tail table) (- i 1)))))
|
|
|
|
(def table-get-col
|
|
(fun (table i)
|
|
(table-get-row (transpose table) i)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;
|
|
;; VERIFICATION
|
|
|
|
;; no duplicates in the list (except 0's)
|
|
(defrec list-no-duplicates
|
|
(fun (list)
|
|
(if (list-empty? list)
|
|
#t
|
|
(and
|
|
(list-every?
|
|
(fun (x) (or (= x 0) (not (= (list-head list) x))))
|
|
(list-tail list))
|
|
(list-no-duplicates (list-tail list))))))
|
|
|
|
;; check if no duplicates in rows
|
|
(def rows-ok
|
|
(fun (table)
|
|
(list-every?
|
|
(fun (row) (list-no-duplicates row))
|
|
table)))
|
|
|
|
;; check if no duplicates in columns
|
|
(def cols-ok
|
|
(fun (table)
|
|
(rows-ok (transpose table))))
|
|
|
|
|
|
;; blockrows contains the first n rows of a sudoku, e.g.
|
|
;; +-----+-----+
|
|
;; | 1 2 | 3 4 |
|
|
;; | 3 4 | 1 2 |
|
|
;; +-----+-----+
|
|
(defrec %blockrows-ok
|
|
(fun (blockrows n)
|
|
(if (list-empty? (list-head blockrows))
|
|
#t
|
|
(and
|
|
(list-no-duplicates
|
|
(flat-map (fun (row) (list-take row n)) blockrows))
|
|
(%blockrows-ok (list-map (fun (row) (list-drop row n)) blockrows) n)))))
|
|
|
|
|
|
;; check if no duplicates in blocks (n x n)
|
|
(defrec blocks-ok
|
|
(fun (table n)
|
|
(if (= 0 (list-length table))
|
|
#t
|
|
(and
|
|
(%blockrows-ok (list-take table n) n)
|
|
(blocks-ok (list-drop table n) n)))))
|
|
|
|
|
|
;; no duplicates (but incomplete solution, i.e. with zeros)
|
|
(def partial-ok
|
|
(fun (table n)
|
|
(and (rows-ok table)
|
|
(cols-ok table)
|
|
(blocks-ok table n))))
|
|
|
|
|
|
;; all numbers between 0 and n
|
|
(def numbers-ok
|
|
(fun (table n)
|
|
(list-every?
|
|
(fun (num) (and (> num 0) (<= num (* n n))))
|
|
(flat-map (fun (row) row) table))))
|
|
|
|
|
|
;; sudoku solved
|
|
(def table-ok
|
|
(fun (table n)
|
|
(and (rows-ok table)
|
|
(cols-ok table)
|
|
(numbers-ok table n)
|
|
(blocks-ok table n))))
|
|
|
|
|
|
|
|
;;;;;;;;;;;
|
|
;; PRINTING
|
|
|
|
(defrec for
|
|
(fun (from to body)
|
|
(if (< from to)
|
|
(begin
|
|
(body from)
|
|
(for (+ from 1) to body))
|
|
0)))
|
|
|
|
|
|
(def %header
|
|
(fun (n)
|
|
(for 0 n
|
|
(fun (x)
|
|
(string-print "+")
|
|
(for 0 (+ (* n 2) 1)
|
|
(fun (x) (string-print "-")))))
|
|
(string-print "+")
|
|
(newline-print)))
|
|
|
|
(def %row
|
|
(fun (row n)
|
|
(for 0 (* n n)
|
|
(fun (x)
|
|
(if (= 0 (%t x n))
|
|
(string-print "| ")
|
|
0)
|
|
(let ((v (list-head (list-drop row x))))
|
|
(if (= v 0)
|
|
(string-print " ")
|
|
(int-print v))
|
|
(string-print " "))))
|
|
(string-print "|")
|
|
(newline-print)))
|
|
|
|
|
|
(def print-table
|
|
(fun (rows n)
|
|
(int-print n)
|
|
(string-print "-sudoku")
|
|
(newline-print)
|
|
(for 0 n
|
|
(fun (x)
|
|
(%header n)
|
|
(for 0 n
|
|
(fun (y)
|
|
(%row (list-head (list-drop rows (+ (* x n) y))) n)))))
|
|
(%header n)
|
|
(newline-print)))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;; SOLVING ALGORITHM
|
|
|
|
|
|
(def %next-zero-cell
|
|
(fun (table)
|
|
(let*
|
|
( (rowi
|
|
(index-of
|
|
(fun (row) (list-any? (fun (x) (= 0 x)) row))
|
|
1
|
|
table))
|
|
(row (list-head (list-drop table (- rowi 1))))
|
|
(coli
|
|
(index-of
|
|
(fun (x) (= x 0))
|
|
1
|
|
row)))
|
|
(list-prepend rowi coli))))
|
|
|
|
|
|
(def sudoku
|
|
(letrec
|
|
((%advance (fun (table cell n)
|
|
(let ((val (table-get-value table cell)))
|
|
(if (< val (* n n))
|
|
(%sudoku (table-set-value table cell (+ val 1)) cell n)
|
|
list-empty))))
|
|
;; find solutions by trying values on 'cell' of 'table'
|
|
(%sudoku (fun (table cell n)
|
|
(if (and (> (table-get-value table cell) 0) (partial-ok table n))
|
|
(if (numbers-ok table n) ;; partial solution with all numbers > 0: we're done
|
|
table
|
|
(let ((sol (%sudoku table (%next-zero-cell table) n)))
|
|
(if (list-empty? sol)
|
|
(%advance table cell n)
|
|
sol)))
|
|
(%advance table cell n)))))
|
|
(fun (table n) (%sudoku table (%next-zero-cell table) n))))
|
|
|
|
;;;;;;;;;;;;;;;
|
|
;; SOME TESTING
|
|
|
|
|
|
;; solution for
|
|
(def table2
|
|
(list-make (list-make 1 2 3 4) (list-make 3 4 1 2) (list-make 2 1 4 3) (list-make 4 3 2 1)))
|
|
|
|
;; sudoku from http://www.nzz.ch/magazin/unterhaltung/sudoku, 6.2.2009, schwer
|
|
(def nzz
|
|
(table-init
|
|
(create-table 3)
|
|
(list-append (list-make (list-prepend 1 1) (list-prepend 1 2) (list-prepend 1 6) (list-prepend 1 7) (list-prepend 2 1) (list-prepend 2 2) (list-prepend 2 5) (list-prepend 2 6) (list-prepend 2 8))
|
|
(list-append (list-make (list-prepend 2 9) (list-prepend 3 2) (list-prepend 3 3) (list-prepend 3 6) (list-prepend 3 8) (list-prepend 4 5) (list-prepend 4 8) (list-prepend 5 6) (list-prepend 5 7))
|
|
(list-append (list-make (list-prepend 6 3) (list-prepend 6 5) (list-prepend 6 9) (list-prepend 7 3) (list-prepend 7 4) (list-prepend 7 6) (list-prepend 7 8) (list-prepend 8 1) (list-prepend 8 2))
|
|
(list-make (list-prepend 9 1) (list-prepend 9 6) (list-prepend 9 7)))))
|
|
(list-append (list-make 1 9 5 4 6 3 9 2 7)
|
|
(list-append (list-make 8 5 7 6 2 4 9 7 2)
|
|
(list-append (list-make 3 1 7 1 8 4 6 4 8)
|
|
(list-make 7 1 3))))))
|
|
|
|
|
|
;; example sudoku (very hard to solve for brute force algorithm), from
|
|
;; http://en.wikipedia.org/wiki/Algorithmics_of_sudoku#Solving_sudokus_by_a_brute-force_algorithm
|
|
(def hard
|
|
(table-init
|
|
(create-table 3)
|
|
(list-append (list-make (list-prepend 2 6) (list-prepend 2 8) (list-prepend 2 9) (list-prepend 3 3) (list-prepend 3 5) (list-prepend 4 4) (list-prepend 4 6) (list-prepend 5 3) (list-prepend 5 7))
|
|
(list-make (list-prepend 6 2) (list-prepend 7 1) (list-prepend 7 8) (list-prepend 7 9) (list-prepend 8 3) (list-prepend 8 5) (list-prepend 9 5) (list-prepend 9 9)))
|
|
(list-append (list-make 3 8 5 1 2 5 7 4 1) (list-make 9 5 7 3 2 1 4 9))))
|
|
|
|
|
|
;; empty 2-sudoku (quick)
|
|
(print-table (sudoku (create-table 2) 2) 2)
|
|
|
|
;; empty 3-sudoku (some seconds)
|
|
(print-table (sudoku (create-table 3) 3) 3)
|
|
|
|
;; nzz 3-sudoku (some seconds)
|
|
(print-table (sudoku nzz 3) 3)
|
|
|
|
;; very hard 3-sudoku (about an hour?)
|
|
;; (print-table (sudoku hard 3) 3)
|