(module sudoku mzscheme
  
  (require (planet "inference.ss" ("williams" "inference.plt")))
  (require (lib "list.ss" "srfi" "1"))
  (provide (all-defined))
  
  (define-ruleset sudoku-rules)
  
  ;; If there is a board and no cells, initialize the system.
  (define-rule (initialize sudoku-rules)
      (board ?board)
      (no (cell . ?))
    ==>
      (printf "initialize:~n")
      (print-board ?board)
      (do ((row 0 (+ row 1)))
          ((= row 9) (void))
        (assert `(digit ,row))
        (do ((column 0 (+ column 1)))
            ((= column 9) (void))
          (let ((value (vector-ref (vector-ref ?board row) column))
                (box (+ (* (quotient row 3) 3)
                        (quotient column 3))))
            (if (eqv? value '_)
                (assert `(cell ,row ,column ,box (1 2 3 4 5 6 7 8 9)))
                (assert `(cell ,row ,column ,box ,value)))))))

  ;; If all of the cells are numbered, we've succeeded.
  (define-rule (rule-1 sudoku-rules)
      (all (cell ?row ?column ?box (?value (number? ?value))))
      (board ?board)
    ==>
      (stop-inference ?board))
  
  ;; If a cell has no possible values. we've failed.
  (define-rule (rule-2 sudoku-rules)
      (cell ?row ?column ?box (?value (eq? ?value '())))
    ==>
      (fail))
  
  ;; If we have a single possible value in a cell,
  ;;   use it to number the cell.
  (define-rule (rule-3 sudoku-rules)
      (?cell <- (cell ?row ?column ?box
                      (?value (and (list? ?value) (= (length ?value) 1)))))
      (board ?board)
    ==>
      (vector-set! (vector-ref ?board ?row) ?column (car ?value))
      (replace ?cell `(cell ,?row ,?column ,?box ,(car ?value))))
  
  ;; If a cell is numbered and it conflicts with another numbered cell,
  ;;   fail.
  (define-rule (rule-4a sudoku-rules)
      (cell ?row ?column ?box (?value (number? ?value)))
      (cell ?row (?column-1 (not (= ?column-1 ?column))) ?box-1
            (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
    ==>
      (fail))
  
  (define-rule (rule-4b sudoku-rules)
      (cell ?row ?column ?box (?value (number? ?value)))
      (cell (?row-1 (not (= ?row-1 ?row))) ?column ?box-1
              (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
    ==>
      (fail))
  
  (define-rule (rule-4c sudoku-rules)
      (cell ?row ?column ?box  (?value (number? ?value)))
      (cell ?row-1 ?column-1 (?box (or (not (= ?row-1 ?row))
                                       (not (= ?column-1 ?column))))
              (?value-1 (and (number? ?value-1) (= ?value-1 ?value))))
    ==>
      (fail))
  
  ;; If a cell is numbered, remove that number from other cell in the
  ;; same row, column, or box.
  (define-rule (rule-5a sudoku-rules)
      (cell ?row ?column ?box
            (?value (number? ?value)))
      (?cell-1 <- (cell ?row
                        (?column-1 (not (= ?column-1 ?column)))
                        ?box-1
                        (?value-1 (and (list? ?value-1)
                                       (memv ?value ?value-1)))))
    ==>
      (replace ?cell-1 `(cell ,?row ,?column-1 ,?box-1
                             ,(delete ?value ?value-1))))  
  
  (define-rule (rule-5b sudoku-rules)
      (cell ?row ?column ?box
            (?value (number? ?value)))
      (?cell-1 <- (cell (?row-1 (not (= ?row-1 ?row)))
                        ?column
                        ?box-1
                       (?value-1 (and (list? ?value-1)
                                      (memv ?value ?value-1)))))
    ==>
      (replace ?cell-1 `(cell ,?row-1 ,?column ,?box-1
                             ,(delete ?value ?value-1))))
  
  (define-rule (rule-5c sudoku-rules)
      (cell ?row ?column ?box
            (?value (number? ?value)))
      (?cell-1 <- (cell ?row-1
                        ?column-1
                        (?box (or (not (= ?row-1 ?row))
                                  (not (= ?column-1 ?column))))
                       (?value-1 (and (list? ?value-1)
                                      (memv ?value ?value-1)))))
    ==>
      (replace ?cell-1 `(cell ,?row-1 ,?column-1 ,?box
                             ,(delete ?value ?value-1))))
  
  ;; If there is a value that only occurs once as a possibility  in any
  ;; row, column, or box, then make it the only possible value.
  (define-rule (rule-6a sudoku-rules)
      (digit ?digit)
      (?cell <- (cell ?row ?column ?box (?value (and (list? ?value)
                                                     (memv ?digit ?value)))))
      (no (cell ?row (?column-1 (not (= ?column-1 ?column))) ?
                (?value-1 (or (and (number? ?value-1)
                                   (= ?value-1 ?digit))
                              (and (list? ?value-1)
                                   (memv ?digit ?value-1))))))
    ==>
      (replace ?cell `(cell ,?row ,?column ,?box ,(list ?digit))))
  
  (define-rule (rule-6b sudoku-rules)
      (digit ?digit)
      (?cell <- (cell ?row ?column ?box (?value (and (list? ?value)
                                                     (memv ?digit ?value)))))
      (no (cell (?row-1 (not (= ?row-1 ?row))) ?column ?
                (?value-1 (or (and (number? ?value-1)
                                               (= ?value-1 ?digit))
                                          (and (list? ?value-1)
                                               (memv ?digit ?value-1))))))
    ==>
      (replace ?cell `(cell ,?row ,?column ,?box ,(list ?digit))))
  
  (define-rule (rule-6c sudoku-rules)
      (digit ?digit)
      (?cell <- (cell ?row ?column ?box (?value (and (list? ?value)
                                           (memv ?digit ?value)))))
      (no (cell ?row-1 ?column-1 (?box (or (not (= ?row-1 ?row))
                                           (not (= ?column-1 ?column))))
                (?value-1 (or (and (number? ?value-1)
                                            (= ?value-1 ?digit))
                                       (and (list? ?value-1)
                                            (memv ?digit ?value-1))))))
    ==>
      (replace ?cell `(cell ,?row ,?column ,?box ,(list ?digit))))
  
  ;; If the above rules don't find a solution (or fail), then create a
  ;; child inference to search using the shorted list of possibilities.
  (define-rule (search sudoku-rules #:priority -100)
      (board ?board)
      (cell ?row ?column ?box (?value (and (list? ?value)
                                           (> (length ?value) 1))))
      (no (cell ? ? ? (?value-1 (and (list? ?value-1)
                                     (< (length ?value-1)
                                        (length ?value))))))
    ==>
    (printf "search: row = ~a, column = ~a, box = ~a, values = ~a~n"
            ?row ?column ?box ?value)
    (for-each
     (lambda (value)
       (let ((new-board (copy-board ?board)))
         (vector-set! (vector-ref new-board ?row) ?column value)
         (let ((result
                (with-new-child-inference-environment
                 (activate sudoku-rules)
                 (assert `(board ,new-board))
                 (let ((result (start-inference)))
                   (printf "Rules fired = ~a~n" (current-inference-rules-fired))
                   result))))
           (when (vector? result)
             (stop-inference result)))))
     ?value)
    (fail))
  
  (define (copy-board board)
    (let ((new-board (make-vector 9)))
      (do ((row 0 (+ row 1)))
          ((= row 9) new-board)
        (let ((board-row (vector-ref board row))
              (new-row (make-vector 9)))
          (do ((column 0 (+ column 1)))
              ((= column 9) (void))
            (vector-set! new-row column
                         (vector-ref board-row column)))
          (vector-set! new-board row new-row)))))
   
  (define (print-board board)
    (do ((row 0 (+ row 1)))
        ((= row 9) (void))
      (do ((column 0 (+ column 1)))
          ((= column 9) (void))
        (let ((value (vector-ref (vector-ref board row) column)))
          (printf "~a " value)))
      (printf "~n")))
  
  (define (sudoku-solver board)
    (printf "Initial Board~n")
    (print-board board)
    (with-new-inference-environment
     (activate sudoku-rules)
     ;(current-inference-strategy 'breadth)
     ;(current-inference-trace #t)
     (assert `(board ,board))
     (let ((result (start-inference)))
       (cond ((eq? result #:fail)
              (printf "Problem cannot be solved!~n"))
             ((not result)
              (printf "No solution found!~n")
              (let* ((board (cdr (assq '?board (cdar (query '(board ?board)))))))
                (print-board board)))
             (else
              (printf "Solution found!~n")
              (print-board result))))
     (printf "Rules fired = ~a~n" (current-inference-rules-fired))
     ))
  
;  (sudoku-solver '((1 2 3 4 5 6 7 8 9)
;                   (4 5 6 7 8 9 1 2 3)
;                   (7 8 9 1 2 3 4 5 6)
;                   (2 3 4 5 6 7 8 9 1)
;                   (5 6 7 8 9 1 2 3 4)
;                   (8 9 1 2 3 4 5 6 7)
;                   (3 4 5 6 7 8 9 1 2)
;                   (6 7 8 9 1 2 3 4 5)
;                   (9 1 2 3 4 5 6 7 8)))
  
;  (sudoku-solver '((_ 2 3 4 5 6 7 8 9)
;                   (4 5 6 7 8 9 1 2 3)
;                   (7 8 9 1 2 3 4 5 6)
;                   (2 3 4 5 6 7 8 9 1)
;                   (5 6 7 8 9 1 2 3 4)
;                   (8 9 1 2 3 4 5 6 7)
;                   (3 4 5 6 7 8 9 1 2)
;                   (6 7 8 9 1 2 3 4 5)
;                   (9 1 2 3 4 5 6 7 8)))
  
;  (sudoku-solver '#(#(7 8 1 6 _ 2 9 _ 5)
;                    #(9 _ 2 7 1 _ _ _ _)
;                    #(_ _ 6 8 _ _ _ 1 2)
;                    #(2 _ _ 3 _ _ 8 5 1)
;                    #(_ 7 3 5 _ _ _ _ 4)
;                    #(_ _ 8 _ _ 9 3 6 _)
;                    #(1 9 _ _ _ 7 _ 8 _)
;                    #(8 6 7 _ _ 3 4 _ 9)
;                    #(_ _ 5 _ _ _ 1 _ _)))
  
;  (sudoku-solver '#(#(_ 8 _ _ _ _ _ _ _)
;                    #(_ 4 7 8 _ 9 _ _ 1)
;                    #(_ _ 1 4 5 _ _ 2 _)
;                    #(8 1 6 7 _ _ 5 _ _)
;                    #(9 _ _ _ _ 1 _ _ _)
;                    #(_ _ _ 5 6 _ _ _ _)
;                    #(_ _ _ _ _ 8 _ 5 3)
;                    #(_ _ _ _ _ _ _ 8 _)
;                    #(_ _ _ 3 1 _ _ 4 6)))
  
  (sudoku-solver '#(#(_ 1 9 _ _ _ _ _ _)
                    #(_ _ 8 _ _ 3 _ 5 _)
                    #(_ 7 _ 6 _ _ _ 8 _)
                    #(_ _ 1 _ _ 6 8 _ 9)
                    #(8 _ _ _ 4 _ _ _ 7)
                    #(9 4 _ _ _ _ _ 1 _)
                    #(_ _ _ _ _ 2 _ _ _)
                    #(_ _ _ _ 8 _ 5 6 1)
                    #(_ _ 3 7 _ _ _ 9 _)))
  
  )