Nondeterministic sudoku solver

sudoku.rkt

#lang racket

(module amb racket/base
  (provide amb assert!)
  (define-syntax-rule (pop! stack)
    (begin0 (car stack) (set! stack (cdr stack))))
  (define-syntax-rule (push! v stack)
    (set! stack (cons v stack)))
  (define (U f) (f f))

  (define fail-stack '())
  (define (fail!)
    (if (null? fail-stack)
        (error 'amb "Back-tracking stack exhausted!")
        (U (pop! fail-stack))))
  (define (amb choices)
    (let ((cc (call-with-current-continuation values)))
      (cond ((null? choices) (fail!))
            (else (push! cc fail-stack)
                  (pop! choices)))))
  (define (assert! condition)
    (unless condition (fail!))))

(require 'amb)


(define (split-into lst n)
  (define-values (head tail) (split-at lst n))
  (if (null? tail)
      (list head)
      (cons head (split-into tail n))))

(define (split-up lst)
  (split-into lst (sqrt (length lst))))

(define (get-rows matrix)
  matrix)

(define (get-columns matrix)
  (apply map list matrix))

(define (get-grids matrix)
  (apply append (map (curry apply map append) (split-up (map split-up matrix)))))

(define (get-digit-set lst)
  (apply set (range 1 (add1 (length lst)))))

(define (valid? lst)
  (set=? (apply set lst) (get-digit-set lst)))

(define (matrix-valid? matrix)
  (let ((rows (get-rows matrix))
        (columns (get-columns matrix))
        (grids (get-grids matrix)))
    (and
     (= (length rows)
        (length columns)
        (length grids))
     (andmap valid? rows)
     (andmap valid? columns)
     (andmap valid? grids))))

(module+ main
  ;; Replace `x' with `amb' for aesthetics.
  (define-syntax x
    (syntax-id-rules ()
      (x (amb (range 1 10)))))
  ;;; Warning: This implementation is very inefficient and unoptimised.
  ;;; This is the price to pay for succint and high-level code.
  (time
   (let ((puzzle
          (list
           (list 5 x x 4 6 7 3 x 9)
           (list 9 x 3 8 1 x 4 2 7)
           (list 1 7 4 2 x 3 x x x)
           (list 2 3 1 9 6 7 8 5 4)
           (list 8 5 7 1 2 4 x 9 x)
           (list 4 6 9 3 x 8 1 7 2)
           (list x x x x 8 9 2 6 x)
           (list 7 8 2 6 4 1 x x 5)
           (list x 1 x x x x 7 x 8))))
     (assert! (matrix-valid? puzzle))
     (pretty-print puzzle))))