sudoku-solver/solver.scm

(define-module (sudoku solver))

(use-modules (srfi srfi-1)
             (ice-9 receive)
             (ice-9 control)
             (sudoku utils)
             (sudoku square)
             (sudoku board))

(define-public (solver board)
  (call/ec
    (lambda (return)
      (solver-loop board return))))

;; TODO; break up
(define (solver-loop board return)
  (receive (min-square i j)
           (find-min-square board)
    (define (find-solution-from-candidates candidates)
      (if (null? candidates)
        #f
        (begin
          (solver-loop
            (let ((n-board (make-array 0 9 9)))
              (array-copy! board n-board)
            (update-board-candidates
              (set-square n-board (set-value min-square (car candidates)) i j)))
            return)
          (find-solution-from-candidates (cdr candidates)))))
    (cond
      ((null? min-square) (return board))
      ((zero? (length (get-candidates min-square))) board)
      (else (find-solution-from-candidates (get-candidates min-square))))))

(define (find-min-square board)
  (let ((min-square-l
          (array-fold
            (lambda (item acc)
              (if (and (= 0 (get-value (car item)))
                       (< (length (get-candidates (car item)))
                          (length (get-candidates (car acc)))))
                item
                acc))
            (list (make-square) -1 -1)
            board)))
    (if (array-in-bounds? board (cadr min-square-l) (last min-square-l))
      (values (car min-square-l) (cadr min-square-l) (last min-square-l))
      (values '() -1 -1))))

(define (update-board-candidates board)
  (fold (lambda (i n-board)
          (update-row (update-col (update-box n-board i) i) i))
        board
        (iota 9)))

(define-public (update-row board i)
  (update-group set-row get-row board i))

(define-public (update-col board j)
  (update-group set-col get-col board j))

(define-public (update-box board k)
  (update-group set-box get-box board k))

(define (update-group set-proc get-proc board i)
  (set-proc board
           (update-list
             (get-proc board i))
           i))

(define (update-list l)
  (let ((vals (get-vals l)))
    (map (lambda (square)
           (update-candidates square vals))
         l)))

(define (get-vals squares)
  (fold (lambda (square vals)
          (if (> (get-value square) 0)
              (cons (get-value square) vals)
              vals))
        '()
        squares))

(define (update-candidates square vals)
  (set-candidates square
                  (lset-difference eq?
                                   (get-candidates square)
                                   vals)))