综合问题

P90 (**) Eight queens problem(八皇后问题）

This is a classical problem in computer science. The objective is to place eight queens on a chessboard so that no two queens are attacking each other; i.e., no two queens are in the same row, the same column, or on the same diagonal.

Hint: Represent the positions of the queens as a list of numbers 1..N. Example: [4,2,7,3,6,8,5,1] means that the queen in the first column is in row 4, the queen in the second column is in row 2, etc. Use the generate-and-test paradigm.

(defun mapa-b (a b)
  (if (> a b)
      nil
      (cons a
	    (mapa-b (1+ a) b))))
(defun canlocat (lst p)
  (let* ((len (length lst))
	(tr1 (+ p len))
	(tr2 (- p len)))
    (labels ((rec (lst1 le)
	       (cond ((null lst1) t)
		     ((or (= p (car lst1))
			  (= (+ (car lst1) le) tr1)
			  (= (- (car lst1) le) tr2))
		      nil)
		     (t (rec (cdr lst1) (1+ le))))))
      (rec lst 0))))
			  
(defun n-queens (num)
  (let ((pos (mapa-b 0 (- num 1))))
    (labels ((rec (n)
	       (if (= n 1)
		   (mapcar #'(lambda (x)
			       (list x))
			   pos)
		   (mapcan 
		    #'(lambda (p)
			(mapcan #'(lambda (lst)
				    (if (canlocat lst p)
					(list (append lst (list p)))
					nil))
				(rec (1- n))))
		    pos))))
      (rec num))))

CL-USER> (pprint (n-queens 8))

((3 1 6 2 5 7 4 0) (4 1 3 6 2 7 5 0) (2 4 1 7 5 3 6 0) (2 5 3 1 7 4 6 0)
 (4 6 0 2 7 5 3 1) (3 5 7 2 0 6 4 1) (2 5 7 0 3 6 4 1) (4 2 7 3 6 0 5 1)
 (4 6 3 0 2 7 5 1) (3 0 4 7 5 2 6 1) (2 5 3 0 7 4 6 1) (3 6 4 2 0 5 7 1)
 (5 3 1 7 4 6 0 2) (5 3 6 0 7 1 4 2) (0 6 3 5 7 1 4 2) (5 7 1 3 0 6 4 2)
 (5 1 6 0 3 7 4 2) (3 6 0 7 4 1 5 2) (4 7 3 0 6 1 5 2) (3 7 0 4 6 1 5 2)
 (1 6 4 7 0 3 5 2) (0 6 4 7 1 3 5 2) (1 4 6 3 0 7 5 2) (3 1 6 4 0 7 5 2)
 (4 6 0 3 1 7 5 2) (5 3 0 4 7 1 6 2) (4 0 3 5 7 1 6 2) (4 1 5 0 6 3 7 2)
 (5 2 6 1 7 4 0 3) (1 6 2 5 7 4 0 3) (6 2 0 5 7 4 1 3) (4 0 7 5 2 6 1 3)
 (0 4 7 5 2 6 1 3) (2 5 7 0 4 6 1 3) (5 2 0 6 4 7 1 3) (6 4 2 0 5 7 1 3)
 (6 2 7 1 4 0 5 3) (4 2 0 6 1 7 5 3) (1 4 6 0 2 7 5 3) (2 5 1 4 7 0 6 3)
 (5 0 4 1 7 2 6 3) (7 2 0 5 1 4 6 3) (1 7 5 0 2 4 6 3) (4 6 1 5 2 0 7 3)
 (2 5 1 6 4 0 7 3) (5 1 6 0 2 4 7 3) (2 6 1 7 5 3 0 4) (5 2 6 1 3 7 0 4)
 (3 1 6 2 5 7 0 4) (6 0 2 7 5 3 1 4) (0 5 7 2 6 3 1 4) (2 7 3 6 0 5 1 4)
 (5 2 6 3 0 7 1 4) (6 3 1 7 5 0 2 4) (3 5 7 1 6 0 2 4) (1 5 0 6 3 7 2 4)
 (1 3 5 7 2 0 6 4) (2 5 7 1 3 0 6 4) (5 2 0 7 3 1 6 4) (7 3 0 2 5 1 6 4)
 (3 7 0 2 5 1 6 4) (1 5 7 2 0 3 6 4) (6 1 5 2 0 3 7 4) (2 5 1 6 0 3 7 4)
 (3 6 2 7 1 4 0 5) (3 7 4 2 0 6 1 5) (2 4 7 3 0 6 1 5) (3 1 7 4 6 0 2 5)
 (4 6 1 3 7 0 2 5) (6 3 1 4 7 0 2 5) (7 1 3 0 6 4 2 5) (6 1 3 0 7 4 2 5)
 (4 0 7 3 1 6 2 5) (3 0 4 7 1 6 2 5) (4 1 7 0 3 6 2 5) (2 6 1 7 4 0 3 5)
 (2 0 6 4 7 1 3 5) (7 1 4 2 0 6 3 5) (2 4 1 7 0 6 3 5) (2 4 6 0 3 1 7 5)
 (4 1 3 5 7 2 0 6) (5 2 4 7 0 3 1 6) (4 7 3 0 2 5 1 6) (3 1 4 7 5 0 2 6)
 (3 5 0 4 1 7 2 6) (5 2 0 7 4 1 3 6) (4 2 0 5 7 1 3 6) (3 1 7 5 0 2 4 6)
 (5 2 4 6 0 3 1 7) (5 3 6 0 2 4 1 7) (3 6 4 1 5 0 2 7) (4 6 1 5 2 0 3 7))

; No value

