【e派】数独——LSP求解

xyp1964

数独的布局分为行、列和宫三类，利用LSP的表处理强项，实现数独求解也许可以练练手……
81码数字字符串：
000000980020010000004057010000000506019060340203000000080420100000070030076000000

起始布局如下：


有兴趣的可以来讨论讨论。

yxp

最近经常开会无聊的时候就玩玩数独，顺手查了一下数独的相关知识。
终盘数量:
数独中的数字排列千变万化，那么究竟有多少种终盘的数字组合呢？
答案是6,670,903,752,021,072,936,960（约为6.67×10的21次方）种组合，2005年由Bertram Felgenhauer和Frazer Jarvis计算出该数字，并将计算方法发布在他们网站上，如果将等价终盘（如旋转、翻转、行行对换，数字对换等变形）不计算，则有5,472,730,538个组合。数独终盘的组合数量都如此惊人，那么数独题目数量就更加不计其数了，因为每个数独终盘又可以根据提示数的多寡，制作出无数道合格的数独题目。

标准数独:
目前（截止2011年）发现的最少提示数9×9标准数独为17个提示数，截止2011年11月24日16:14，共发现了非等价17提示数谜题49151题，此数量仍在缓慢上升中，如果你先发现了17提示数的题目，可以上传至“17格数独验证”网站，当然你也可以在这里下载这49151题。
Gary McGuire的团队在2009年设计了新的算法，利用Deadly Pattern的思路，花费710万小时CPU时间后，于2012年1月1日提出了9×9标准数独不存在16提示唯一解的证明，继而说明最少需要17个提示数。并将他们的论文以及源代码更新在2009年的页面上。


看见e派用了自定义函数，用标准lisp函数也不是很麻烦，关键是求解数独的算法。

1. ;; sudoku-str->row 字符串转行表，传入参数 str
   
2. ;;(setq str "000000980020010000004057010000000506019060340203000000080420100000070030076000000")
   
3. (defun sudoku-str->row(str)(DivLst (mapcar 'atoi (mapcar 'chr (vl-string->list str))) 9))
   
4. 
   
5. 
   
6. ;; sudoku-row->col 行表转列表，传入参数 lst
   
7. ;;(setq lst (sudoku-str->row str))
   
8. (defun sudoku-row->col (lst / NL S N)
   
9. (while (car lst)
   
10.   (foreach x lst (setq S (cons (car x) S) N (cons (cdr x) N)))
    
11.   (setq lst (reverse N) NL (cons (reverse S) NL) S nil N nil)
    
12. )(reverse NL)
    
13. )
    
14. 
    
15. 
    
16. ;; sudoku-row->9gg 行表转宫表，传入参数 lst
    
17. ;;(setq lst (sudoku-str->row str))
    
