ikarus/lab/sudoku-2.ss

620 lines
20 KiB
Scheme

;;; Rich Lewis
;;; Sudoku Puzzle Solver Version 2.0
;;; Hopefully someday, I'll work out a better user interface, but it
;;; serves its purpose for now. Feel free to pass it around to anyone
;;; who is interested in sudoku puzzles and wants a solver written in
;;; scheme.
;;;
;;; Rich Lewis
;(print-vector-length #f)
(define make-table
(lambda (nr nc init)
(let ([tbl (make-vector nr)])
(let insert-rows! ([i 0])
(unless (= i nr)
(vector-set! tbl i (make-vector nc init))
(insert-rows! (+ i 1))))
tbl)))
(define table-set!
(lambda (tbl ri ci x)
(vector-set! (vector-ref tbl ri) ci x)))
(define table-ref
(lambda (tbl ri ci)
(vector-ref (vector-ref tbl ri) ci)))
(define make-grid
(lambda ()
(let ([grid (make-table 9 9 #f)])
(let row-loop ([row 0])
(if (= row 9)
grid
(let col-loop ([col 0])
(if (= col 9)
(row-loop (+ row 1))
(begin
(table-set! grid row col (make-vector 9 1))
(col-loop (+ col 1))))))))))
(define grid (make-grid))
(define grid-ref
(lambda (x y)
(table-ref grid y x)))
(define grid-set!
(lambda (x y val)
(table-set! grid y x val)))
(define reset-row
(lambda (row)
(let loop ([i 0])
(unless (= i 9)
(grid-set! row i (make-vector 9 1))
(loop (+ i 1))))))
(define reset-grid
(lambda ()
(let row-loop ([row 0])
(unless (= row 9)
(let col-loop ([col 0])
(if (= col 9)
(row-loop (+ row 1))
(begin
(grid-set! row col (make-vector 9 1))
(col-loop (+ col 1)))))))))
(define input-grid
(lambda ()
(printf " Sudoku Puzzle Solver~%~%")
(printf "Starting in the top left-hand corner, input either a 0 for a~%")
(printf "blank space or a number between 1 and 9. Then press enter and~%")
(printf "repeat across the first row. Return to the beginning of the~%")
(printf "next row and input each row until the end. If a number is~%")
(printf "mis-entered, inputing \"s\" will return to the beginning. \"r\" will~%")
(printf "restart the current row and \"q\" will quit the program altogether.~%~%")
(printf "When the last cell (9,9) is entered, the puzzle will automatically~%")
(printf "be solved and the result printed in a simple grid.~%~%")
(let row-loop ([i 0])
(unless (= i 9)
(let col-loop ([j 0])
(if (= j 9)
(begin
(newline)
(row-loop (+ i 1)))
(begin
(printf "cell ~a, ~a: " (+ i 1) (+ j 1))
(let ([c (read)])
(cond
[(and (number? c) (> c 0) (< c 10)) (begin
(grid-set! i j c)
(col-loop (+ j 1)))]
[(equal? c '0) (begin
(grid-set! i j (make-vector 9 1))
(col-loop (+ j 1)))]
[(equal? c 'q) (row-loop 9)]
[(equal? c 'r) (begin
(reset-row i)
(col-loop 0))]
[(equal? c 's) (begin
(reset-grid)
(row-loop 0))]
[else (begin
(printf "invalid input ~a~%" c)
(col-loop j))])))))))))
(define input-block
(lambda (block)
(unless (= (length block) 10)
(error 'input-block "invalid block"))
(let f ([i 0] [ls (cdr block)])
(unless (= i 9)
(let ([str (car ls)])
(unless (and (string? str) (= (string-length str) 9))
(error 'input-block "invalid string ~s" str))
(for-each
(lambda (c j)
(grid-set! i j
(case c
[(#\0) (make-vector 9 1)]
[(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(- (char->integer c) (char->integer #\0))]
[else (error 'input-block "invalid char ~s" c)])))
(string->list str)
'(0 1 2 3 4 5 6 7 8)))
(f (add1 i) (cdr ls))))))
(define print-sudoku
(lambda ()
(printf " column ~%")
(printf " 1 2 3 4 5 6 7 8 9~%")
(newline)
(let row-loop ([row 0])
(unless (= row 9)
(printf "~a " (+ row 1))
(let col-loop ([col 0])
(if (= col 9)
(begin
(newline)
(row-loop (+ row 1)))
(begin
(if (vector? (grid-ref row col))
(printf " ")
(printf "~a " (grid-ref row col)))
(col-loop (+ col 1)))))))))
(define sub-grid-list
(lambda (sub)
(case sub
[(0) '(0 2 0 2)]
[(1) '(0 2 3 5)]
[(2) '(0 2 6 8)]
[(3) '(3 5 0 2)]
[(4) '(3 5 3 5)]
[(5) '(3 5 6 8)]
[(6) '(6 8 0 2)]
[(7) '(6 8 3 5)]
[(8) '(6 8 6 8)])))
(define sub-grid-list2
(lambda (row col)
(case row
[(0 1 2)
(case col
[(0 1 2) 0]
[(3 4 5) 1]
[(6 7 8) 2])]
[(3 4 5)
(case col
[(0 1 2) 3]
[(3 4 5) 4]
[(6 7 8) 5])]
[(6 7 8)
(case col
[(0 1 2) 6]
[(3 4 5) 7]
[(6 7 8) 8])])))
(define row->vector
(lambda (row)
(let ([vec (make-vector 9 #f)])
(let loop ([i 0])
(if (= i 9)
vec
(begin
(vector-set! vec i (grid-ref row i))
(loop (+ i 1))))))))
(define row-init
(lambda (row)
(vector->row (vector-init (row->vector row)) row)))
(define row-init-all
(lambda ()
(let loop ([i 0])
(unless (= i 9)
(row-init i)
(loop (+ i 1))))))
(define col->vector
(lambda (col)
(let ([vec (make-vector 9 #f)])
(let loop ([i 0])
(if (= i 9)
vec
(begin
(vector-set! vec i (grid-ref i col))
(loop (+ i 1))))))))
(define col-init
(lambda (col)
(vector->col (vector-init (col->vector col)) col)))
(define col-init-all
(lambda ()
(let loop ([i 0])
(unless (= i 9)
(col-init i)
(loop (+ i 1))))))
(define sub-grid->vector
(lambda (sub-grid)
(let ([sub (sub-grid-list sub-grid)])
(let ([vec (make-vector 9 #f)] [row1 (car sub)] [row2 (cadr sub)]
[col1 (caddr sub)] [col2 (cadddr sub)])
(let loop1 ([i row1] [k 0])
(if (= k 9)
vec
(let loop2 ([j col1] [k k])
(if (= j (+ col2 1))
(loop1 (+ i 1) k)
(begin
(vector-set! vec k (grid-ref i j))
(loop2 (+ j 1) (+ k 1)))))))))))
(define sub-grid-init
(lambda (sub)
(vector->sub-grid (vector-init (sub-grid->vector sub)) sub)))
(define sub-grid-init-all
(lambda ()
(let loop ([i 0])
(unless (= i 9)
(sub-grid-init i)
(loop (+ i 1))))))
(define vector->row
(lambda (vec row)
(let loop ([i 0])
(unless (= i 9)
(grid-set! row i (vector-ref vec i))
(loop (+ i 1))))))
(define vector->col
(lambda (vec col)
(let loop ([i 0])
(unless (= i 9)
(grid-set! i col (vector-ref vec i))
(loop (+ i 1))))))
(define vector->sub-grid
(lambda (vec sub-grid)
(let ([sub (sub-grid-list sub-grid)])
(let ([row1 (car sub)] [row2 (cadr sub)]
[col1 (caddr sub)] [col2 (cadddr sub)])
(let loop1 ([i row1] [k 0])
(unless (= k 9)
(let loop2 ([j col1] [k k])
(if (= j (+ col2 1))
(loop1 (+ i 1) k)
(begin
(grid-set! i j (vector-ref vec k))
(loop2 (+ j 1) (+ k 1)))))))))))
(define vector-init
(lambda (vec)
(let main-loop ([i 0])
(if (= i 9)
vec
(let ([x (vector-ref vec i)])
(if (vector? x)
(main-loop (+ i 1))
(let sub-loop ([j 0])
(if (= j 9)
(main-loop (+ i 1))
(let ([y (vector-ref vec j)])
(if (vector? y)
(begin
(vector-set! y (- x 1) 0)
(sub-loop (+ j 1)))
(sub-loop (+ j 1))))))))))))
(define grid-init
(lambda ()
(row-init-all)
(col-init-all)
(sub-grid-init-all)))
(define one-possible?
(lambda (vec)
(let loop ([i 0] [count 0])
(if (= i 9)
(= count 1)
(if (= (vector-ref vec i) 1)
(loop (+ i 1) (+ count 1))
(loop (+ i 1) count))))))
(define replace-one
(lambda (vec)
(let loop ([i 0])
(if (= (vector-ref vec i) 1)
i
(loop (+ i 1))))))
(define level-one-row
(lambda (row)
(let loop ([i 0] [count 0] [vec (row->vector row)])
(if (= i 9)
count
(let ([x (vector-ref vec i)])
(if (vector? x)
(if (one-possible? x)
(begin
(grid-set! row i (+ (replace-one x) 1))
(row-init row)
(col-init i)
(sub-grid-init (sub-grid-list2 row i))
(loop (+ i 1) (+ count 1) (row->vector row)))
(loop (+ i 1) count vec))
(loop (+ i 1) count vec)))))))
(define level-one-pass
(lambda ()
(let loop ([i 0] [count 0])
(if (= i 9)
count
(loop (+ i 1) (+ count (level-one-row i)))))))
(define level-one
(lambda ()
(let loop ()
(unless (= (level-one-pass) 0)
(loop)))))
(define level-two-row
(lambda (row)
(let loop1 ([i 0] [count1 0] [vec (row->vector row)])
(if (= i 9)
count1
(let loop2 ([j 0] [count2 0] [col 0])
(if (= j 9)
(if (= count2 1)
(begin
(grid-set! row col (+ i 1))
(row-init row)
(col-init col)
(sub-grid-init (sub-grid-list2 row col))
(loop1 (+ i 1) (+ count1 1) (row->vector row)))
(loop1 (+ i 1) count1 vec))
(begin
(let ([x (vector-ref vec j)])
(if (vector? x)
(if (= (vector-ref x i) 1)
(loop2 (+ j 1) (+ count2 1) j)
(loop2 (+ j 1) count2 col))
(loop2 (+ j 1) count2 col))))))))))
(define level-two-row-pass
(lambda ()
(let loop ([i 0] [count 0])
(if (= i 9)
count
(loop (+ i 1) (+ count (level-two-row i)))))))
(define level-two-col
(lambda (col)
(let loop1 ([i 0] [count1 0] [vec (col->vector col)])
(if (= i 9)
count1
(let loop2 ([j 0] [count2 0] [row 0])
(if (= j 9)
(if (= count2 1)
(begin
(grid-set! row col (+ i 1))
(row-init row)
(col-init col)
(sub-grid-init (sub-grid-list2 row col))
(loop1 (+ i 1) (+ count1 1) (col->vector col)))
(loop1 (+ i 1) count1 vec))
(begin
(let ([x (vector-ref vec j)])
(if (vector? x)
(if (= (vector-ref x i) 1)
(loop2 (+ j 1) (+ count2 1) j)
(loop2 (+ j 1) count2 row))
(loop2 (+ j 1) count2 row))))))))))
(define level-two-col-pass
(lambda ()
(let loop ([i 0] [count 0])
(if (= i 9)
count
(loop (+ i 1) (+ count (level-two-col i)))))))
(define level-two-sub
(lambda (sub)
(let loop1 ([i 0] [count1 0] [vec (sub-grid->vector sub)])
(if (= i 9)
count1
(let loop2 ([j 0] [count2 0] [loc 0])
(if (= j 9)
(if (= count2 1)
(begin
(let ([row (+ (car (sub-grid-list sub)) (quotient loc 3))]
[col (+ (caddr (sub-grid-list sub)) (modulo loc 3))])
(grid-set! row col (+ i 1))
(row-init row)
(col-init col)
(sub-grid-init sub))
(loop1 (+ i 1) (+ count1 1) (sub-grid->vector sub)))
(loop1 (+ i 1) count1 vec))
(begin
(let ([x (vector-ref vec j)])
(if (vector? x)
(if (= (vector-ref x i) 1)
(loop2 (+ j 1) (+ count2 1) j)
(loop2 (+ j 1) count2 loc))
(loop2 (+ j 1) count2 loc))))))))))
(define level-two-sub-pass
(lambda ()
(let loop ([i 0] [count 0])
(if (= i 9)
count
(loop (+ i 1) (+ count (level-two-sub i)))))))
(define vector-count
(lambda (vec)
(let loop ([i 0] [count 0])
(if (= i 9)
count
(if (= (vector-ref vec i) 1)
(loop (+ i 1) (+ count 1))
(loop (+ i 1) count))))))
(define replace-2
(lambda (vec loc1 loc2)
(let loop1 ([i 0] [count1 0])
(if (= i 9)
(list count1 vec)
(let ([x (vector-ref vec i)])
(if (and (vector? x) (not (= loc1 i)) (not (= loc2 i)))
(let loop2 ([j 0] [count2 count1])
(if (= j 9)
(loop1 (+ i 1) count2)
(let ([y (vector-ref vec loc1)])
(if (and (= (vector-ref y j) 1) (= (vector-ref x j) 1))
(begin
(vector-set! (vector-ref vec i) j 0)
(loop2 (+ j 1) (+ count2 1)))
(loop2 (+ j 1) count2)))))
(loop1 (+ i 1) count1)))))))
(define level-three-col
(lambda (col)
(let loop1 ([i 0] [count1 0] [vec (col->vector col)])
(if (= i 9)
count1
(let ([x1 (vector-ref vec i)])
(if (vector? x1)
(let loop2 ([j 0])
(if (= j 9)
(loop1 (+ i 1) count1 vec)
(let ([x2 (vector-ref vec j)])
(if (and (vector? x2) (not (= i j)) (equal? x1 x2))
(let ([y1 (vector-count x1)])
(case y1
[(2) (begin
(let ([z (replace-2 vec i j)])
(if (= (car z) 0)
(loop2 (+ j 1))
(begin
(vector->col (cadr z) col)
(loop1 (+ i 1) (+ count1 (car z)) (col->vector col))))))]
[(3) (loop2 (+ j 1))]
[(else) (loop2 (+ j 1))]))
(loop2 (+ j 1))))))
(loop1 (+ i 1) count1 vec)))))))
(define done?
(lambda ()
(let row-loop ([row 0] [count 0])
(if (= row 9)
(= count 0)
(let col-loop ([col 0] [count count])
(if (= col 9)
(row-loop (+ row 1) count)
(let ([x (grid-ref row col)])
(if (vector? x)
(col-loop (+ col 1) (+ count 1))
(col-loop (+ col 1) count)))))))))
(define invalid?
(lambda ()
(let row-loop ([row 0] [count 0])
(if (= row 9)
(> count 0)
(let col-loop ([col 0] [count count])
(if (= col 9)
(row-loop (+ row 1) count)
(let ([x (grid-ref row col)])
(if (and (vector? x) (= (vector-count x) 0))
(col-loop (+ col 1) (+ count 1))
(col-loop (+ col 1) count)))))))))
(define copy-grid
(lambda ()
(let ([grid-orig (make-grid)])
(let row-loop ([row 0])
(if (= row 9)
grid-orig
(let col-loop ([col 0])
(if (= col 9)
(row-loop (+ row 1))
(let ([x1 (table-ref grid row col)] [y1 (table-ref grid-orig col row)])
(if (not (vector? x1))
(begin
(table-set! grid-orig col row x1)
(col-loop (+ col 1)))
(let vector-loop ([loc 0])
(if (= loc 9)
(col-loop (+ col 1))
(let ([x2 (vector-ref x1 loc)] [y2 (vector-ref y1 loc)])
(vector-set! y1 loc x2)
(vector-loop (+ loc 1))))))))))))))
(define restore-grid
(lambda (grid-orig)
(reset-grid)
(let row-loop ([row 0])
(unless (= row 9)
(let col-loop ([col 0])
(if (= col 9)
(row-loop (+ row 1))
(let ([x1 (table-ref grid row col)] [y1 (table-ref grid-orig row col)])
(if (not (vector? y1))
(begin
(grid-set! row col y1)
(col-loop (+ col 1)))
(let vector-loop ([loc 0])
(if (= loc 9)
(col-loop (+ col 1))
(let ([y2 (vector-ref y1 loc)])
(vector-set! (grid-ref row col) loc y2)
(vector-loop (+ loc 1)))))))))))))
(define level-four
(lambda ()
(let row-loop ([row 0])
(unless (= row 9)
(let col-loop ([col 0])
(if (= col 9)
(row-loop (+ row 1))
(let ([x (grid-ref row col)])
(if (and (vector? x) (= (vector-count x) 2))
(let vector-loop ([loc 0])
(if (= loc 9)
(col-loop (+ col 1))
(let ([x2 (grid-ref row col)])
(if (= (vector-ref x2 loc) 1)
(let ([grid-orig (copy-grid)])
(vector-set! (grid-ref row col) loc 0)
(if (sudoku-help grid)
#t
(begin
(restore-grid grid-orig)
(vector-loop (+ loc 1)))))
(vector-loop (+ loc 1))))))
(col-loop (+ col 1))))))))))
(define sudoku-help
(lambda (grid)
(grid-init)
(let loop ()
(cond
[(and (number? (level-one-pass)) (> (level-one-pass) 0)) (loop)]
[(invalid?) #f]
[(and (number? (level-two-row-pass)) (> (level-two-row-pass) 0)) (loop)]
[(and (number? (level-two-col-pass)) (> (level-two-col-pass) 0)) (loop)]
[(and (number? (level-two-sub-pass)) (> (level-two-sub-pass) 0)) (loop)]
[(done?) #t]
[else (level-four)]))))
(define sudoku
(lambda (block)
(define grid (make-grid))
(input-block block)
(if (sudoku-help grid)
(print-sudoku)
(error 'sudoku "MIS-ENTERED INITIALIZATION"))))
(define quotient fxquotient)
(define modulo fxmodulo)
(define do-file
(lambda ()
(let f ()
(let ([x (read)])
(unless (eof-object? x)
(sudoku x)
(f))))))
(with-input-from-file "sudoku.txt" do-file)
(with-input-from-file "sudoku-hard.txt" do-file)
(exit)
;;; vim:syntax=scheme