代码运行了很长时间才结束，上面的代码写的有些问题，使用time测试运行的状态

CL-USER> (time (n-queens 8))
(N-QUEENS 8) took 13,348 milliseconds (13.348 seconds) to run 
                    with 2 available CPU cores.
During that period, 13,088 milliseconds (13.088 seconds) were spent in user mode
                    125 milliseconds (0.125 seconds) were spent in system mode
1,925 milliseconds (1.925 seconds) was spent in GC.
 862,185,264 bytes of memory allocated.

简单修改一下n-queens的写法

(defun n-queens (num)
  (let ((pos (mapa-b 0 (- num 1))))
    (labels ((rec (n)
	       (if (= n 1)
		   (mapcar #'(lambda (x)
			       (list x))
			   pos)
		   (mapcan 
		    #'(lambda (lst)
			(mapcan #'(lambda (p)
				    (if (canlocat lst p)
					(list (append lst (list p)))
					nil))
				pos))
		    (rec (1- n))))))
      (rec num))))

测试一下运行时间，可以看到改善是很明显的
CL-USER> (time (n-queens 8))
(N-QUEENS 8) took 6 milliseconds (0.006 seconds) to run 
                    with 2 available CPU cores.
During that period, 0 milliseconds (0.000 seconds) were spent in user mode
                    0 milliseconds (0.000 seconds) were spent in system mode
 182,968 bytes of memory allocated.

P91 (**) Knight's tour（骑士问题----类似哈密顿回路）

Another famous problem is this one: How can a knight jump on an NxN chessboard in such a way that it visits every square exactly once?

Hints: Represent the squares by pairs of their coordinates of the form X/Y, where both X and Y are integers between 1 and N. (Note that '/' is just a convenient functor, not division!) Define the relation jump(N,X/Y,U/V) to express the fact that a knight can jump from X/Y to U/V on a NxN chessboard. And finally, represent the solution of our problem as a list of N*N knight positions (the knight's tour).

(defvar steps '((1 . 2) (-1 . 2) (1 . -2) (-1 . -2)
		(2 . 1) (-2 . 1) (2 . -1) (-2 . -1)))
(defun knight-N*N (p1 p2 N)
  (labels ((rec (n1)
	     (if (= n1 0)
		 (list (list (cons p1 p2)))
		 (mapcan
		  #'(lambda (path)
		      (mapcan 
		       #'(lambda (ss)
			   (let* ((cur (first path))
				  (pos1 (+ (car cur) (car ss)))
				  (pos2 (+ (cdr cur) (cdr ss))))
			     (if (and (>= pos1 0) (< pos1 N)
				      (>= pos2 0) (< pos2 N)
				      (null (find-if #'(lambda (e)
							 (equal e
								(cons pos1
								      pos2)))
						     path)))
				 (list (cons (cons pos1 pos2)
					     path)))))
		       steps))
		  (rec (1- n1))))))
    (rec (- (* N N) 1))))

(defun find-path (N)
  (labels ((rec (n1)
	     (cond ((< n1 0) nil)
		   ((knight-N*N (truncate (/ n1 N)) 
				(mod n1 N)
				N)
		    (progn 
		      (pprint (knight-N*N (truncate (/ n1 N)) 
				(mod n1 N)
				N))
		      t))
		   (t (rec (1- n1))))))
    (rec (- (* N N) 1))))

