;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; file        : sudoku.lisp
;;; author      : Greatfulfrog: gf_at_gratefulfrog_dot_net
;;; license     : GPL http://www.gnu.org/licenses/gpl.html
;;; date        : 2005 05 31
;;; role        : sudoku puzzle sover.
;;; usage       : This file provides the package "SUDOKU", abreviated "SK"
;;;               and the single exported symbol, the function  "RUN".
;;;               To solve a sudoku puzzle the following inputs are required:
;;;               Size : the size of the puzzle is defined: (sqrt row-length)
;;;                      thus a 9x9 puzzle is of size '3'.
;;;               Initial-Value-A-List
;;;                    : This is an a-list where the car of each element is the
;;;                      position and the cdr is the value at that
;;;                      position. Note that position is zero-based and is thus
;;;                      defined on [0..(expt n 4)[.  Values are defined on
;;;                      [1..(expt n 2)].
;;;               Example
;;;                    : to solve the following size '2'puzzle (4x4):
;;;                      1 2 3 4
;;;                      3 4 1 2
;;;                      2 3 4 1
;;;                      ? ? ? ?
;;;                      Execute the call:
;;;                      (sk:run 2 '((0 . 1) (1 . 2) (2 . 3) (3 . 4) 
;;;                                  (4 . 3) (5 . 4) (6 . 1) (7 . 2) 
;;;                                  (8 . 2) (9 . 3) (10 . 4) (11 . 1)))
;;;                      Which will print out the solution and return nil.
;;;  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 2005 05 31: GF
;;;             initial functions, not yet complete, incrementally tested 100%
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 2005 06 07 : GF
;;;            :  small corrections, now exectues but does not solve...
;;;            : on 2x2 example, finds correct solution but result screwed up
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 2005 06 08 : GF
;;;            : one last small correction, 
;;;            : First working version!
;;;            : added printing routines, exec by: (sk:run n init-lis)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 2005 06 10 : GF
;;;            : Documentation for publication:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 2005 09 08 : GF
;;;            : change use package name to COMMON-LISP to avoid
;;;            : non-std nicknames,
;;;            : added reference to GPL and my email. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "SUDOKU" 
  ;; provide a package to encapsule the functionality 
  (:use "COMMON-LISP")  
  ;; this pkg will access std lisp functions
  (:nicknames "SK") 
  (:export "RUN"))

(in-package "SUDOKU")
;; we are now within the pkg.

