Sudoku Solver1

;;; -*- Scheme -*-
;;; sudoku.scm
;;; 2006-feb-26
;;;
;;; Every cell in a 9x9 sudoku puzzle is a member of 3 intersecting sets.
;;; - a 3x3 box, a 9-cell row, and a 9-cell column. For a pending change
;;; in any cell, the rule must be applied to each of these 3 sets. Ergo,
;;; must of the effort is in applying the constraints.
;;;
;;; The overall program can be simplified if the data is organized to
;;; take advantage of standard Scheme idioms. This program represents the
;;; entire puzzle as a single 81-cell vector. A series of lists contains
;;; indices into the vector for each set. Consequently, the same Schemely
;;; routines can be used for each set no matter the positions of it's
;;; cells in the puzzle.
;;;
;;; Sudokus probably appear in your daily paper. These are a good way to
;;; pass time on a boring train ride but not a good use of human brain
;;; power. However, they are an interesting programming project.
;;;
;;; The challenge is to find a representation which results in the
;;; simplest possible solution. Efficiency has a lower priority.
;;;
;;;
;; --------------------------------------------------------------------
;; define PUZZLE=9x9 grid of data cells, sequential storage,
;; The program will solve the one named *grid*
;;
(define *grid* (vector			;diabolical
		0 3 0 0 1 7 0 0 0
		0 0 0 0 0 0 8 6 5
		2 0 0 0 0 0 0 0 0
		5 7 4 0 0 0 0 0 0
		1 2 0 0 0 0 0 3 0
		0 0 0 5 6 0 1 0 0
		3 9 0 0 0 0 0 2 8
		0 0 2 0 0 0 0 0 0
		0 0 0 4 0 0 9 1 0))	;78101 mutations, 5613 backtracks

(define *another-grid1* (vector 
		5 0 6 0 0 0 8 0 0
		0 0 0 0 0 9 4 1 0
		0 2 0 0 0 0 0 5 6
		0 8 0 0 1 6 0 0 5
		7 0 0 0 0 0 0 0 4
		6 0 0 8 5 0 0 3 0
		2 3 0 0 0 0 0 4 0
		0 4 5 9 0 0 0 0 0
		0 0 8 0 0 0 1 0 7))	;39873 mutations

(define BlankPuzzle  (vector 
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0
		0 0 0 0 0 0 0 0 0))

(define *another-grid2* (vector 
		0 2 0 3 0 0 9 0 0
		0 8 3 0 2 5 6 0 1
		0 7 0 0 0 0 0 0 0
		0 4 0 9 0 0 0 0 0
		8 0 0 5 0 1 0 0 9
		0 0 0 0 0 8 0 2 0
		0 0 0 0 0 0 0 1 0
		1 0 8 2 6 0 7 4 0
		0 0 7 0 0 3 0 9 0))	;47755 mutations


;; This one fails on cell 0. It might work if the puzzle was sequenced
;; in reverse
(define *invalid-perhaps* (vector 
		0 0 0 1 5 0 0 7 0
		1 0 6 0 0 0 8 2 0
		3 0 0 8 6 0 0 4 0
		9 0 0 4 0 0 5 6 7
		0 0 4 7 0 8 3 0 0
		7 3 2 0 1 6 0 0 4
		0 4 0 0 8 1 0 0 9
		0 1 7 0 0 0 2 0 8
		0 5 0 0 3 7 0 0 0))	;1299 mutations, 103 backtracks


(define *grid4* (vector 		;challenging
		0 0 0 2 0 0 0 0 0
		0 9 0 0 1 5 6 0 0
		7 6 0 0 0 0 3 0 0
		0 0 3 0 8 0 9 1 0
		0 0 5 4 0 0 0 0 0
		6 0 0 0 0 7 4 3 0
		9 5 0 0 0 6 0 0 0
		0 0 0 0 0 0 0 4 0
		0 3 0 0 0 0 0 0 2))	;29967 mutations, 2048 backtracks

;; here are the indices to cells stored in the vector
;; 00,01,02, 03,04,05, 06,07,08
;; 09,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
;;
;; define reference lists for each 3x3 box that comprise the grid so
;; run time does not require index calculation. Instead, common Scheme
;; idioms can be used.
;;
;; list the indices for the nine 3x3 boxes
(define b0list (list  0  1  2  9 10 11 18 19 20))  
(define b1list (list  3  4  5 12 13 14 21 22 23))  
(define b2list (list  6  7  8 15 16 17 24 25 26))  