CL-USER> (find-path 3)
NIL
CL-USER> (find-path 4)
NIL
CL-USER> (find-path 5)
(((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (0 . 2) (1 . 4) (3 . 3)
  (4 . 1) (2 . 0) (0 . 1) (1 . 3) (3 . 4) (4 . 2) (3 . 0) (1 . 1) (0 . 3)
  (2 . 2) (1 . 0) (3 . 1) (4 . 3) (2 . 4) (3 . 2) (4 . 4))
 ((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (1 . 1) (0 . 3) (2 . 2)
  (3 . 0) (4 . 2) (3 . 4) (1 . 3) (0 . 1) (2 . 0) (4 . 1) (3 . 3) (1 . 4)
  (0 . 2) (1 . 0) (3 . 1) (4 . 3) (2 . 4) (3 . 2) (4 . 4))
 ((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (4 . 2) (3 . 0) (1 . 1)
  (0 . 3) (2 . 2) (3 . 4) (1 . 3) (0 . 1) (2 . 0) (4 . 1) (3 . 3) (1 . 4)
  (0 . 2) (1 . 0) (3 . 1) (4 . 3) (2 . 4) (3 . 2) (4 . 4))
 ((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (3 . 1) (1 . 0) (0 . 2)
  (1 . 4) (3 . 3) (4 . 1) (2 . 0) (0 . 1) (1 . 3) (3 . 4) (4 . 2) (3 . 0)
  (1 . 1) (0 . 3) (2 . 2) (4 . 3) (2 . 4) (3 . 2) (4 . 4))
 ((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (0 . 2) (1 . 0) (3 . 1)
  (4 . 3) (2 . 2) (1 . 4) (3 . 3) (4 . 1) (2 . 0) (0 . 1) (1 . 3) (3 . 4)
  (4 . 2) (3 . 0) (1 . 1) (0 . 3) (2 . 4) (3 . 2) (4 . 4))
 ((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (3 . 1) (4 . 3) (2 . 2)
  (1 . 0) (0 . 2) (1 . 4) (3 . 3) (4 . 1) (2 . 0) (0 . 1) (1 . 3) (3 . 4)
  (4 . 2) (3 . 0) (1 . 1) (0 . 3) (2 . 4) (3 . 2) (4 . 4))
 ((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (4 . 2) (3 . 4) (1 . 3)
  (0 . 1) (2 . 0) (4 . 1) (3 . 3) (1 . 4) (0 . 2) (1 . 0) (3 . 1) (4 . 3)
  (2 . 2) (3 . 0) (1 . 1) (0 . 3) (2 . 4) (3 . 2) (4 . 4))
 ((4 . 0) (2 . 1) (0 . 0) (1 . 2) (0 . 4) (2 . 3) (1 . 1) (3 . 0) (4 . 2)
  (3 . 4) (1 . 3) (0 . 1) (2 . 0) (4 . 1) (3 . 3) (1 . 4) (0 . 2) (1 . 0)
  (3 . 1) (4 . 3) (2 . 2) (0 . 3) (2 . 4) (3 . 2) (4 . 4))

。。。。。。。

P93 (***) An arithmetic puzzle（算术疑团）

Given a list of integer numbers, find a correct way of inserting arithmetic signs (operators) such that the result is a correct equation. Example: With the list of numbers [2,3,5,7,11] we can form the equations 2-3+5+7 = 11 or 2 = (3*5+7)/11 (and ten others!).

(defun two-number-resolve (n1 n2)
  (labels ((one-operator (oper)
	     (cond ((and (equal '/ (first oper))
			 (or (equal (first n2) 0)
			     (equal (first n1) 0)))
		    (cond ((and 
			    (equal (first n2) 0)
			    (equal (first n1) 0)) nil)
			  ((equal (first n2) 0)
			   (list 
			    (list (/ (first n2) 
				     (first n1)) '/  n2 n1)))
			  ((equal (first n1) 0)
			   (list 
			    (list (/ (first n1) 
				     (first n2)) '/  n1 n2)))))
		   ((third oper) 
		    (list 
		     (list (funcall (second oper) (first n1) (first n2))
			   (first oper) n1 n2)
		     (list (funcall (second oper) (first n2) (first n1))
			   (first oper) n2 n1)))
		   (t (list  
		       (list (funcall (second oper) (first n1) (first n2))
			     (first oper) n1 n2))))))
    (mapcan #'one-operator operator-direction)))

(defun n-pairs (lst n)
  (cond ((= n 0) (list nil))
	((= n 1)
	 (mapcar #'(lambda (x) (list x)) lst))
	(t (mapcan
	    #'identity
	    (maplist #'(lambda (lst1)
			 (let ((f (first lst1))
			       (left (cdr lst1)))
			   (mapcar #'(lambda (x)
				       (cons f x))
				   (n-pairs left (1- n)))))
		     lst)))))

(defun puzzle (lst)
  (let ((init (mapcar #'(lambda (x)
			  (list x '~ nil nil))
		      lst)))
    (labels ((rec (lst1)
	       (if (= (length lst1) 1)
		   lst1
		   (mapcan
		    #'(lambda (pair)
			(let ((rest (set-difference lst1 pair))
			      (results (two-number-resolve
				       (first pair) (second pair))))
			  (mapcan #'(lambda (result)
				  (rec (cons result rest)))
				  results)))
		    (n-pairs lst1 2)))))
      (mapcan #'(lambda (e)
		  (let* ((rest (set-difference init (list e)))
			(possi (rec rest)))
		    (mapcan #'(lambda (r1)
				(if (equal (first e)
					   (first r1))
				    (list (list e r1))))
			    possi)))
	      init))))

CL-USER> (pprint (puzzle '(2 3 5 7 11)))


(((2 ~ NIL NIL)
  (2 - (7 + (4 - (11 ~ NIL NIL) (7 ~ NIL NIL)) (3 ~ NIL NIL))
   (5 ~ NIL NIL)))
 ((2 ~ NIL NIL)
  (2 + (-1 - (4 - (11 ~ NIL NIL) (7 ~ NIL NIL)) (5 ~ NIL NIL))
   (3 ~ NIL NIL)))
 ((2 ~ NIL NIL)
  (2 - (3 ~ NIL NIL)
   (1 - (5 ~ NIL NIL) (4 - (11 ~ NIL NIL) (7 ~ NIL NIL)))))
 ((2 ~ NIL NIL)
  (2 / (8 + (3 ~ NIL NIL) (5 ~ NIL NIL))
   (4 - (11 ~ NIL NIL) (7 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 + (-2 - (3 ~ NIL NIL) (5 ~ NIL NIL))
   (4 - (11 ~ NIL NIL) (7 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (4 - (11 ~ NIL NIL) (7 ~ NIL NIL))
   (2 - (5 ~ NIL NIL) (3 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 / (4 - (11 ~ NIL NIL) (7 ~ NIL NIL))
   (2 - (5 ~ NIL NIL) (3 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (7 - (3 ~ NIL NIL) (-4 - (7 ~ NIL NIL) (11 ~ NIL NIL)))
   (5 ~ NIL NIL)))
 ((2 ~ NIL NIL)
  (2 - (3 ~ NIL NIL)
   (1 + (-4 - (7 ~ NIL NIL) (11 ~ NIL NIL)) (5 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (-2 - (3 ~ NIL NIL) (5 ~ NIL NIL))
   (-4 - (7 ~ NIL NIL) (11 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 / (-4 - (7 ~ NIL NIL) (11 ~ NIL NIL))
   (-2 - (3 ~ NIL NIL) (5 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (9 + (6 - (11 ~ NIL NIL) (5 ~ NIL NIL)) (3 ~ NIL NIL))
   (7 ~ NIL NIL)))
 ((2 ~ NIL NIL)
  (2 + (-1 - (6 - (11 ~ NIL NIL) (5 ~ NIL NIL)) (7 ~ NIL NIL))
   (3 ~ NIL NIL)))
 ((2 ~ NIL NIL)
  (2 - (3 ~ NIL NIL)
   (1 - (7 ~ NIL NIL) (6 - (11 ~ NIL NIL) (5 ~ NIL NIL)))))
 ((2 ~ NIL NIL)
  (2 + (-4 - (3 ~ NIL NIL) (7 ~ NIL NIL))
   (6 - (11 ~ NIL NIL) (5 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (6 - (11 ~ NIL NIL) (5 ~ NIL NIL))
   (4 - (7 ~ NIL NIL) (3 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (9 - (3 ~ NIL NIL) (-6 - (5 ~ NIL NIL) (11 ~ NIL NIL)))
   (7 ~ NIL NIL)))
 ((2 ~ NIL NIL)
  (2 - (3 ~ NIL NIL)
   (1 + (-6 - (5 ~ NIL NIL) (11 ~ NIL NIL)) (7 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (-4 - (3 ~ NIL NIL) (7 ~ NIL NIL))
   (-6 - (5 ~ NIL NIL) (11 ~ NIL NIL))))
 ((2 ~ NIL NIL)
  (2 - (9 - (14 + (11 ~ NIL NIL) (3 ~ NIL NIL)) (5 ~ NIL NIL))
   (7 ~ NIL NIL)))
 ((2 ~ NIL NIL)
  (2 - (7 - (14 + (11 ~ NIL NIL) (3 ~ NIL NIL)) (7 ~ NIL NIL))

P94 (***) Generate K-regular simple graphs with N nodes（K邻接正规图）

In a K-regular graph all nodes have a degree of K; i.e. the number of edges incident in each node is K. How many (non-isomorphic!) 3-regular graphs with 6 nodes are there? See also atable of results and a Java applet that can represent graphs geometrically.

(defun all-the-edges (num)
  (let* ((nodes (mapa-b 0 (1- num)))
	 (edges (n-pairs nodes 2)))
    edges))
(defun count-degree (lst node)
  (count node lst :test #'(lambda (n e)
			    (or (equal n (first e))
				(equal n (second e))))))
(defun canjoin (lst e limit)
  (and (< (count-degree lst (first e)) limit)
       (< (count-degree lst (second e)) limit)))
(defun k-regular-g (k n)
  (let ((possible-edge (all-the-edges n))
	(num-of-require (/ (* n k) 2)))
    (labels ((rec (n1 lst-1 lst1) ;return a list contain 
	       (let ((len (length lst1)))
		 (cond ((> n1 len) nil)
		       ((= n1 0) (list lst-1))
		       (t 
			(mapcon #'(lambda (l)
				    (if (canjoin lst-1 (first l) k)
					(rec (1- n1) 
					     (cons (first l) lst-1)
					     (cdr l))
					nil))
				lst1))))))
	     (rec num-of-require nil possible-edge))))

CL-USER> (k-regular-g 2 4)
(((2 3) (1 3) (0 2) (0 1)) ((2 3) (1 2) (0 3) (0 1)) ((1 3) (1 2) (0 3) (0 2)))
CL-USER> (k-regular-g 3 4)
(((2 3) (1 3) (1 2) (0 3) (0 2) (0 1)))

CL-USER> (pprint (k-regular-g 3 6))


(((4 5) (3 5) (3 4) (2 5) (1 4) (1 2) (0 3) (0 2) (0 1))
 ((4 5) (3 5) (3 4) (2 4) (1 5) (1 2) (0 3) (0 2) (0 1))
 ((4 5) (3 5) (2 5) (2 4) (1 4) (1 3) (0 3) (0 2) (0 1))
 ((4 5) (3 4) (2 5) (2 4) (1 5) (1 3) (0 3) (0 2) (0 1))
 ((4 5) (3 5) (2 4) (2 3) (1 5) (1 4) (0 3) (0 2) (0 1))
 ((4 5) (3 4) (2 5) (2 3) (1 5) (1 4) (0 3) (0 2) (0 1))
 ((3 5) (3 4) (2 5) (2 4) (1 5) (1 4) (0 3) (0 2) (0 1))
 ((4 5) (3 5) (3 4) (2 5) (1 3) (1 2) (0 4) (0 2) (0 1))
 ((4 5) (3 5) (3 4) (2 3) (1 5) (1 2) (0 4) (0 2) (0 1))
 ((4 5) (3 5) (2 5) (2 3) (1 4) (1 3) (0 4) (0 2) (0 1))
 ((4 5) (3 5) (2 4) (2 3) (1 5) (1 3) (0 4) (0 2) (0 1))
 ((4 5) (3 4) (2 5) (2 3) (1 5) (1 3) (0 4) (0 2) (0 1))
 ((3 5) (3 4) (2 5) (2 4) (1 5) (1 3) (0 4) (0 2) (0 1))
 ((3 5) (3 4) (2 5) (2 3) (1 5) (1 4) (0 4) (0 2) (0 1))
 ((4 5) (3 5) (3 4) (2 4) (1 3) (1 2) (0 5) (0 2) (0 1))
 ((4 5) (3 5) (3 4) (2 3) (1 4) (1 2) (0 5) (0 2) (0 1))
 ((4 5) (3 5) (2 4) (2 3) (1 4) (1 3) (0 5) (0 2) (0 1))
 ((4 5) (3 4) (2 5) (2 3) (1 4) (1 3) (0 5) (0 2) (0 1))
 ((3 5) (3 4) (2 5) (2 4) (1 4) (1 3) (0 5) (0 2) (0 1))
 ((4 5) (3 4) (2 4) (2 3) (1 5) (1 3) (0 5) (0 2) (0 1))
 ((3 5) (3 4) (2 4) (2 3) (1 5) (1 4) (0 5) (0 2) (0 1))
 ((4 5) (3 5) (2 5) (2 4) (1 3) (1 2) (0 4) (0 3) (0 1))
 ((4 5) (3 5) (2 5) (2 3) (1 4) (1 2) (0 4) (0 3) (0 1))
 ((4 5) (3 5) (2 4) (2 3) (1 5) (1 2) (0 4) (0 3) (0 1))
 ((4 5) (3 4) (2 5) (2 3) (1 5) (1 2) (0 4) (0 3) (0 1))
 ((3 5) (3 4) (2 5) (2 4) (1 5) (1 2) (0 4) (0 3) (0 1))
 ((4 5) (2 5) (2 4) (2 3) (1 5) (1 3) (0 4) (0 3) (0 1))

。。。。。

P95 (**) English number words（简单题，可能是我理解错了）

On financial documents, like cheques, numbers must sometimes be written in full words. Example: 175 must be written as one-seven-five. Write a predicate full-words/1 to print (non-negative) integer numbers in full words.

这个题目很简单，居然是两星

(defun number-to-full-word (num)
  (if (< num 9)
      (list (second (assoc num map-number-word)))
      (cons (second (assoc (mod num 10) 
			   map-number-word))
	    (number-to-full-word (truncate (/ num 10))))))
(defun num-full-word (num)
  (let ((result (nreverse (number-to-full-word num))))
    (labels ((rec (lst)
	       (cond ((null lst) t)
		     ((null (cdr lst)) (princ (first lst)))
		     (t (progn
			  (princ (first lst))
			  (princ "-")
			  (rec (cdr lst)))))))
      (rec result))))

P97 (**) Sudoku

Sudoku puzzles go like this:

   Problem statement                 Solution

    .  .  4 | 8  .  . | .  1  7	     9  3  4 | 8  2  5 | 6  1  7	     
            |         |                      |         |
    6  7  . | 9  .  . | .  .  .	     6  7  2 | 9  1  4 | 8  5  3
            |         |                      |         |
    5  .  8 | .  3  . | .  .  4      5  1  8 | 6  3  7 | 9  2  4
    --------+---------+--------      --------+---------+--------
    3  .  . | 7  4  . | 1  .  .      3  2  5 | 7  4  8 | 1  6  9
            |         |                      |         |
    .  6  9 | .  .  . | 7  8  .      4  6  9 | 1  5  3 | 7  8  2
            |         |                      |         |
    .  .  1 | .  6  9 | .  .  5      7  8  1 | 2  6  9 | 4  3  5
    --------+---------+--------      --------+---------+--------
    1  .  . | .  8  . | 3  .  6	     1  9  7 | 5  8  2 | 3  4  6
            |         |                      |         |
    .  .  . | .  .  6 | .  9  1	     8  5  3 | 4  7  6 | 2  9  1
            |         |                      |         |
    2  4  . | .  .  1 | 5  .  .      2  4  6 | 3  9  1 | 5  7  8
   

Every spot in the puzzle belongs to a (horizontal) row and a (vertical) column, as well as to one single 3x3 square (which we call "square" for short). At the beginning, some of the spots carry a single-digit number between 1 and 9. The problem is to fill the missing spots with digits in such a way that every number between 1 and 9 appears exactly once in each row, in each column, and in each square.

(defparameter sudoku-input 
  '(N N 4 8 N N N 1 7
    6 7 N 9 N N N N N
    5 N 8 N 3 N N N 4
    3 N N 7 4 N 1 N N
    N 6 9 N N N 7 8 N
    N N 1 N 6 9 N N 5
    1 N N N 8 N 3 N 6
    N N N N N 6 N 9 1
    2 4 N N N 1 5 N N ))
(defvar *dims* (* 9 9))
(defparameter *array* (make-array *dims* :initial-contents sudoku-input))

(defun could-put(arr p1 p2 square num)
  (let* ((sp1 (truncate (/ p1 3)))
	 (sp2 (truncate (/ p2 3)))
	 (sph (* sp1 3))
	 (spv (* sp2 3)))
    (labels ((pos (p-1 p-2)
	       (+ (* p-1 square)
		  p-2))
	     (herizo (i)
	       (pos p1 i))
	     (verti (i)
	       (pos i p2))
	     (sb (i)
	       (let ((si-1 (truncate (/ i 3)))
		     (si-2 (mod i 3)))
		 (pos (+ sph si-1) (+ spv si-2))))
	     (find-equal (i)
	       (let* ((orig (pos p1 p2))
		      (h (herizo i))
		      (v (verti i))
		      (s (sb i)))
		 (or (and (/= h orig)
			  (equal num (aref arr h)))
		     (and (/= v orig)
			  (equal num (aref arr v)))
		     (and (/= s orig)
			  (equal num (aref arr s))))))
	     (rec (i)
	       (if (= i 9)
		   t
		   (and (not (find-equal i))
			(rec (1+ i))))))
      (rec 0))))
(defun mapa-b (a b)
  (if (> a b)
      nil
      (cons a
	    (mapa-b (1+ a) b))))
(defvar lst-nums (mapa-b 1 9))
(defun solve (lst i)
  (let ((p1 (truncate (/ i 9)))
	(p2 (mod i 9)))
    (mapcan #'(lambda (arr)
		(mapcan 
		 #'(lambda (n)
		     (if (could-put arr p1 p2 9 n)
			 (let ((na (make-array *dims* 
					       :initial-contents arr)))
			   (setf (aref na i) n)
			   (list na))))
		 lst-nums))
	    lst)))
(defun sudoku (array)
  (labels ((rec (lst i)
	     (cond ((= i 81) lst)
		   ((equal (aref array i) 'n) 
		    (rec (solve lst i) (1+ i)))
		   (t (rec lst (1+ i))))))
    (rec (list array) 0)))

CL-USER> (sudoku *array*)
(#(9 3 4 8 2 5 6 1 7 6 7 2 9 1 4 8 5 3 5 1 8 6 3 7 9 2 4 3 2 5 7 4 8 1 6 9 4 6 9 1 5 3 7 8 2 7 8 1 2 6 9 4 3 5 1 9 7 5 8 2 3 4 6 8 5 3 4 7 6 2 9 1 2 4 6 3 9 1 5 7 8))

P98 (***) Nonograms

Around 1994, a certain kind of puzzles was very popular in England. The "Sunday Telegraph" newspaper wrote: "Nonograms are puzzles from Japan and are currently published each week only in The Sunday Telegraph. Simply use your logic and skill to complete the grid and reveal a picture or diagram." As a Prolog programmer, you are in a better situation: you can have your computer do the work! Just write a little program ;-).

The puzzle goes like this: Essentially, each row and column of a rectangular bitmap is annotated with the respective lengths of its distinct strings of occupied cells. The person who solves the puzzle must complete the bitmap given only these lengths.

          Problem statement:          Solution:

          |_|_|_|_|_|_|_|_| 3         |_|X|X|X|_|_|_|_| 3           
          |_|_|_|_|_|_|_|_| 2 1       |X|X|_|X|_|_|_|_| 2 1         
          |_|_|_|_|_|_|_|_| 3 2       |_|X|X|X|_|_|X|X| 3 2         
          |_|_|_|_|_|_|_|_| 2 2       |_|_|X|X|_|_|X|X| 2 2         
          |_|_|_|_|_|_|_|_| 6         |_|_|X|X|X|X|X|X| 6           
          |_|_|_|_|_|_|_|_| 1 5       |X|_|X|X|X|X|X|_| 1 5         
          |_|_|_|_|_|_|_|_| 6         |X|X|X|X|X|X|_|_| 6           
          |_|_|_|_|_|_|_|_| 1         |_|_|_|_|X|_|_|_| 1           
          |_|_|_|_|_|_|_|_| 2         |_|_|_|X|X|_|_|_| 2           
           1 3 1 7 5 3 4 3             1 3 1 7 5 3 4 3              
           2 1 5 1                     2 1 5 1                      
   

For the example above, the problem can be stated as the two lists [[3],[2,1],[3,2],[2,2],[6],[1,5],[6],[1],[2]] and [[1,2],[3,1],[1,5],[7,1],[5],[3],[4],[3]] which give the "solid" lengths of the rows and columns, top-to-bottom and left-to-right, respectively. Published puzzles are larger than this example, e.g. 25 x 20, and apparently always have unique solutions.

   1. 按照行搜索，每次看加入的是否符合列要求
      
      行搜索的过程是：搜索函数的参数设为(i lst)，假如插入的X分布是(2
      1), 如果当前i列放入lst第一个要求，则在i+3放入（cdr lst），或者当
      前位置不放入lst第一个，则在（（1+ i） lst）中接着搜索。


      搜索退出的条件是，当lst为null时，说明lst前面要求放入的X可以满足，
      返回array的副本，当lst不为null，则查看当前位置是否可以放（first
      lst）的要求，如果不能，返回nil，如果可以，使用上面的搜索过程。


      查看是否符合一列的要求：复制一列，然后将相邻的X归为一组，比如上图第0列的分组是
      （（X） （X X）），然后列要求是（1 2）,检查函数的参数为（lst-x lst-r)，如果lst-x为空，
      显然前面都符合，返回真，如果lst-r为空，则表明有多余的x，返回假，
      fx为第一组，fr为第一个要求，如果fx的长度小于fr，如果lst-r后面的为空，则递归检查，
      如果fx的长度大于fr，返回假，否则，递归检查

算法如下：

(defparameter *grams* '(_ X X X _ _ _ _
			X X _ X _ _ _ _
			_ X X X _ _ X X
			_ _ X X _ _ X X
			_ _ X X X X X X
			X _ X X X X X _
			X X X X X X _ _
			_ _ _ _ X _ _ _
			_ _ _ X X _ _ _))
(defparameter row 9)
(defparameter col 8)
(defparameter *gram-array* (make-array (* row col) :initial-contents
				       *grams*))
(defparameter *row-request* '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)))
(defparameter *colum-request* '((1 2) (3 1) (1 5) (7 1) (5) (3) (4) (3)))
(defun pos (i j max)
  (+ (* i max) j))
(defun copy-column-to-list (arr j col row)
  (labels ((rec (acc i)
	     (if (= i row)
		 (nreverse acc)
		 (rec (cons (aref arr
				  (pos i j col))
			    acc)
		      (1+ i)))))
    (rec nil 0)))

(defun group (lst pred)
  (labels ((rec (acc lst-1)
	     (cond ((null lst-1)
		    (list acc))
		   ((funcall pred acc (first lst-1))
		    (rec (nconc acc (list (first lst-1)))
			 (cdr lst-1)))
		   (t (cons acc
			    (rec  (list (first lst-1))
				  (cdr lst-1)))))))
    (if (null lst)
	nil
	(rec (list (first lst)) (cdr lst)))))

(defun group-by-length (lst n)
  (group lst #'(lambda (lst1 e)
		 (declare (ignore e))
		 (< (length lst1) n))))

(defun group-the-same (lst)
  (group lst #'(lambda (lst1 e)
		 (equal (first lst1) e))))

引用list-classify.lisp代码见上

(load "f:/source-reading/lisp-package/lisp-code/list-classify.lisp")
(defun group-x (lst)
  (mapcan #'(lambda (lst-1)
	      (if (equal (first lst-1)
			 'X)
		  (list lst-1)))
	  (group-the-same lst)))
(defun check (arr c col row lst)
  (let ((g (group-x
	    (copy-column-to-list arr c col row))))
    (labels ((rec (lst-1 g-1)
	       (cond ((null g-1) t)
		     ((null lst-1) nil)
		     (t (let* ((f (first lst-1))
			       (gg (first g-1))
			       (glen (length gg)))
			  (cond ((> glen f) nil)
				((and 
				  (< glen f)
				  (not (null (cdr g-1))))
				 nil)
				(t (rec (cdr lst-1) (cdr g-1)))))))))
      (rec lst g))))
(defun isValid(array col row lst)
  (labels ((rec (lst-1 i)
	     (if (= i col)
		 t
		 (and (check array i col row (first lst-1))
		      (rec (cdr lst-1) (1+ i))))))
    (rec lst 0)))
  
(defparameter *null-array* 
	     (make-array (* col row) :initial-element '_))
(defun fill-1 (array r col row lst)
  (labels ((rec (i rest)
	     (if (null rest)
		 (list (make-array (* row col) 
				   :initial-contents array))
		 (let* ((f (first rest))
			(stop (- col f)))
		   (if (> i stop)
		       nil
		       (nconc 
			(mapcar #'(lambda (a)
				    (loop for j from i to (- (+ f i)
							     1)
					 do
					 (setf (aref a (pos r j col))
					       'X))
				    a)
				(rec (+ i f 1) (cdr rest)))
			(rec (1+ i) rest)))))))
    (rec 0 lst)))
(fill-1 *null-array* 0 col row (first *row-request*))

(defun Nonograms (array row col row-r col-r)
  (labels ((rec (r left-r acc)
	     (let ((lef (remove nil acc 
				:key #'(lambda (a)
					 (isValid a col row col-r)))))
	       (if (= r row)
		   lef
		   (rec (1+ r)
			(cdr left-r)
			(mapcan #'(lambda (e)
				    (fill-1 e r col row (first left-r)))
				lef))))))
    (rec 0 row-r (list array))))

(defun print-a (array col row)
  (loop for i from 0 to (1- row) do
       (loop for j from 0 to (1- col) do
	    (format t "~a" (aref array (pos i j col))))
       (format t "~%")))

(defun solve-non (array row col row-r col-r)
  (mapcar #'(lambda (e)
	      (print-a e col row)
	      (format t "~%~%"))
	  (Nonograms array row col row-r col-r)))

CL-USER> (solve-non *null-array* row col *row-request* *colum-request*)
_XXX____
XX_X____
_XXX__XX
__XX__XX
__XXXXXX
X_XXXXX_
XXXXXX__
____X___
___XX___




(NIL)

CL-USER> 

   2. 按照行或者列加入x，选择的方法是给每一个放置X的要求设计一个分数，然后取分
      数最小的作为当前要求放置X
      
      如果当前放置的是行，则需要检查所有的列，如果当前放置的是列，则需
      要检查所有的行，实际上并没有好的检查方法，目前的做法是检查总数不
      超过要求的总数，这种粗糙的检查方法不能有效的缩小结果集，需要改进


      设计score函数如下，加入当前要求为（f0，f1, f2 .....)，并且当前行
      或者列中已有K个X， 则为(S-f0+1-K) *  (S - f0 -f1-K) * (S - f0 -f1 -f2-K)


      需要记录那些行或者列已经放置过了，因此搜索的时候需要一个行和列的
      链表记录搜索过的。设计还是很复杂.

(load "f:/source-reading/lisp-package/lisp-code/list-classify.lisp")
(defun group-x (lst)
  (mapcan #'(lambda (lst-1)
	      (if (equal (first lst-1)
			 'X)
		  (list lst-1)))
	  (group-the-same lst)))
(defun pos (i j max)
  (+ (* i (1+ max)) j))
(defparameter *grams* '(_ X X X _ _ _ _ _
			X X _ X _ _ _ _ _
			_ X X X _ _ X X _
			_ _ X X _ _ X X _
			_ _ X X X X X X _
			X _ X X X X X _ _
			X X X X X X _ _ _
			_ _ _ _ X _ _ _ _
			_ _ _ X X _ _ _ _
			_ _ _ _ _ _ _ _ _))
(defparameter *gram-array* (make-array (* 9 10) :initial-contents
				       *grams*))
(defun mark-used (array request colum row)
  (let ((col-or-row? (second request)))
    (setf (aref array (pos (if col-or-row? row (first request))
			  (if col-or-row? (first request) colum)
			  colum))
	 'X)))
(defun is-used (array request colum row)
    (let ((col-or-row? (second request)))
    (equal (aref array (pos (if col-or-row? row (first request))
			  (if col-or-row? (first request) colum)
			  colum))
	 'X)))
(defun copy-col-row (arr j col row &optional (col? t))
  (labels ((rec (acc i)
	     (if (= i (if col? row col))
		 (nreverse acc)
		 (rec (cons (aref arr
				  (pos (if col? i j)
				       (if col? j i)
				       col))
			    acc)
		      (1+ i)))))
    (rec nil 0)))
;request is like this (i col-or-row (list request)) i indicate which
;row or column
(defun check (arr  col row request)
  (let ((g (group-x
	    (copy-col-row 
	     arr (first request) col row (second request))))
	(lst (third request)))
    (labels ((rec (lst-1 g-1)
	       (cond ((null g-1) t)
		     ((null lst-1) nil)
		     (t (let* ((f (first lst-1))
			       (gg (first g-1))
			       (glen (length gg)))
			  (cond ((> glen f) nil)
				((and 
				  (< glen f)
				  (not (null (cdr g-1))))
				 nil)
				(t (rec (cdr lst-1) (cdr g-1)))))))))
      (rec lst g))))
(defun check-2(arr col row request)
  (let ((copy (copy-col-row arr (first request) 
			    col row (second request)))
	(cnt (reduce #'+ (third request))))
    (<= (count 'X copy) cnt)))
(defun isValid(array col row requests)
  (let ((col-or-row? (second (first requests))))
    (labels ((rec (lst-1 i)
	       (if (= i (if col-or-row? col row))
		   t
		   (and (check-2 array col row (first lst-1))
			(rec (cdr lst-1) (1+ i))))))
      (rec requests 0))))
(defun score (array request col row)
    (let ((cr (first request))
	  (c-or-r (second request))
	  (use? (is-used array request col row)))
      (if use?
	  1000 ;i think it is big
	  (let ((count 0))
	    (loop for i from 0 to (- (if c-or-r row col) 1) do
		 (if (equal 'X
			    (aref array (pos (if c-or-r i cr)
					     (if c-or-r cr i)
					     col)))
		     (incf count)))
	    (labels ((rec (left lst)
		       (if (null lst)
			   1
			   (let ((s (- left (first lst))))
			     (* s
				(rec s (cdr lst)))))))
	      (rec (- (if c-or-r row col) count) (third request)))))))
(defun most-min(array requests col row)
  (labels ((rec (mv mr lst)
	     (if (null lst)
		 mr
		 (let ((s (score array (first lst) col row)))
		   (if (< s mv)
		       (rec s (first lst) (cdr lst))
		       (rec mv mr (cdr lst)))))))
    (rec (score array (first requests) col row)
	 (first requests)
	 (cdr requests))))
(defun fill-a (array request col row r-c r-r)
  (let* ((c-or-r (second request))
	 (cr (first request))
	 (lst (third request))
	 (r-check (if c-or-r r-r r-c)))
    (labels ((rec (i rest)
	       (if (null rest)
		   (list (make-array (* (1+ row) (1+ col))
				     :initial-contents array))
		   (let* ((f (first rest))
			  (stop (- (if c-or-r row col) f)))
		     (if (> i stop)
			 nil
			 (nconc 
			  (mapcar #'(lambda (a)
				      (loop for j from i to (- (+ f i)
							       1)
					 do
					   (setf (aref a (pos (if c-or-r j cr)
							      (if c-or-r cr j)
							    col))
					       'X))
				    a)
				(rec (+ i f 1) (cdr rest)))
			(rec (1+ i) rest)))))))
      (mark-used array request col row)
      (remove nil (rec 0 lst) :key #'(lambda (e)
				       (if (and 
					    (check e col row request)
					    (isValid e col row r-check))
					   e))))))
(defun print-a (array col row)
  (loop for i from 0 to (1- row) do
       (loop for j from 0 to (1- col) do
	    (format t "~a " (aref array (pos i j col))))
       (format t "~%"))
  (format t "~%~%"))	
(defvar *testing-array* #(_ X X X _ _ _ _ _
			  X X _ X _ _ _ _ _
			  _ X X X _ _ X X _
			  _ _ X X _ _ X X _
			  _ _ X X X X X X _
			  X X X X X X X _ _
			  X X X X X X _ _ _
			  _ _ _ _ X _ _ _ _
			  _ _ _ X X _ _ _ _
			  _ _ _ _ _ _ _ _ _))			 
(defun new-solve-non (col row r-c r-r)
  (let ((requests (append r-c r-r)))
    (labels ((rec (lst i)
	       (if (= i (+ col row))
		   lst
		   (rec
		    (mapcan #'(lambda (e)
				(let ((choice (most-min e requests col row)))
				  (fill-a e choice col row r-c r-r)))
			    lst)
		    (1+ i)))))
      (rec (list (make-array (* (1+ col)
			  (1+ row))
		       :initial-element '_)) 0))))
(defvar *test1* (make-array (* (1+ 8)
			  (1+ 9))
		       :initial-element '_))

(new-solve-non 8 9 '((0 t (1 2)) (1 t (3 1))
			      (2 t (1 5)) (3 t (7 1))
			      (4 t (5)  ) (5 t  (3))
			      (6 t (4))   (7 t  (3)))
			'((0 nil (3)) (1 nil (2 1))
			  (2 nil (3 2)) (3 nil (2 2))
			  (4 nil (6)) (5 nil (1 5))
			  (6 nil (6)) (7 nil (1))
			  (8 nil (2))))

CL-USER> (mapcar #'(lambda (e)
    (print-a e 8 9))(new-solve-non 8 9 '((0 t (1 2)) (1 t (3 1))
     (2 t (1 5)) (3 t (7 1))
     (4 t (5)  ) (5 t  (3))
     (6 t (4))   (7 t  (3)))
'((0 nil (3)) (1 nil (2 1))
 (2 nil (3 2)) (3 nil (2 2))
 (4 nil (6)) (5 nil (1 5))
 (6 nil (6)) (7 nil (1))
 (8 nil (2)))))
_ X X X _ _ _ _ 
X X _ X _ _ _ _ 
_ X X X _ _ X X 
_ _ X X _ _ X X 
_ _ X X X X X X 
X _ X X X X X _ 
X X X X X X _ _ 
_ _ _ _ X _ _ _ 
_ _ _ X X _ _ _ 




(NIL)
CL-USER>