【e派】数独——LSP求解
本帖最后由 xyp1964 于 2018-3-27 07:40 编辑数独的布局分为行、列和宫三类，利用LSP的表处理强项，实现数独求解也许可以练练手……
81码数字字符串：
000000980020010000004057010000000506019060340203000000080420100000070030076000000
起始布局如下：
有兴趣的可以来讨论讨论。
本帖最后由 yxp 于 2018-3-30 00:02 编辑
最近经常开会无聊的时候就玩玩数独，顺手查了一下数独的相关知识。
终盘数量:
数独中的数字排列千变万化，那么究竟有多少种终盘的数字组合呢？
答案是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函数也不是很麻烦，关键是求解数独的算法。
;; sudoku-str->row 字符串转行表，传入参数 str
;;(setq str "000000980020010000004057010000000506019060340203000000080420100000070030076000000")
(defun sudoku-str->row(str)(DivLst (mapcar 'atoi (mapcar 'chr (vl-string->list str))) 9))
;; sudoku-row->col 行表转列表，传入参数 lst
;;(setq lst (sudoku-str->row str))
(defun sudoku-row->col (lst / NL S N)
(while (car lst)
(foreach x lst (setq S (cons (car x) S) N (cons (cdr x) N)))
(setq lst (reverse N) NL (cons (reverse S) NL) S nil N nil)
)(reverse NL)
)
;; sudoku-row->9gg 行表转宫表，传入参数 lst
;;(setq lst (sudoku-str->row str))
(defun sudoku-row->9gg(lst / SN)
(foreach x (sudoku-row->col (mapcar '(lambda (x)(DivLst x 3)) lst))
(setq SN (cons (DivLst (apply 'append x) 9) SN)))
(apply 'append (reverse SN))
)
;;定长分割表函数
(defun DivLst(lst n / a b)
(while lst
(setq b nil i 0)
(while (< i n) (setq b (cons (car lst) b) lst (cdr lst) i (1+ i)))
(setq a (cons (reverse b) a))
)(reverse a)
)
本帖最后由 yxp 于 2018-4-1 14:47 编辑
回溯法
一、在第一个格子填上1，检查行、列和九宫格是否合法。如果合法，跳入下一个格子，从1开始测试；如果不合法，则继续测试2、 3......
二、如果下一个格子1-9都测试完了，全部不合法，说明上一个格子填错了，则回溯到上一步，继续测试2、 3......所有格子测试的数字只有1-9，所以不存在死循环的问题。
;;*******************************************************
;; LISP 数独求解：回溯法（穷举法）
;;*******************************************************
;;回溯法主程序
(defun c:sudoku2( / str m x sulsp xSudo)
(setq str "000000980020010000004057010000000506019060340203000000080420100000070030076000000")
;(setq str "800000000003600000070090200050007000000045700000100030001000068008500010090000400")
(setq m 0 x 1 sulsp (str->row str) xSudo nil)
(sudoku-print (DivLst sulsp 9)) ;;显示题目
(setq *s1* (getvar "date")) ;;计时开始
(while (< m 81) ;;测试数独的81个格子，m 为格子指针值为 0-80
(setq hl9g (Cal99 m (updateLst xSudo sulsp)))
(if (zerop (nth m sulsp))(progn ;;如果m格子里数据为0，则进入循环
(while (and (<= x 9)(apply 'or (mapcar '(lambda(y)(member x y))hl9g)))(setq x (1+ x)));;合法性
(if (> x 9) ;;当x>9时，显然该回溯了
(while (>= x 9)
(setq x (car xSudo) xSudo (cdr xSudo) ;;数据回溯遇到 9 则继续回溯
x (1+ x) m (1- m)) (entdel(entlast))
(while (> (nth m sulsp) 0)(setq m (1- m))) ;;指针回溯稍微麻烦，遇到原始数据则需要继续
)(setq xSudo (cons x xSudo) LJ (dxftxt (itoa x) m) x 1 m (1+ m)) ;;x 归位，m 跳入下一格
))(setq m (1+ m) x 1) ;;如果下一个格子有数据，即 m 格子数据不为 0，则跳入下一格， x 复位
)
) (princ (strcat "\n数独回溯法求解耗时 " (rtos (* 86400.0 (- (getvar "date") *s1*)) 2 4) " 秒"))
(princ)
)
;;行、列、九宫计算
;;返回一维表数字 L 中第 n 个数字所在的行、列和九宫数的组合
(defun Cal99(n L / mn mr mc ms k Lr Lc Ls)
(setq k 0 Lr nil Lc nil Ls nil
mn (Calxm n)
mr (car mn)
mc (cadr mn)
ms (caddr mn))
(foreach x L (setq kk (Calxm k) k (1+ k))
(if (= (car kk) mr)(setq Lr (cons x Lr))) ;;行
(if (= (cadr kk) mc)(setq Lc (cons x Lc))) ;;列
(if (= (caddr kk) ms)(setq Ls (cons x Ls)))) ;;宫
(list Lr Lc Ls)
)
;;返回第 m 个数字在九宫格里的行、列、宫号，均为 0-8
(defun Calxm(m / r c s)
(setq r (/ m 9) c (- m (* r 9)) s (+ (* 3 (/ r 3))(/ c 3)))
(list r c s)
)
;;将计算出的数独 L1 与原始数独 L2 合并
(defun updateLst(L1 L2)
(setq xL (reverse L1) NL '())
(foreach x L2 (if (and (= x 0)(car xL))
(setq NL (cons (car xL) NL) xL (cdr xL))
(setq NL (cons x NL))))
(reverse NL)
)
;;字符串到一维数据表
(defun str->row(str)(mapcar 'atoi (mapcar 'chr (vl-string->list str))))
;;定长分割表函数
(defun DivLst(lst n / a b)
(while lst
(setq b nil i 0)
(while (< i n) (setq b (cons (car lst) b) lst (cdr lst) i (1+ i)))
(setq a (cons (reverse b) a))
)(reverse a)
)
;;*******************************************************
;; 数独在CAD中绘制
;;*******************************************************
;;在CAD中输出九宫格 (sudoku-print lst)
;;(setq lst (sudoku-str->row str))
(defun sudoku-print(lst / dx dy pt0 en)
(setvar "cmdecho" 0)
(setvar "peditaccept" 0)
(setq pt0 (getpoint "\n指定点:"))
(or pt0 (setq pt0 '(0 0 0)))
(setq dx 0 dy 0 zx0 (car pt0) zy0 (cadr pt0))
(command "line" pt0 (polar pt0 0 18) "")
(setq en (entlast))
(command "-array" en "" "r" 10 1 -2)
(line-WPL (line-WPL en))
(command "line" pt0 (polar pt0 (r2a -90) 18) "")
(setq en (entlast))
(command "-array" en "" "r" 1 10 2)
(line-WPL (line-WPL en))
(command "zoom" (polar pt0 (r2a 135) 8) (polar pt0 (r2a -45) 34))
(foreach y lst
(foreach x y
(if (/= x 0)(command "text" "j" "mc"
(list (+ (car pt0) (* 2 dx) 1)(- (cadr pt0) (* 2 dy) 1)) "1" "0" (itoa x)))
(setq dx (+ dx 1)))
(setq dy (+ dy 1) dx 0)
)(princ)
)
;;角度到弧度的转换
(defun R2A(R)(* pi (/ R 180.0)))
(defun line-WPL(en)
(setq en (entnext (entnext (entnext en))))
(command "pedit" en "y" "w" "0.15" "") en
)
;;显示求解出的数字
(defun dxftxt(str n / a b)
(setq a (/ n 9) b (- n (* a 9))
pt (list (+ 1 zx0 (* b 2))(- zy0 (* a 2) 1) 0))
(entmake (list '(0 . "TEXT")(cons 1 str)(cons 72 1)(cons 10 pt)(cons 11 pt)
(cons 40 1)(cons 62 1)(cons 71 0)(cons 73 2)))
(command "zoom" (polar (list zx0 zy0) (r2a 135) 8)(polar (list zx0 zy0) (r2a -45) 34))
)
先来看看效果：
;; suduku-str->row 字符串转行表
;; (suduku-str->row "000000980020010000004057010000000506019060340203000000080420100000070030076000000")
(defun suduku-str->row (str) (if (= (strlen str) 81) (xyp-List-Div (xyp-Str2List str) 9)))
;; suduku-row->col 行表转列表
(defun suduku-row->col (lst-row) (xyp-List-Reverse lst-row))
;; suduku-row->9gg 行表转宫表
(defun suduku-row->9gg (lst-row / lst-9gg)
(setq lst-9gg (mapcar '(lambda (x) (xyp-List-Div x 3)) lst-row)
lst-9gg (xyp-List-Div lst-9gg 3)
lst-9gg (mapcar 'xyp-List-Reverse lst-9gg)
lst-9gg (apply 'append lst-9gg)
lst-9gg (mapcar '(lambda (x) (apply 'append x)) lst-9gg)
)
)
;; suduku-9gg->row 宫表转行表
(defun suduku-9gg->row (lst / lst1 x y)
(setq lst1 (xyp-List-Div lst 3)
lst1 (mapcar '(lambda (x)
(xyp-List-Reverse (mapcar '(lambda (y) (xyp-List-Div y 3)) x))
)
lst1
)
lst1 (apply 'append lst1)
lst1 (mapcar '(lambda (x) (apply 'append x)) lst1)
)
)
不错，不错，玩出了花样 厉害、非常厉害！ 请问算法是什么？以前vba做过的是笨方法，一个个去试，试到合格为止。 关键是算法 好玩法，代码用的什么编译器啊，我的发上来不是这样的格式，还要调格式的