(defun run (n init-lis)
  "provided with a puzzle size and an initial value list, the puzzle is 
solved and the solution is pretty-printed.
   Arguments:
     n        : puzzle size, row and col lengths are n**2,
     init-lis : initial values as a-list ((pos . val)...
                where pos is [0..n**4[
   Return:
     nil, but if a solution is found, it is output.
"
  (let ((res-a-lis (init n init-lis)))
    (if res-a-lis (print-grid n res-a-lis) 
      ())))

(defun print-grid (n pos-val-a-lis)
  " takes a size and a solution a-list and prints it out, no checkin for
null solutions at this point.
   Arguments:
     n   : puzzle size, row col lengths are n**2,
     pos-val-a-lis: an a-list containing solution value per position,  
   Return:
     nil, but pretty prints out the result.
"
  (print-helper 0 (expt n 2) pos-val-a-lis))

(defun print-helper (pos row-len pos-val-a-lis)
  "recursive helper to print results, if the pos mod roiw-len is zero, print a
line-feed, then if there is no value for pos, we are done, if not print the
value associated with pos, with sufficient padding, and recurse.
   Arguments:
     pos           : curent position to process
     row-length    : length of a row, used to insert line-feeds
     pos-val-a-lis : a-lis of pos,value pairs.
   Return:
     nil.
"
  (and (zerop (mod pos row-len))
       (format t "~%"))
  (let ((val (cdr (assoc pos pos-val-a-lis))))
    (cond
     ((null val) ())
     (t (format t "~5d" (cdr (assoc pos pos-val-a-lis)))
	(print-helper (1+ pos) row-len  pos-val-a-lis)))))

(defun init (n init-lis) 
  "Initialize the puzzle data structure based on the arguments. The data
   structure used is an a-list: 
     ((pos . val) ...)
   where pos is the sequential numberical id of the position and val is its
   current value, or nil if not assigned.
   Arguments:
     n: the 'size' of the puzzle, or the sqrt of the length of a row,
     init-lis: an a-list of pos . val pairs for initialization
   Return:
     a list of 2 lists: 
       a-list of pos . val pairs wher  val = nl if unknown,
       liberty list uptodate
"
  (let ((pos-libs (init-helper 
		   (1- (expt n 4)) 
		   n 
		   init-lis 
		   (init-liberties n) 
		   ())))
    (solve n (car pos-libs) (cadr pos-libs))))

(defun solve (n pos-lis lib-lis-lis &optional (bound-lis ()))
  "solve the puzzle!
   Arguments:
     n : definining size [0..n**4[
     pos-lis: list of positions, at init this is all the free positons
     lib-lis-lis: list of list of liberties
                 (L-rows L-cols L-boxes) 
                 such that
                 L-rows:  (lr-0 lr-1 ... lr-(n**2-1)
                 L-cols:  (lc-0 lc-1 ... lc-(n**2-1)
                 L-boxes: (lb-0 lb-1 ... lb-(n**2-1)
                 such that each lx-i contains the numbers on [1..n**2[ that are
                 still available for the corresponding row, or col, or box.
     bound-lis: bindings
   Return:
     nil if usolvable
     list of bindings (pos . val)
"
  (cond
   ((null pos-lis) bound-lis)
   ((cdr (car pos-lis)) (solve n
			       (cdr pos-lis)
			       lib-lis-lis
			       (cons (car pos-lis) bound-lis)))
			       
   ((null (liberties n
		     (caar pos-lis) 
		     lib-lis-lis))
    ())
   (t (solve-helper n
		    (caar pos-lis)
		    (liberties n (caar pos-lis) lib-lis-lis)
		    (cdr pos-lis)
		    lib-lis-lis
		    bound-lis))))

(defun solve-helper (n
		     cur-pos 
		     cur-libs 
		     pos-lis 
		     lib-lis-lis
		     bound-lis)
  "Arguments
     n :  size defining positons [0..n**4[
     cur-pos: the position being bound
     cur-lis: list of liberties available to cur-pos
     pos-lis: remaining positions to bound
     lib-lis-lis: full list of list of liberties, including cur-libs
     bound-lis: list of binding pairs
   Return:
     nil if failed,
     bound-lis if success.
"
  (cond
   ((null cur-libs) ())
   (t (or (solve n
		 pos-lis
		 (unliberty (cons cur-pos
				  (car cur-libs))
			    n
			    lib-lis-lis)
		 (cons (cons cur-pos (car cur-libs))
		       bound-lis))
	  (solve-helper n
			cur-pos
			(cdr cur-libs)
			pos-lis
			lib-lis-lis
			bound-lis)))))

(defun liberties (n pos lib-lis-lis)
  "return the intersection of the the 3 liberty lists for the position."
  (reduce #'intersection
	  (get-liberty-lis n pos lib-lis-lis)))

(defun get-liberty-lis (n pos lib-lis-lis) 
  "return the 3 liberty lists for the position."
  (mapcar #'(lambda(rcb id)
	      (nth rcb (nth id lib-lis-lis)))
	  (multiple-value-list (pid2rcb pos n))
	  '(0 1 2)))

(defun init-liberties (n)
  "Initialize and return the list of liberties for the value of n.
   The Liberties data structure is a list of lists:
   Liberties: (L-rows L-cols L-boxes) 
   such that
   L-rows:  (lr-0 lr-1 ... lr-(n**2-1)
   L-cols:  (lc-0 lc-1 ... lc-(n**2-1)
   L-boxes: (lb-0 lb-1 ... lb-(n**2-1)
   such that each lx-i contains the numbers on [1..n**2[ that are still
   available for the corresponding row, or col, or box.
"  
  (let ((numb-liberties (expt n 2)))
    (mapcar #'(lambda(n)
		(make-n-lists numb-liberties
			      #'make-int-list
			      (list numb-liberties)))
	    (make-int-list 3))))

(defun make-n-lists (n maker-func &optional (arg-lis ()) (res ()))
  "make n lists by evaluating maker-func n-times. the n evalutaions of maker
func are consed into a list and returned.
   Arguments:
     n: number of lists to make
     maker-func: function returning elts to be consed into a list
     m-arg-lis: optional list of arguments to maker-func
     res: list to be returned, for tail recursion.
   Return:
     the list of n evaluaitons of (apply maker-func args) 
"
  (if (zerop n) 
      res
    (make-n-lists (1- n)
		  maker-func 
		  arg-lis
		  (cons (apply maker-func arg-lis) 
			res))))

(defun make-int-list (last &optional (first 1) (res ()) )
  "return a list of all intergers on [first..last]"
  (if (< last first)
      res
    (make-int-list (1- last) first (cons last res))))

(defun init-helper (current n init-lis liberty-lis res-lis)
  "Does the work specified in function 'init'
   Arguments:
     current: the current position to create, or -1 if done
     init-lis: an a-list of pos . val pairs for initialization
   Return:
     a list containting (a-list of pos . val pairs liberty-list)
"
  (if (minusp current) 
      (list res-lis liberty-lis)
    (init-helper (1- current) 
		 n
		 init-lis
		 (unliberty (assoc current init-lis)
			    n
			    liberty-lis)
		 (cons (or (assoc current init-lis)
			   (list current))
		       res-lis))))

(defun unliberty (pair n lib-lis)
  "return the lib-lis after removing all liberties correspondin to the values
   in the pair argument. 
   Arguments:
     pair: (pos . val) where pos is on [0..n**2[ or nil if nothing to do.
     n: 'size' of game, i.e. n**2 x n**2
   Return:
     new full liberties list.
"
  (if (not pair)
      lib-lis
    (mapcar #'(lambda(index libs)
		(remove-n-libs (cdr pair) index libs))
	    (multiple-value-list (pid2rcb (car pair) n))
	    lib-lis)))
					    
(defun remove-n-libs (n pos libs)
  "run through the libs until reaching right one, then remove n from it.
   return the new libs
   Arguments:
     n: the number to remove
     pos: the inedx of the lib to act on,
   Return:
     the libs after cleaning
"
  (cond
   ((null libs) ())
   ((zerop pos) (cons (remove-n-lis n (car libs)) (cdr libs)))
   (t (cons (car libs) (remove-n-libs n (1- pos) (cdr libs))))))

(defun remove-n-lis (n lis) 
  "return a copy of the lis with all occurence of n removed."
  (remove-if #'(lambda(elt)(= elt n)) lis))


(defun pid2liberties (pid n libs-lis)
  "return the list of values available at the postion defined by pid on an 
   n**2 x n**2 game.
   Arguments:
     pid: position indicator for elt under study
     n:   'size' of game
     libs-lis: list of list of libs (Lr Lc Lb)
   Return:
     list consisting of the intersection of the r c b liberties for the pid.
"
  (reduce #'intersection
	  (mapcar #'(lambda(rcb libs)
		      (nth rcb libs))
		  (multiple-value-list (pid2rcb pid n))
		  libs-lis)))

(defun pid2rcb (pid n)
  "convert a position id into row; col; bid multiple values and returns them.
   Arguments:
     the pos id as an integer on [0..n**4[
     n: 'size', ie sqrt of length of a row or column
   Return  
     r c b: row id; col id, box-id zero based, on [0..n**2[
"
  (multiple-value-bind (r cn2) (floor (/ pid (expt n 2))) 
		       (let ((c (* (expt n 2) cn2)))
			 (values r c 
				 (+ (* n 
				       (floor (/ r n))) 
				    (floor (/ c n)))))))

(defun pid2rc (pid n)
  "convert a position id into row; col multiple values and returns them.
   Arguments:
     the pos id as an integer on [0..n**4[
     n: 'size', ie sqrt of length of a row or column
   Return  
     r  c : row id; col id, zero based, on [0..n**2[
"
  (multiple-value-bind (r cn2) 
		       (floor (/ pid (expt n 2))) 
		       (values r (* (expt n 2) cn2))))

(defun rc2bid (r c n)
  "convert a (row, col) pair into a box position id and return it.
   Arguments:
     r: row id, zero based, on [0..n**2[
     c: col id, zero based, on [0..n**2[
     n: 'size', ie sqrt of length of a row or column
   Return
     the box id as an integer on [0..n**2[
"
  (+ (* n 
	(floor (/ r n))) 
     (floor (/ c n))))

(defun rc2pid (r c n)
  "convert a (row, col) pair into a position id and return it.
   Arguments:
     r: row id, zero based, on [0..n**2[
     c: col id, zero based, on [0..n**2[
     n: 'size', ie sqrt of length of a row or column
   Return
     the pos id as an integer on [0..n**4[
"
  (+ (* (expt n 2) 
	r) 
     c))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;      End of Code        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
[1]> (load "/home/bob/Desktop/Programming/lisp/Sudoku/sudoku.lisp")
;; Loading file /home/bob/Desktop/Programming/lisp/Sudoku/sudoku.lisp ...
;; Loaded file /home/bob/Desktop/Programming/lisp/Sudoku/sudoku.lisp
T
[2]> (load "/home/bob/Desktop/Programming/lisp/Sudoku/data-sudoku.lisp")
;; Loading file /home/bob/Desktop/Programming/lisp/Sudoku/data-sudoku.lisp ...
;; Loaded file /home/bob/Desktop/Programming/lisp/Sudoku/data-sudoku.lisp
T
[3]> (do-init)
((0 . 1) (1 . 2) (2 . 3) (3 . 4) (4 . 3) (5 . 4) (6 . 1) (7 . 2) (8 . 2)
 (9 . 3) (10 . 4) (11 . 1))

[4]> (sk:run 2 (do-init))

    1    2    3    4
    3    4    1    2
    2    3    4    1
    4    1    2    3
NIL
[7]> (do-init pos-0 val-0)
((0 . 7) (2 . 1) (3 . 6) (5 . 9) (7 . 2) (8 . 8) (9 . 4) (17 . 3) (18 . 3)
 (22 . 2) (35 . 7) (37 . 6) (38 . 8) (40 . 9) (41 . 3) (44 . 4) (48 . 5)
 (50 . 2) (51 . 9) (54 . 5) (58 . 7) (64 . 1) (65 . 7) (67 . 5) (72 . 6)
 (74 . 2) (75 . 9) (76 . 8) (78 . 7) (79 . 5))


[8] (sk:run 3 (do-init pos-0 val-0))

    7    5    1    6    3    9    4    2    8
    4    2    9    8    1    5    6    7    3
    3    8    6    4    2    7    1    9    5
    9    4    5    1    6    8    2    3    7
    2    6    8    7    9    3    5    1    4
    1    7    3    5    4    2    9    8    6
    5    9    4    3    7    1    8    6    2
    8    1    7    2    5    6    3    4    9
    6    3    2    9    8    4    7    5    1
NIL
|#