Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 151 lines (137 sloc) 7.007 kb
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 39 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 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
#lang scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sudoku puzzles are a simple and popular amusement given as a
;;; nine-by-nine grid of cells, some of them containing digits:
;;;
;;; ┌──────────┬──────────┬──────────┐
;;; │┌──┬──┬──┐│┌──┬──┬──┐│┌──┬──┬──┐│
;;; ││7 │ │ │││1 │ │ │││ │ │ ││
;;; │├──┼──┼──┤│├──┼──┼──┤│├──┼──┼──┤│
;;; ││ │2 │ │││ │ │ │││ │1 │5 ││
;;; │├──┼──┼──┤│├──┼──┼──┤│├──┼──┼──┤│
;;; ││ │ │ │││ │ │6 │││3 │9 │ ││
;;; │└──┴──┴──┘│└──┴──┴──┘│└──┴──┴──┘│
;;; ├──────────┼──────────┼──────────┤
;;; │┌──┬──┬──┐│┌──┬──┬──┐│┌──┬──┬──┐│
;;; ││2 │ │ │││ │1 │8 │││ │ │ ││
;;; │├──┼──┼──┤│├──┼──┼──┤│├──┼──┼──┤│
;;; ││ │4 │ │││ │9 │ │││ │7 │ ││
;;; │├──┼──┼──┤│├──┼──┼──┤│├──┼──┼──┤│
;;; ││ │ │ │││7 │5 │ │││ │ │3 ││
;;; │└──┴──┴──┘│└──┴──┴──┘│└──┴──┴──┘│
;;; ├──────────┼──────────┼──────────┤
;;; │┌──┬──┬──┐│┌──┬──┬──┐│┌──┬──┬──┐│
;;; ││ │7 │8 │││5 │ │ │││ │ │ ││
;;; │├──┼──┼──┤│├──┼──┼──┤│├──┼──┼──┤│
;;; ││5 │6 │ │││ │ │ │││ │4 │ ││
;;; │├──┼──┼──┤│├──┼──┼──┤│├──┼──┼──┤│
;;; ││ │ │ │││ │ │1 │││ │ │2 ││
;;; │└──┴──┴──┘│└──┴──┴──┘│└──┴──┴──┘│
;;; └──────────┴──────────┴──────────┘
;;;
;;; The challenge is to fill the empty cells with the digits 1 through 9 in
;;; such a way that no row, column, or three-by-three sub-grid contains the
;;; same digit two or more times.
;;;
;;; Write a program to solve sudoku puzzles; your program may assume the
;;; puzzle is well-formed. What is the solution of the above puzzle?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require srfi/26)
(require scheme/control)

(require "dancing-links.ss")

;;; Solve the sample problem.
(define (main)
  (solve-work (make-constraints "7..1......2.....15.....639.2...18....4..9..7....75...3.785.....56.....4......1..2")
print-solution))

;;; And a sample "extreme" problem.
(define (main-extreme)
  (solve-work (make-constraints "1.......2.9.4...5...6...7...5.9.3.......7.......85..4.7.....6...3...9.8...2.....1")
print-solution))

(define (main-hardest)
  (solve-work (make-constraints "7......1946.19.......6827.4.9......7...3..4.5..67.......1......2...74......2..3..")
print-solution))

(define (main-wild)
  (solve-work (make-constraints "002090107038600000400000000000005000009010300000400000000000004000007920806030700")
print-solution))

;;; Build the constraints for an n^2 by n^2 sudoku puzzle.
(define (board-constraints nsqrt)
  (define n (sqr nsqrt))
  (define range-n (in-range 1 (add1 n)))
  (define range-nsqrt (in-range 1 (add1 nsqrt)))
  (define (make-row row col piece)
    (+ (* 100 row) (* 10 col) piece))
  (append
    ;; Each cell only to have a single number.
    (for*/list ([row range-n]
[col range-n])
      (let ([pieces (for/list ([piece range-n]) (make-row row col piece))])
(make-column (format "u~a~a" row col) pieces)))

    ;; Each number only once per row.
    (for*/list ([row range-n]
[piece range-n])
      (let ([row-vals (for/list ([col range-n]) (make-row row col piece))])
(make-column (format "r~a-p~a" row piece) row-vals)))

    ;; Each number only once per column.
    (for*/list ([col range-n]
[piece range-n])
      (let ([col-vals (for/list ([row range-n]) (make-row row col piece))])
(make-column (format "c~a-p~a" col piece) col-vals)))

    ;; Each number only once per group.
    (for*/list ([gy (in-range nsqrt)]
[gx (in-range nsqrt)]
[piece range-n])
      (let ([group-vals (for*/list ([dy (in-range nsqrt)]
[dx (in-range nsqrt)])
(make-row (+ (* nsqrt gy) dy 1)
(+ (* nsqrt gx) dx 1)
piece))])
(make-column (format "g~a~a-p~a" (add1 gx) (add1 gy) piece) group-vals)))))

;;; Convert an initial board into a set of given constraints.
(define (given-constraints initial)
  (define n (sqrt (string-length initial)))
  (assert = (sqr n) (string-length initial))
  (for*/list ([row (in-range n)]
[col (in-range n)]
[offset (in-value (+ (* n row) col))]
[ch (in-value (string-ref initial offset))]
#:when (char<=? #\1 ch #\9))
    (let ([piece (- (char->integer ch) (char->integer #\0))])
      (make-column (format "i~a~a-p~a" (add1 col) (add1 row) piece)
(list (+ (* 100 (add1 row))
(* 10 (add1 col))
piece))))))

;;; Given a list of rows of a solution, print out the board. Assumes
;;; that the row numbers will sort properly, and that the solution is
;;; complete.
(define (print-solution answer)
  (define alength (length answer))
  (define sorted-answer (sort answer <))
  (define n (sqrt alength))
  (define nsub (sqrt n))
  (define vlimit (* n nsub))
  (define hsep (make-string (* 2 nsub) #\-))
  (define hline (string-join (make-list nsub hsep) "-+"))
  (assert = (sqr n) (length answer))
  (assert = (sqr nsub) n)
  (for ([cell (in-list sorted-answer)]
[col (in-cycle (in-range 1 (add1 n)))]
[hbox (in-cycle (in-range 1 (add1 nsub)))]
[vbox (in-cycle (in-range 1 (add1 vlimit)))]
[fullc (in-range 1 (add1 alength))])
    (printf " ~a" (remainder cell 10))
    (when (and (= hbox nsub) (< col n))
      (display " |"))
    (when (= col n)
      (newline))
    (when (and (= vbox vlimit) (< fullc alength))
      (display hline)
      (newline))))

;;; Construct constraints for a given problem.
(define (make-constraints initial)
  (define root (create-node))
  (define n (sqrt (sqrt (string-length initial))))
  (assert = (sqr (sqr n)) (string-length initial))
  (for-each (cut insert-column root <>) (board-constraints n))
  (for-each (cut insert-column root <>) (given-constraints initial))
  (sever-row-helper! root)
  root)
Something went wrong with that request. Please try again.