Sudoku solver

sudoku.rkt

#lang racket

;;; problem-board and solved-board are included as examples
;;; (solve problem-board) should produce the same result as solved-board

(require rackunit)

;; A board is a 9-vector of 9-vectors (rows) of board-cells
(define (board? xs)
  (define (row? r)
    (and (vector? r)
         (= 9 (vector-length r))
         (for/and ([n r])
           (board-cell? n))))
  (and (vector? xs)
       (= 9 (vector-length xs))
       (for/and ([x xs]) (row? x))))
;; A board-cell is one of
;; -- a list of numbers between 1 and 9 (inclusive)
(define (board-cell? bc)
  (and (list? bc)
       (for/and ([x bc])
         (and (number? x)
              (>= x 1)
              (<= x 9)))))

(define blank-board-cell (for/list ([x 9]) (add1 x)))
(define blank-row (make-vector 9 blank-board-cell))
(define blank-board (make-vector 9 blank-row))

;; Access an entry in the board
;; e.g. (board-ref blank-board 3 5) -> '(1 2 3 4 5 6 7 8 9)
;;      if partial-fill is a board with '(5) one right from the top left corner
;;                                  and '(3 4 6) the lower left corner
;;       then (board-ref partial-fill 0 1) -> '(5)
;;            (board-ref partial-fill 8 0) -> '(3 4 6)
;; board-ref : board number number -> board-cell
(define (board-ref b row col)
  (vector-ref (vector-ref b row) col))

