gistfile1.sls

(use srfi-1)    ; iota
(use srfi-43)   ; vector-for-each

(define fail #f)

;;; write following at the end of file
;;; to initialize the value of the fail.
(call/cc
 (lambda (cc)
   (set! fail
         (lambda ()
           (cc 'no-choise)))))

;;; nondeterminsm macro operator
(define-syntax amb
  (syntax-rules ()
    ((_) (fail))
    ((_ a) a)
    ((_ a b ...)
     (let ((fail0 fail))
       (call/cc
        (lambda (cc)
          (set! fail
                (lambda ()
                  (set! fail fail0)
                  (cc (amb b ...))))
          (cc a)))))))

;;; if not pred backtrack
(define (assert pred)
  (or pred (amb)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define panel #(
        5 3 0  0 7 0  0 0 0
        6 0 0  1 9 5  0 0 0
        0 9 8  0 0 0  0 6 0

        8 0 0  0 6 0  0 0 3
        4 0 0  8 0 3  0 0 1
        7 0 0  0 2 0  0 0 6

        0 6 0  0 0 0  2 8 0
        0 0 0  4 1 9  0 0 5
        0 0 0  0 8 0  0 7 9))
;
;(define panel #(
;        0 0 5  3 0 0  0 0 0
;        8 0 0  0 0 0  0 2 0
;        0 7 0  0 1 0  5 0 0
;
;        4 0 0  0 0 5  3 0 0
;        0 1 0  0 7 0  0 0 6
;        0 0 3  2 0 0  0 8 0
;
;        0 6 0  5 0 0  0 0 9
;        0 0 4  0 0 0  0 3 0
;        0 0 0  0 0 9  7 0 0))



;; 整形して表示
(define display-panel (lambda (p)
    (format #t "+-------+-------+-------+~%")
    (vector-for-each (lambda (idx v)
        (if (= 0 (modulo idx 3)) (format #t "| "))
        (format #t "~A " v)
        (if (= 8 (modulo idx 9)) (format #t "|~%"))
        (if (= 26 (modulo idx 27)) (format #t "+-------+-------+-------+~%"))
    ) p)))

(define (get-hline-indices idx)
    (iota 9 (* 9 (quotient idx 9)) 1))
;   (map (lambda (i) (+ (* 9 (quotient idx 9)) i)) '(0 1 2 3 4 5 6 7 8)))

(define (get-vline-indices idx)
    (iota 9 (modulo idx 9) 9))
;   (map (lambda (i) (+ (* 9 i) (modulo idx 9))) '(0 1 2 3 4 5 6 7 8)))

(define (get-box-indices idx)
    (map (lambda (v) (+ v (+
      (* 3 (modulo (quotient idx 3) 3))   ; x
      (* 27 (quotient idx 27)) ; y
    ))) '(0 1 2 9 10 11 18 19 20)))

(define (list-have-duplicates? lst)
  (and (not (null? lst))
    (or
      (and (> (car lst) 0) (any (lambda (v) (and (> v 0) (= v (car lst)))) (cdr lst)))
      (list-have-duplicates? (cdr lst)))))

(define (valid-sudoku-rule? p)
  (not (list-have-duplicates? p)))


(vector-for-each (lambda (idx v)
    (if (= 0 v)
      (let ((p (vector-copy panel))) ; save the current panel
        (let ((newv (amb 1 2 3 4 5 6 7 8 9)))
            (set! panel p) ; restore the panel for backtrack
            (vector-set! panel idx newv)
            (assert (valid-sudoku-rule? (map (lambda (i) (vector-ref panel i)) (get-hline-indices idx))))
            (assert (valid-sudoku-rule? (map (lambda (i) (vector-ref panel i)) (get-vline-indices idx))))
            (assert (valid-sudoku-rule? (map (lambda (i) (vector-ref panel i)) (get-box-indices   idx))))
          ))
    )) panel)

(display-panel panel)