18. (defun sudoku-row->9gg(lst / SN)
    
19. (foreach x (sudoku-row->col (mapcar '(lambda (x)(DivLst x 3)) lst))
    
20. (setq SN (cons (DivLst (apply 'append x) 9) SN)))
    
21. (apply 'append (reverse SN))
    
22. )
    
23.   
    
24. 
    
25. ;;定长分割表函数
    
26. (defun DivLst(lst n / a b)
    
27. (while lst
    
28.   (setq b nil i 0)
    
29.   (while (< i n) (setq b (cons (car lst) b) lst (cdr lst) i (1+ i)))
    
30.   (setq a (cons (reverse b) a))
    
31. )(reverse a)
    
32. )

;; sudoku-str->row 字符串转行表，传入参数 str<br /> ;;(setq str "000000980020010000004057010000000506019060340203000000080420100000070030076000000")<br /> (defun sudoku-str->row(str)(DivLst (mapcar 'atoi (mapcar 'chr (vl-string->list str))) 9))<br /> <br /> <br /> ;; sudoku-row->col 行表转列表，传入参数 lst<br /> ;;(setq lst (sudoku-str->row str))<br /> (defun sudoku-row->col (lst / NL S N)<br /> (while (car lst)<br />   (foreach x lst (setq S (cons (car x) S) N (cons (cdr x) N)))<br />   (setq lst (reverse N) NL (cons (reverse S) NL) S nil N nil)<br /> )(reverse NL)<br /> )<br /> <br /> <br /> ;; sudoku-row->9gg 行表转宫表，传入参数 lst<br /> ;;(setq lst (sudoku-str->row str))<br /> (defun sudoku-row->9gg(lst / SN)<br /> (foreach x (sudoku-row->col (mapcar '(lambda (x)(DivLst x 3)) lst))<br /> (setq SN (cons (DivLst (apply 'append x) 9) SN)))<br /> (apply 'append (reverse SN))<br /> )<br />   <br /> <br /> ;;定长分割表函数<br /> (defun DivLst(lst n / a b)<br /> (while lst<br />   (setq b nil i 0)<br />   (while (< i n) (setq b (cons (car lst) b) lst (cdr lst) i (1+ i)))<br />   (setq a (cons (reverse b) a))<br /> )(reverse a)<br /> )

yxp

回溯法
一、在第一个格子填上1，检查行、列和九宫格是否合法。如果合法，跳入下一个格子，从1开始测试；如果不合法，则继续测试2、 3......
二、如果下一个格子1-9都测试完了，全部不合法，说明上一个格子填错了，则回溯到上一步，继续测试2、 3......所有格子测试的数字只有1-9，所以不存在死循环的问题。

1. ;;*******************************************************
   
2. ;;          LISP 数独求解：回溯法（穷举法）
   
3. ;;*******************************************************
   
4. ;;回溯法主程序
   
5. (defun c:sudoku2( / str m x sulsp xSudo)
   
6. (setq str "000000980020010000004057010000000506019060340203000000080420100000070030076000000")
   
7. ;(setq str "800000000003600000070090200050007000000045700000100030001000068008500010090000400")
   
8. (setq m 0 x 1 sulsp (str->row str) xSudo nil)
   
9. (sudoku-print (DivLst sulsp 9)) ;;显示题目
   
10. (setq *s1* (getvar "date")) ;;计时开始
    
11. (while (< m 81)                           ;;测试数独的81个格子，m 为格子指针值为 0-80
    
12.         (setq hl9g (Cal99 m (updateLst xSudo sulsp)))
    
13.         (if (zerop (nth m sulsp))(progn       ;;如果m格子里数据为0，则进入循环
    
14.                 (while (and (<= x 9)(apply 'or (mapcar '(lambda(y)(member x y))hl9g)))(setq x (1+ x)));;合法性
    
15.                 (if (> x 9)                       ;;当x>9时，显然该回溯了
    
16.                         (while (>= x 9)
    
17.                                 (setq x (car xSudo) xSudo (cdr xSudo) ;;数据回溯遇到 9 则继续回溯
    
18.                                         x (1+ x) m (1- m)) (entdel(entlast))
    
19.                                 (while (> (nth m sulsp) 0)(setq m (1- m))) ;;指针回溯稍微麻烦，遇到原始数据则需要继续
    
20.                         )(setq xSudo (cons x xSudo) LJ (dxftxt (itoa x) m) x 1 m (1+ m))   ;;x 归位，m 跳入下一格
    
21.                 ))(setq m (1+ m) x 1)   ;;如果下一个格子有数据，即 m 格子数据不为 0，则跳入下一格， x 复位
    
22.         )
    
23. ) (princ (strcat "\n数独回溯法求解耗时 " (rtos (* 86400.0 (- (getvar "date") *s1*)) 2 4) " 秒"))
    
24. (princ)
    
25. )
    
26. 
    
27. ;;行、列、九宫计算
    
28. ;;返回一维表数字 L 中第 n 个数字所在的行、列和九宫数的组合
    
29. (defun Cal99(n L / mn mr mc ms k Lr Lc Ls)
    
30. (setq k 0 Lr nil Lc nil Ls nil
    
31.         mn (Calxm n)
    
32.         mr (car mn)
    
33.         mc (cadr mn)
    
34.         ms (caddr mn))
    
35. (foreach x L (setq kk (Calxm k) k (1+ k))
    
36.         (if (= (car kk) mr)(setq Lr (cons x Lr)))    ;;行
    
37.         (if (= (cadr kk) mc)(setq Lc (cons x Lc)))   ;;列
    
38.         (if (= (caddr kk) ms)(setq Ls (cons x Ls)))) ;;宫
    
39. (list Lr Lc Ls)
    
40. )
    
41. 
    
42. ;;返回第 m 个数字在九宫格里的行、列、宫号，均为 0-8
    
43. (defun Calxm(m / r c s)
    
44. (setq r (/ m 9) c (- m (* r 9)) s (+ (* 3 (/ r 3))(/ c 3)))
    
45. (list r c s)
    
46. )
    
47. 
    
48. ;;将计算出的数独 L1 与原始数独 L2 合并
    
49. (defun updateLst(L1 L2)
    
50. (setq xL (reverse L1) NL '())
    
51. (foreach x L2 (if (and (= x 0)(car xL))
    
52.         (setq NL (cons (car xL) NL) xL (cdr xL))
    
53.         (setq NL (cons x NL))))
    
54. (reverse NL)
    
55. )
    
56. 
    
57. ;;字符串到一维数据表
    
58. (defun str->row(str)(mapcar 'atoi (mapcar 'chr (vl-string->list str))))
    
59. 
    
60. 
    
61. ;;定长分割表函数
    
62. (defun DivLst(lst n / a b)
    
63. (while lst
    
64.         (setq b nil i 0)
    
65.         (while (< i n) (setq b (cons (car lst) b) lst (cdr lst) i (1+ i)))
    
66.         (setq a (cons (reverse b) a))
    
67. )(reverse a)
    
68. )
    
69. 
    
70. 
    
71. ;;*******************************************************
    
72. ;;           数独在CAD中绘制
    
73. ;;*******************************************************
    
74. ;;在CAD中输出九宫格 (sudoku-print lst)
    
75. ;;(setq lst (sudoku-str->row str))
    
76. (defun sudoku-print(lst / dx dy pt0 en)
    
77. (setvar "cmdecho" 0)
    
78. (setvar "peditaccept" 0)
    
79. (setq pt0 (getpoint "\n指定点:"))
    
80. (or pt0 (setq pt0 '(0 0 0)))
    
81. (setq dx 0 dy 0 zx0 (car pt0) zy0 (cadr pt0))
    
82. (command "line" pt0 (polar pt0 0 18) "")
    
83. (setq en (entlast))
    
84. (command "-array" en "" "r" 10 1 -2)
    
85. (line-WPL (line-WPL en))
    
86. (command "line" pt0 (polar pt0 (r2a -90) 18) "")
    
87. (setq en (entlast))
    
88. (command "-array" en "" "r" 1 10 2)
    
89. (line-WPL (line-WPL en))
    
90. (command "zoom" (polar pt0 (r2a 135) 8) (polar pt0 (r2a -45) 34))
    
91. (foreach y lst
    
92.         (foreach x y
    
93.                 (if (/= x 0)(command "text" "j" "mc"
    
94.                         (list (+ (car pt0) (* 2 dx) 1)(- (cadr pt0) (* 2 dy) 1)) "1" "0" (itoa x)))
    
95.                 (setq dx (+ dx 1)))
    
96.         (setq dy (+ dy 1) dx 0)
    
97. )(princ)
    
98. )
    
99. 
    
100. ;;角度到弧度的转换
     
101. (defun R2A(R)(* pi (/ R 180.0)))
     
102. 
     
103. (defun line-WPL(en)
     
104. (setq en (entnext (entnext (entnext en))))
     
105. (command "pedit" en "y" "w" "0.15" "") en
     
106. )
     
107. ;;显示求解出的数字
     
108. (defun dxftxt(str n / a b)
     
109. (setq a (/ n 9) b (- n (* a 9))
     
110.         pt (list (+ 1 zx0 (* b 2))(- zy0 (* a 2) 1) 0))
     
111. (entmake (list '(0 . "TEXT")(cons 1 str)(cons 72 1)(cons 10 pt)(cons 11 pt)
     
112.         (cons 40 1)(cons 62 1)(cons 71 0)(cons 73 2)))
     
113. (command "zoom" (polar (list zx0 zy0) (r2a 135) 8)(polar (list zx0 zy0) (r2a -45) 34))
     
114. )
     

;;*******************************************************<br /> ;;          LISP 数独求解：回溯法（穷举法）<br /> ;;*******************************************************<br /> ;;回溯法主程序<br /> (defun c:sudoku2( / str m x sulsp xSudo)<br /> (setq str "000000980020010000004057010000000506019060340203000000080420100000070030076000000")<br /> ;(setq str "800000000003600000070090200050007000000045700000100030001000068008500010090000400")<br /> (setq m 0 x 1 sulsp (str->row str) xSudo nil)<br /> (sudoku-print (DivLst sulsp 9)) ;;显示题目<br /> (setq *s1* (getvar "date")) ;;计时开始<br /> (while (< m 81)                           ;;测试数独的81个格子，m 为格子指针值为 0-80<br />         (setq hl9g (Cal99 m (updateLst xSudo sulsp)))<br />         (if (zerop (nth m sulsp))(progn       ;;如果m格子里数据为0，则进入循环<br />                 (while (and (<= x 9)(apply 'or (mapcar '(lambda(y)(member x y))hl9g)))(setq x (1+ x)));;合法性<br />                 (if (> x 9)                       ;;当x>9时，显然该回溯了<br />                         (while (>= x 9)<br />                                 (setq x (car xSudo) xSudo (cdr xSudo) ;;数据回溯遇到 9 则继续回溯<br />                                         x (1+ x) m (1- m)) (entdel(entlast))<br />                                 (while (> (nth m sulsp) 0)(setq m (1- m))) ;;指针回溯稍微麻烦，遇到原始数据则需要继续<br />                         )(setq xSudo (cons x xSudo) LJ (dxftxt (itoa x) m) x 1 m (1+ m))   ;;x 归位，m 跳入下一格 <br />                 ))(setq m (1+ m) x 1)   ;;如果下一个格子有数据，即 m 格子数据不为 0，则跳入下一格， x 复位<br />         )<br /> ) (princ (strcat "\n数独回溯法求解耗时 " (rtos (* 86400.0 (- (getvar "date") *s1*)) 2 4) " 秒"))<br /> (princ)<br /> )<br /> <br /> ;;行、列、九宫计算<br /> ;;返回一维表数字 L 中第 n 个数字所在的行、列和九宫数的组合<br /> (defun Cal99(n L / mn mr mc ms k Lr Lc Ls)<br /> (setq k 0 Lr nil Lc nil Ls nil<br />         mn (Calxm n)<br />         mr (car mn)<br />         mc (cadr mn)<br />         ms (caddr mn))<br /> (foreach x L (setq kk (Calxm k) k (1+ k))<br />         (if (= (car kk) mr)(setq Lr (cons x Lr)))    ;;行<br />         (if (= (cadr kk) mc)(setq Lc (cons x Lc)))   ;;列<br />         (if (= (caddr kk) ms)(setq Ls (cons x Ls)))) ;;宫<br /> (list Lr Lc Ls)<br /> )<br /> <br /> ;;返回第 m 个数字在九宫格里的行、列、宫号，均为 0-8<br /> (defun Calxm(m / r c s)<br /> (setq r (/ m 9) c (- m (* r 9)) s (+ (* 3 (/ r 3))(/ c 3)))<br /> (list r c s)<br /> )<br /> <br /> ;;将计算出的数独 L1 与原始数独 L2 合并<br /> (defun updateLst(L1 L2)<br /> (setq xL (reverse L1) NL '())<br /> (foreach x L2 (if (and (= x 0)(car xL))<br />         (setq NL (cons (car xL) NL) xL (cdr xL))<br />         (setq NL (cons x NL))))<br /> (reverse NL)<br /> )<br /> <br /> ;;字符串到一维数据表<br /> (defun str->row(str)(mapcar 'atoi (mapcar 'chr (vl-string->list str))))<br /> <br /> <br /> ;;定长分割表函数<br /> (defun DivLst(lst n / a b)<br /> (while lst<br />         (setq b nil i 0)<br />         (while (< i n) (setq b (cons (car lst) b) lst (cdr lst) i (1+ i)))<br />         (setq a (cons (reverse b) a))<br /> )(reverse a)<br /> )<br /> <br /> <br /> ;;*******************************************************<br /> ;;           数独在CAD中绘制 <br /> ;;*******************************************************<br /> ;;在CAD中输出九宫格 (sudoku-print lst)<br /> ;;(setq lst (sudoku-str->row str))<br /> (defun sudoku-print(lst / dx dy pt0 en)<br /> (setvar "cmdecho" 0)<br /> (setvar "peditaccept" 0)<br /> (setq pt0 (getpoint "\n指定点:"))<br /> (or pt0 (setq pt0 '(0 0 0)))<br /> (setq dx 0 dy 0 zx0 (car pt0) zy0 (cadr pt0))<br /> (command "line" pt0 (polar pt0 0 18) "")<br /> (setq en (entlast))<br /> (command "-array" en "" "r" 10 1 -2)<br /> (line-WPL (line-WPL en))<br /> (command "line" pt0 (polar pt0 (r2a -90) 18) "")<br /> (setq en (entlast))<br /> (command "-array" en "" "r" 1 10 2)<br /> (line-WPL (line-WPL en))<br /> (command "zoom" (polar pt0 (r2a 135) 8) (polar pt0 (r2a -45) 34))<br /> (foreach y lst<br />         (foreach x y<br />                 (if (/= x 0)(command "text" "j" "mc"<br />                         (list (+ (car pt0) (* 2 dx) 1)(- (cadr pt0) (* 2 dy) 1)) "1" "0" (itoa x)))<br />                 (setq dx (+ dx 1)))<br />         (setq dy (+ dy 1) dx 0)<br /> )(princ)<br /> )<br /> <br /> ;;角度到弧度的转换<br /> (defun R2A(R)(* pi (/ R 180.0)))<br /> <br /> (defun line-WPL(en)<br /> (setq en (entnext (entnext (entnext en))))<br /> (command "pedit" en "y" "w" "0.15" "") en<br /> )<br /> ;;显示求解出的数字<br /> (defun dxftxt(str n / a b)<br /> (setq a (/ n 9) b (- n (* a 9))<br />         pt (list (+ 1 zx0 (* b 2))(- zy0 (* a 2) 1) 0))<br /> (entmake (list '(0 . "TEXT")(cons 1 str)(cons 72 1)(cons 10 pt)(cons 11 pt)<br />         (cons 40 1)(cons 62 1)(cons 71 0)(cons 73 2)))<br /> (command "zoom" (polar (list zx0 zy0) (r2a 135) 8)(polar (list zx0 zy0) (r2a -45) 34))<br /> )<br />

xyp1964

先来看看效果：

xyp1964

1. ;; suduku-str->row 字符串转行表
   
2. ;; (suduku-str->row "000000980020010000004057010000000506019060340203000000080420100000070030076000000")
   
3. (defun suduku-str->row (str) (if (= (strlen str) 81) (xyp-List-Div (xyp-Str2List str) 9)))
   
4. 
   
5. ;; suduku-row->col 行表转列表
   
6. (defun suduku-row->col (lst-row) (xyp-List-Reverse lst-row))
   
7. 
   
8. ;; suduku-row->9gg 行表转宫表
   
9. (defun suduku-row->9gg (lst-row / lst-9gg)
   
10.   (setq        lst-9gg        (mapcar '(lambda (x) (xyp-List-Div x 3)) lst-row)
    
11.         lst-9gg        (xyp-List-Div lst-9gg 3)
    
12.         lst-9gg        (mapcar 'xyp-List-Reverse lst-9gg)
    
13.         lst-9gg        (apply 'append lst-9gg)
    
14.         lst-9gg        (mapcar '(lambda (x) (apply 'append x)) lst-9gg)
    
15.   )
    
16. )
    
17. 
    
18. ;; suduku-9gg->row 宫表转行表
    
19. (defun suduku-9gg->row (lst / lst1 x y)
    
20.   (setq        lst1 (xyp-List-Div lst 3)
    
21.         lst1 (mapcar '(lambda (x)
    
22.                         (xyp-List-Reverse (mapcar '(lambda (y) (xyp-List-Div y 3)) x))
    
23.                       )
    
24.                      lst1
    
25.              )
    
26.         lst1 (apply 'append lst1)
    
27.         lst1 (mapcar '(lambda (x) (apply 'append x)) lst1)
    
28.   )
    
29. )
    

;; suduku-str->row 字符串转行表<br /> ;; (suduku-str->row "000000980020010000004057010000000506019060340203000000080420100000070030076000000")<br /> (defun suduku-str->row (str) (if (= (strlen str) 81) (xyp-List-Div (xyp-Str2List str) 9)))<br /> <br /> ;; suduku-row->col 行表转列表<br /> (defun suduku-row->col (lst-row) (xyp-List-Reverse lst-row))<br /> <br /> ;; suduku-row->9gg 行表转宫表<br /> (defun suduku-row->9gg (lst-row / lst-9gg)<br />   (setq        lst-9gg        (mapcar '(lambda (x) (xyp-List-Div x 3)) lst-row)<br />         lst-9gg        (xyp-List-Div lst-9gg 3)<br />         lst-9gg        (mapcar 'xyp-List-Reverse lst-9gg)<br />         lst-9gg        (apply 'append lst-9gg)<br />         lst-9gg        (mapcar '(lambda (x) (apply 'append x)) lst-9gg)<br />   )<br /> )<br /> <br /> ;; suduku-9gg->row 宫表转行表<br /> (defun suduku-9gg->row (lst / lst1 x y)<br />   (setq        lst1 (xyp-List-Div lst 3)<br />         lst1 (mapcar '(lambda (x)<br />                         (xyp-List-Reverse (mapcar '(lambda (y) (xyp-List-Div y 3)) x))<br />                       )<br />                      lst1<br />              )<br />         lst1 (apply 'append lst1)<br />         lst1 (mapcar '(lambda (x) (apply 'append x)) lst1)<br />   )<br /> )<br />

pengfei2010

不错，不错，玩出了花样

panliang9

厉害、非常厉害！

mikewolf2k

请问算法是什么？以前vba做过的是笨方法，一个个去试，试到合格为止。

cq_qg

关键是算法

半夜星星

好玩法，代码用的什么编译器啊，我的发上来不是这样的格式，还要调格式的