;; Functional update for an entry in the board
;; e.g. (board-update blank-board 0 1 '(5)) produces a board like blank-board,
;;      but with the cell one right of the upper-left corner changed to '(5)
;; board-update : board number number board-cell -> board
(define (board-update b target-row target-col new-cell)
  (for/vector ([row 9])
    (for/vector ([col 9])
      (cond [(and (= row target-row)
                  (= col target-col))
             new-cell]
            [else (board-ref b row col)]))))

;; Extract a row from a board
;; e.g. (extract-row blank-board 4) -> list where all entries are blank
;;      (extract-row partial-fill 0) -> list where #1 is 5 and others are blank
;; extract-row : board number -> (listof board-cell)
(define (extract-row b row)
  (for/list ([col 9]) (board-ref b row col)))

;; Extract a column from a board
;; e.g. (extract-col blank-board 4) -> list where all entries are blank
;;      (extract-col partial-fill 1) -> list where #0 is 5, others blank
;; extract-row : board number -> (listof board-cell)
(define (extract-column b col)
  (for/list ([row 9]) (board-ref b row col)))

;; Extract a 3x3 subblock from a board
;; e.g. (extract-block blank-board 0 0) -> list where all entries are blank
;;      (extract-block partial-fill 0 0) -> list where #1 is 5, others blank
;; extract-row : board number -> (listof board-cell)
(define (extract-block b block-row block-col)
  (for*/list ([row-offset 3]
              [col-offset 3])
    (define row (+ row-offset (* 3 block-row)))
    (define col (+ col-offset (* 3 block-col)))
    (board-ref b row col)))

;; Determine whether the given board has contradictory entries
;; e.g. (contradict? blank-board) -> #f
;;      if row-fail-board has the same number in (8,2) and (8,8)
;;      then (contradict? row-fail-board) -> #t
;;      if col-fail-board has the same number in (7,3) and (1,3)
;;      then (contradict? col-fail-board) -> #t
;;      if diag-fail-board has the same number in (3,3) and (4,5)
;;      then (contradict? diag-fail-board) -> #t
;; contradict? : board -> boolean
(define (contradict? b)
  (not (and (row-valid? b)
            (column-valid? b)
            (block-valid? b))))

;; Count how many times the given entry appears in the given list
;; e.g. (count-instances _ '()) -> 0
;;      (count-instances 3 '(2 3 5 34 3)) -> 2
;; count-instance : A (listof A) -> number
(define (count-instances x xs)
  (length (filter ((curry equal?) x) xs)))

; Determine whether any row in the board has duplicated numbers
;; e.g. (row-valid? row-fail-board) -> #f
;;      (row-valid? col-fail-board) -> #t
;;      (row-valid? diag-fail-board) -> #t
(define (row-valid? b)
  (for/and ([row 9])
    (define current-row (extract-row b row))
    (for/and ([item 9])
      (<= (count-instances (list (add1 item)) current-row) 1))))

; Determine whether any row in the board has duplicated numbers
;; e.g. (col-valid? row-fail-board) -> #f
;;      (col-valid? col-fail-board) -> #t
;;      (col-valid? diag-fail-board) -> #t
(define (column-valid? b)
  (for/and ([col 9])
    (define current-column (extract-column b col))
    (for/and ([item 9])
      (<= (count-instances (list (add1 item)) current-column) 1))))

; Determine whether any row in the board has duplicated numbers
;; e.g. (block-valid? row-fail-board) -> #t
;;      (block-valid? col-fail-board) -> #t
;;      (block-valid? diag-fail-board) -> #f
(define (block-valid? b)
  (for*/and ([row 3] [col 3])
    (define current-block (extract-block b row col))
    (for/and ([item 9])
      (<= (count-instances (list (add1 item)) current-block) 1))))


;; Identify the first cell in the board that has not been determined
;; e.g. (first-unknown blank-board) -> 0 0
;;      (first-unknown (board-update blank-board 0 0 '(2 3))) -> 0 0
;;      (first-unknown (board-update blank-board 0 0 '(3))) -> 0 1
;;      (first-unknown filled-board) -> #f
;; first-unknown : board -> (OR (pair number number) #f)
(define (first-unknown b)
  (for*/first ([row 9]
               [col 9]
               #:when (> (length (board-ref b row col)) 1))
    (cons row col)))

;; Determine whether the given board is completely filled (even if invalid)
;; e.g. (filled? filled-board) -> #t
;;      (filled? solved-board) -> #t
;;      (filled? blank-board) -> #f
;; filled? : board -> boolean
(define (filled? b)
  (for*/and ([row 9] [col 9])
    (= 1 (length (board-ref b row col)))))

;; Determined whether the given board is solved (filled and not contradictory)
;; e.g. (solved? filled-board) -> #f
;;      (solved? solved-board) -> #t
;;      (solved? blank-board) -> #f
;; solved? : board -> boolean
(define (solved? b) (and (filled? b) (not (contradict? b))))


;; Construct a solution for the given board, or return #f if there is none
;; solve : board -: (OR board #f)
(define (solve b)
  (cond 
    ; if the board is already solved, it is its own solution
    [(solved? b) b]
    ; if it's contradictory, it cannot be solved
    [(contradict? b) #f]
    ; otherewise, identify the first unknown cell and recursively try
    ; all of its possible entries
    [else
     (define coords (first-unknown b))
     (define row (car coords))
     (define col (cdr coords))
     (define possible-guesses (board-ref b row col))
     (for/or ([guess possible-guesses])
       (solve (board-update b row col (list guess))))]))


;;;-----------------------------------------------------------------------------
;;; Tests
;;;-----------------------------------------------------------------------------
(define bc blank-board-cell)
(define br blank-row)
(define partial-fill
  (vector (vector bc '(5) bc bc bc bc bc bc bc)
          br br br br br br br
          (vector '(3 4 6) bc bc bc bc bc bc bc bc)))
(define row-fail-board
  (vector br br br br br br br br
          (vector bc bc '(7) bc bc bc bc bc '(7))))
(define col-fail-board
  (vector br
          (vector bc bc bc '(4) bc bc bc bc bc)
          br br br br br
          (vector bc bc bc '(4) bc bc bc bc bc)
          br))
(define diag-fail-board
  (vector br br br
          (vector bc bc bc '(2) bc bc bc bc bc)
          (vector bc bc bc bc bc '(2) bc bc bc)
          br br br br))
(define filled-board (for/vector ([r 9]) (for/vector ([c 9]) '(1))))
(define problem-board
  (vector (vector '(5) '(3) bc bc '(7) bc bc bc bc)
          (vector '(6) bc bc '(1) '(9) '(5) bc bc bc)
          (vector bc '(9) '(8) bc bc bc bc '(6) bc)
          (vector '(8) bc bc bc '(6) bc bc bc '(3))
          (vector '(4) bc bc '(8) bc '(3) bc bc '(1))
          (vector '(7) bc bc bc '(2) bc bc bc '(6))
          (vector bc '(6) bc bc bc bc '(2) '(8) bc)
          (vector bc bc bc '(4) '(1) '(9) bc bc '(5))
          (vector bc bc bc bc '(8) bc bc '(7) '(9))))
(define solved-board
  '#(#((5) (3) (4) (6) (7) (8) (9) (1) (2))
     #((6) (7) (2) (1) (9) (5) (3) (4) (8))
     #((1) (9) (8) (3) (4) (2) (5) (6) (7))
     #((8) (5) (9) (7) (6) (1) (4) (2) (3))
     #((4) (2) (6) (8) (5) (3) (7) (9) (1))
     #((7) (1) (3) (9) (2) (4) (8) (5) (6))
     #((9) (6) (1) (5) (3) (7) (2) (8) (4))
     #((2) (8) (7) (4) (1) (9) (6) (3) (5))
     #((3) (4) (5) (2) (8) (6) (1) (7) (9))))
(define almost-solved-board (board-update solved-board 0 0 blank-board-cell))


;; board?
(check-equal? (board? blank-board) #t)
(check-equal? (board? partial-fill) #t)
(check-equal? (board? row-fail-board) #t)
(check-equal? (board? col-fail-board) #t)
(check-equal? (board? diag-fail-board) #t)
(check-equal? (board? (board-update blank-board 0 0 0)) #f)

;; board-ref
(check-equal? (board-ref partial-fill 0 1) '(5))
(check-equal? (board-ref partial-fill 8 0) '(3 4 6))

;; board-update
(check-equal? (board-update (board-update blank-board 0 1 '(5)) 8 0 '(3 4 6))
              partial-fill)

;; extract-row
(check-equal? (extract-row partial-fill 1)
              (extract-row blank-board 1))
(check-equal? (extract-row partial-fill 0)
              (list bc '(5) bc bc bc bc bc bc bc))

;; extract-col
(check-equal? (extract-column partial-fill 2)
              (extract-column blank-board 2))
(check-equal? (extract-column partial-fill 1)
              (list '(5) bc bc bc bc bc bc bc bc))

;; extract-block
(check-equal? (extract-block partial-fill 2 2)
              (extract-block blank-board 2 2))
(check-equal? (extract-block partial-fill 2 0)
              (list bc bc bc bc bc bc '(3 4 6) bc bc))

;; count-instances
(check-equal? (count-instances 6 '()) 0)
(check-equal? (count-instances 3 '(2 3 5 34 3)) 2)

;; row-valid?
(check-equal? (row-valid? row-fail-board) #f)
(check-equal? (row-valid? col-fail-board) #t)
(check-equal? (row-valid? diag-fail-board) #t)

;; column-valid?
(check-equal? (column-valid? row-fail-board) #t)
(check-equal? (column-valid? col-fail-board) #f)
(check-equal? (column-valid? diag-fail-board) #t)

;; block-valid?
(check-equal? (block-valid? row-fail-board) #t)
(check-equal? (block-valid? col-fail-board) #t)
(check-equal? (block-valid? diag-fail-board) #f)

;; contradict?
(check-equal? (contradict? row-fail-board) #t)
(check-equal? (contradict? col-fail-board) #t)
(check-equal? (contradict? diag-fail-board) #t)
(check-equal? (contradict? blank-board) #f)
(check-equal? (contradict? partial-fill) #f)

;; first-unknown
(check-equal? (first-unknown blank-board)
              (cons 0 0))
(check-equal? (first-unknown (board-update blank-board 0 0 '(3)))
              (cons 0 1))
(check-equal? (first-unknown (board-update blank-board 0 0 '(2 3)))
              (cons 0 0))
(check-equal? (first-unknown filled-board) #f)

;; filled?
(check-equal? (filled? filled-board) #t)
(check-equal? (filled? solved-board) #t)
(check-equal? (filled? blank-board) #f)

;; solved?
(check-equal? (solved? filled-board) #f)
(check-equal? (solved? solved-board) #t)
(check-equal? (solved? blank-board) #f)

;; solve
(check-equal? (solve row-fail-board) #f)
(check-equal? (solve col-fail-board) #f)
(check-equal? (solve diag-fail-board) #f)
(check-equal? (solve solved-board) solved-board)
(check-equal? (solve almost-solved-board) solved-board)