(define b3list (list 27 28 29 36 37 38 45 46 47))
(define b4list (list 30 31 32 39 40 41 48 49 50)) 
(define b5list (list 33 34 35 42 43 44 51 52 53))

(define b6list (list 54 55 56 63 64 65 72 73 74)) 
(define b7list (list 57 58 59 66 67 68 75 76 77))
(define b8list (list 60 61 62 69 70 71 78 79 80))

;; list the indices for columns.
(define c0list (list 00 09 18 27 36 45 54 63 72))
(define c1list (list 01 10 19 28 37 46 55 64 73))
(define c2list (list 02 11 20 29 38 47 56 65 74))
(define c3list (list 03 12 21 30 39 48 57 66 75))
(define c4list (list 04 13 22 31 40 49 58 67 76))
(define c5list (list 05 14 23 32 41 50 59 68 77))
(define c6list (list 06 15 24 33 42 51 60 69 78))
(define c7list (list 07 16 25 34 43 52 61 70 79))
(define c8list (list 08 17 26 35 44 53 62 71 80))

;; list the indices for rows. Boring but fits the strategy
(define r0list (list 00 01 02 03 04 05 06 07 08))
(define r1list (list 09 10 11 12 13 14 15 16 17))
(define r2list (list 18 19 20 21 22 23 24 25 26))
(define r3list (list 27 28 29 30 31 32 33 34 35))
(define r4list (list 36 37 38 39 40 41 42 43 44))
(define r5list (list 45 46 47 48 49 50 51 52 53))
(define r6list (list 54 55 56 57 58 59 60 61 62))
(define r7list (list 63 64 65 66 67 68 69 70 71))
(define r8list (list 72 73 74 75 76 77 78 79 80))

;;list of row lists useful for displaying the puzzle
(define row-list (list r0list r1list r2list r3list r4list
		      r5list r6list r7list r8list))

;;list of column lists useful for checking constraints
(define col-list (list c0list c1list c2list c3list c4list
		      c5list c6list c7list c8list))

;;list of box lists useful for checking constraints
(define box-list (list b0list b1list b2list b3list b4list
		      b5list b6list b7list b8list))

;; --------------------------------------------------------------------
;; any row, column, or block has an expected constant sum. A match
;; means the set of cells comply with the rule
(define K1 (+ 1 2 3 4 5 6 7 8 9))	;45

;; --------------------------------------------------------------------
;;
(define *verbose* #f) ; printing option
(define *mutations* 0) ; count cell changes while running
(define *retreats* 0) ; count backtracks while running

(define box-size 3) ;size of 3x3 box in a 9*9 sudoku grid
(define grid-size 9) ;row/col size of 9*9 sudoku grid
(define cell-limit 80) ;last cell in the vector for the grid
(define *vi* 0) ; vector index

;; --------------------------------------------------------------------
;; get cell value from puzzle[indexed]
;;
(define (get-cell-index puzzle ci )
      (vector-ref puzzle ci))

;; --------------------------------------------------------------------
;; put cell value to puzzle[indexed]
(define (put-cell-index puzzle cell-num N)
  (vector-set! puzzle cell-num N))

;; --------------------------------------------------------------------
;; wait for <enter>; exit the program if 'e' was pressed
(define (prompt)
    (display ">>")
    (if ( char=? (read-char) #\e)
	(exit)				;#t
        (newline)))			;#f


;; --------------------------------------------------------------------
;; conditionally display 2 items and a linefeed, preceded by puzzle index 
(define (show2-line item1 item2)
  (when *verbose*
	(display "Cell: ")
	(display *vi*)
	(display ": ")
	(display item1) 
	(display " ")
	(display item2)
	(newline)))

;; --------------------------------------------------------------------
;; display 2 items and a linefeed. Example, a name-value pair
(define (show-pair item1 item2)
  (display item1) 
  (display " ")
  (display item2)
  (newline))

;; --------------------------------------------------------------------
;; return the sum of the values of cells in a row, column or box.
;; if the sum equals K1, the item is complete
;; this will help validate the entire puzzle
(define (sum-cells indices)
  (let ( [sum 0])
    (for-each (lambda (i)
		(set! sum (+ sum (vector-ref *grid* i))))
	      indices)
    sum))

;; --------------------------------------------------------------------
;; print the cells of a box, row, or column using a list of indices
(define (display-items puzzle indices)
  (for-each (lambda (i)
	      (display (vector-ref puzzle i))
	      (display " "))
	    indices)
  (newline))


;; --------------------------------------------------------------------
;; display a puzzle grid using lists of vector indices
(define (print-grid puzzle rlist)
  (for-each (lambda (i)
	      (display-items puzzle i)) 
	    rlist))  

;; --------------------------------------------------------------------
;; print the puzzle state and exit
(define (exit-print-grid reason)

  (define (print-sums ilist)		;local routine
    (for-each (lambda (i)
		(if (not ( = K1 (sum-cells i)))
		    (show2-line "sum not 45 in " i)))
	      ilist))

  (display reason)
  (display "validating..\n")
  ;;(vector-set! *grid* 1 0)
  (print-grid *grid* row-list)
  (print-sums row-list)
  (print-sums col-list)
  (print-sums box-list)
  (show-pair  "mutations" *mutations*)
  (show-pair  "backtracks" *retreats*)
  (display "goodbye\n");
  (exit))

;; --------------------------------------------------------------------
;; increment the global puzzle vector index.
;; quit if the next-cell is out of bounds. This is always printed even
;; if the solution is successful
(define (next-cell)
  (if (< *vi* cell-limit)
	(set! *vi* (+ *vi* 1))
	(exit-print-grid 
	 "cell high limit exceeded or puzzle complete...\n")))

;; --------------------------------------------------------------------
;; decrement the global puzzle vector index.
;; return true if the previous cell is within bounds.
(define (previous-cell)
  (if (> *vi* 0)
	(set! *vi* (- *vi* 1))
	(exit-print-grid "cell low limit exceeded\n")))

;; --------------------------------------------------------------------
;; return true if a set (box|row|col) already contains the candidate
;; number in any of it's cells
;;
(define (set-has-number? indices n)
  (let ([flag #f])
    (for-each (lambda (i)
		(if (= n (vector-ref *grid* i)) 
		    (set! flag #t)))
	      indices)
    flag))
    
;; --------------------------------------------------------------------
;; return true if the number 'ci' is found in a list of integers
;; 
(define (list-has-number? nlist ci )
  (let ([flag #f])
    (for-each (lambda (i)
		(if (= ci i) 
		    (set! flag #t)))
	      nlist)
    flag))

;; --------------------------------------------------------------------
;; given a cell-index and a new cell value, determine a matching
;; box-list, then return true if any box cell already has the proposed
;; new value
(define (box-cell-has-number? vi cv)
  (if (set-has-number?
       (cond ((list-has-number? b0list vi) b0list)
	     ((list-has-number? b1list vi) b1list)
	     ((list-has-number? b2list vi) b2list)
	     ((list-has-number? b3list vi) b3list)
	     ((list-has-number? b4list vi) b4list)
	     ((list-has-number? b5list vi) b5list)
	     ((list-has-number? b6list vi) b6list)
	     ((list-has-number? b7list vi) b7list)
	     ((list-has-number? b8list vi) b8list)
	     (else (exit-print-grid))) cv)
      (begin
	(show2-line "box has" cv)
	#t)
      (begin
	(show2-line "box has not" cv)
	#f)))

;; --------------------------------------------------------------------
;; given cell index, return row list number
(define (cell-to-row ci)
  ;;(print ci)
  (if (>= ci grid-size)
      (inexact->exact (floor ( / ci grid-size )) )
      0))
  
;; --------------------------------------------------------------------
;; given cell index, return column number
(define (cell-to-column ci)
  (- ci (* (cell-to-row ci) grid-size)))

;; --------------------------------------------------------------------
;; for avoid duplicate entries
(define (column-has-number? vi cv)
  (if (set-has-number? (list-ref col-list (cell-to-column  vi))  cv)
      (begin
	(show2-line "column has" cv)
	#t)
      (begin
	(show2-line "column has not" cv)
	#f)))

;; --------------------------------------------------------------------
;; for avoid duplicate entries
;;
(define (row-has-number? vi cv)
  (if (set-has-number? (list-ref row-list (cell-to-row  vi))  cv)
      (begin
	(show2-line "row has" cv)
	#t)
      (begin
	(show2-line "row has not" cv)
	#f)))

;; --------------------------------------------------------------------
;;
(define counters (make-vector (+ cell-limit 1) 1))
(define (set-counters)
  ;;the counters vector shadows the puzzle vector such that every
  ;;non-zero cell in the original puzzle has a matching zero
  ;;in the counters vector. During search, the non-zero cells in the
  ;;counters vector will be incremented.
  (let ci-flag-loop ([ci 0])
    (if ( > (get-cell-index *grid* ci) 0)
	(put-cell-index counters ci 0)
	#f)
    (if (< ci cell-limit)
	(ci-flag-loop (+ ci 1)))))

(set-counters) ;;mask stating cells which cannot change

;; --------------------------------------------------------------------
(define (get-cell-mask ci)
    (get-cell-index counters ci))

;; --------------------------------------------------------------------
(define (set-cell-mask ci cv) 
  (vector-set! counters ci cv))

;; --------------------------------------------------------------------
;; return #t if a number cv inserted in the cell leaves a valid puzzle.
;; if not, leave the puzzle as it was
;;
(define (try-put-num ci cv)
  (let ( [x #f] [y #f])
    (if ( or
	  (> cv grid-size)
	  (< cv 1)
	  (row-has-number? ci cv)
	  (column-has-number? ci cv)
	  (box-cell-has-number? ci cv)
	  )
	(begin
	  (show2-line "cannot put value " cv )
	  #f)  ; return false if already in use or invalid cv
	(begin 
	  (show2-line "put value " cv)
	  (put-cell-index *grid* ci cv)
	  #t)) )
  )

;; --------------------------------------------------------------------
;; get the cell value counter;increment if possible;
;; return #t if new within bound, #f otherwise.
;; assumes the current cell is mutable
(define (update-cell-mask )
  (let ( [cv (get-cell-mask *vi*)] )
    (if (< cv grid-size )
	(begin 
	  (vector-set! counters *vi* (+ cv 1))
	  #t)
	(begin ;all tried, reset to 1, return failure
	  (vector-set! counters *vi* 1)
	  #f))))


;; --------------------------------------------------------------------
;; try to put a number in a cell, if that fails, try the next number.
;; assumes the current cell is mutable
(define (mutate-loop)
  (let ( [flag #f] [cv 0])
    (let mloop ()
      (set! cv (get-cell-mask *vi*))
      (set! *mutations* (+ *mutations* 1))
      (if (try-put-num *vi* cv)
	  (begin
	    (set! flag #t))			;success
	  (begin
	    (if (update-cell-mask)
		(mloop)))))
    
    flag))


;; --------------------------------------------------------------------
;;
(define (solve puzzle)
  (newline)
  (set-counters)
  (display "Sudoku Solver (2006-feb-26) ...\n")

  (let ([dir 1]				;1=forward else reverse
	[cv 1]				;cell value
	[ci 0])
    
    ;;( print-grid counters row-list) (prompt)
    ;;try to mutate all 81 cells while searching for solution.
    (let ci-loop ()
      
      (set! cv (get-cell-mask *vi*))
      (when ( < cv 1 )
	  (if (= dir 1)	;skip immutable cells
	      (next-cell)
	      (previous-cell))
	  
	  (ci-loop))

      ;;( print-grid *grid* row-list) (newline)
      ;;(show2-line " vi=" *vi*) ;;(prompt)

      (if (= dir 1)
	  (begin
	    (if (mutate-loop)
		(begin
		  (next-cell)
		  (ci-loop))
		(begin  ;failure, prepare to retreat or backtrack
		  (put-cell-index *grid* *vi* 0)
		  (previous-cell)
		  (set! dir 0))))
	  ( begin ; dir = 0
	    (if (mutate-loop)
		(begin			;go forward again
		  (set! dir 1)
		  (next-cell))
		(begin			;clear cell, retreat
		  (put-cell-index *grid* *vi* 0)
		  (set! *retreats* (+ *retreats* 1))
		  (previous-cell)))))
      
      (ci-loop))))
  
(print (solve *grid*))


( display "\n -- goodbye from sudoku\n" )
(exit)

;; #f