;apl version 1.2 （单人跳棋游戏 version 2.4 从2.2版开始改名为APL） 2014/5/23
;使用多进程，进程数不限。
;这个版本还需改进，尤其是进程管理器apl1.1-jc。
;使用jc-num个进程进行计算，即，程序同时在“下”n盘棋，比如jc-num为2，则创建两个进程，两盘棋，下完第1盘的第一步后立即下第二盘的
;第一步，然后再接着下第一盘的第二步，接着是第二盘的第二部...若其中一盘无解，则立即开启另一局，而这并不影响那盘还未下完的，
;如第一盘无解，则另开一盘，而这时第二盘可能已经下到第15步，那么，第一盘下第一步，第二盘下第16步...，始终保持同时下两局棋，
;直到找到解或者下棋的盘数达到要求。但是因为实质上使用的是随机路径搜索算法，所以，多进程并不会使计算速度明显加快，尤其是在进程数
;达到了一个限度之后，默认值为24。这与我的计算机性能有关，为:CPU 1.8G 双核。
;优化了下代码。可能优化的有错误，导致该版本不太稳定了，但是速度明显变快了。优化的地方为zf1、zf-t、zf-n。
;添加个了随机生成棋局的功能，函数xinqiju，它不保证生成的棋局一定有解。
;在棋局为7*7（棋盘大小）时解题时间在1分钟之内，更大的时候没有实用性。
;单人跳棋游戏比五子棋这样的游戏写起来难度要大很多。
;这个版本中的apl1.1-jc和jc-x都需要继续改进。
;较上一版本有多处改进。
;c-s打头的都是测试用例。例：(nil 1 3)表示棋盘上该坐标表示的位置上没有棋子。(t 1 4)表示棋盘上该坐标所表示的位置上有棋子。
(defvar c-s '((t 1 1) (t 2 1) (t 3 1) (t 4 1) (t 1 2) (t 2 2) (t 3 2) (nil 1 3) (t 2 3) (t 1 4)) "最简单的布局")
(defvar c-s1 '((t 1 1) (t 2 1) (t 3 1) (t 4 1) (t 1 2) (t 2 2) (t 3 2) (nil 1 3) (t 2 3) (t 1 4)
(t 2 4) (t 3 4) (t 4 4)(t 3 3)(t 4 3)(t 4 2)) "4*4的棋盘")
(defvar c-s2 '((NIL 2 0) (NIL 2 4) (NIL 2 3) (T 0 0) (T 1 0) (T 3 0) (T 4 0) (T 0 1) (T 1 1) (T 2 1) (T 3 1) (T 4 1) (T 0 2)
(T 1 2) (T 2 2) (T 3 2) (T 4 2) (T 0 3) (T 1 3) (T 3 3) (T 4 3) (T 0 4) (T 1 4) (T 3 4) (T 4 4)) "5*5")
(defvar c-s3 '((NIL 0 2) (NIL 5 5) (NIL 4 2) (NIL 1 0) (T 0 0) (T 2 0) (T 3 0) (T 4 0) (T 5 0) (T 0 1) (T 1 1) (T 2 1)
(T 3 1) (T 4 1) (T 5 1) (T 1 2) (T 2 2) (T 3 2) (T 5 2) (T 0 3) (T 1 3) (T 2 3) (T 3 3) (T 4 3) (T 5 3)
(T 0 4) (T 1 4) (T 2 4) (T 3 4) (T 4 4) (T 5 4) (T 0 5) (T 1 5) (T 2 5) (T 3 5) (T 4 5)) "6*6")
(defvar c-s4 '((NIL 4 0) (NIL 0 1) (NIL 1 4) (NIL 0 2) (NIL 0 5) (T 0 0) (T 1 0) (T 2 0) (T 3 0) (T 5 0) (T 1 1) (T 2 1)
(T 3 1) (T 4 1) (T 5 1) (T 1 2) (T 2 2) (T 3 2) (T 4 2) (T 5 2) (T 0 3) (T 1 3) (T 2 3) (T 3 3) (T 4 3) (T 5 3)
(T 0 4) (T 2 4) (T 3 4) (T 4 4) (T 5 4) (T 1 5) (T 2 5) (T 3 5) (T 4 5) (T 5 5) (T 0 6) (T 1 6) (T 2 6) (T 3 6)
(T 4 6) (T 5 6)) "6*7")
(defvar c-s5 '((NIL 6 3) (NIL 0 4) (NIL 2 2) (NIL 3 4) (NIL 4 0) (T 0 0) (T 1 0) (T 2 0) (T 3 0) (T 5 0) (T 6 0) (T 0 1)
(T 1 1) (T 2 1) (T 3 1) (T 4 1) (T 5 1) (T 6 1) (T 0 2) (T 1 2) (T 3 2) (T 4 2) (T 5 2) (T 6 2) (T 0 3) (T 1 3)
(T 2 3) (T 3 3) (T 4 3) (T 5 3) (T 1 4) (T 2 4) (T 4 4) (T 5 4) (T 6 4) (T 0 5) (T 1 5) (T 2 5) (T 3 5) (T 4 5)
(T 5 5) (T 6 5) (T 0 6) (T 1 6) (T 2 6) (T 3 6) (T 4 6) (T 5 6) (T 6 6)) "7*7")
;-------------------------------------------------------------------------------------------------------------------------------
(setf *print-pretty* t)
(defun qipan (heng zong) "生成一个heng*zong的棋盘。"
(let (b1)
(dotimes (h heng (reverse b1))
(dotimes (z zong)
(push `(t ,z ,h) b1)))))
(defun xinqiju (&key (gao-h 6) (gao-z 7)) "产生一个新棋局，但不保证棋局有解。"
(let* ((b1 (qipan gao-h gao-z))
(b2 (length b1))
(b3 (ceiling b2 10))
(b5 (copy-list b1))
b4)
(do ((a1 (nth (random b2) b1)
(nth (random b2) b1)))
((= b3 0))
(if (not (find a1 b4 :test #'equal))
(progn
(decf b3)
(push a1 b4)
(setf b5 (delete a1 b5 :test #'equal))))) (setf b2 nil)
(dolist (x b4)
(push (funcall #'(lambda (lst) (pop lst) (push nil lst)) x) b2))
(append b2 b5)))
(defun zf1 (qiju)
"qiju是棋局,该函数返回每个棋子的所有的可以走的走法。若任何棋子都不能走，则返回nil.
返回的形式为((t 1 2) (t 2 3) (nil 3 4)),表示(t 1 2) 经过(t 2 3)落子到(nil 3 4).如果有多个
可走的步法，则(((t 1 2) (t 2 3)(nil 3 4)) ((t 5 6)(t 5 7)(nil 7 8)) ...)."
(let (value-t value-nil value-rel)
(dolist (zuobiao qiju)
(if (car zuobiao) (push zuobiao value-t)(push zuobiao value-nil)))
(if (< (length value-t) (length value-nil))
(zf-t value-t value-nil value-rel)
(zf-n value-t value-nil value-rel))))
(defun zf-t (value-t value-nil value-rel) "棋子数大于空位数时使用该函数。"
(dolist (b1 value-t value-rel)
(let ((x (second b1)) (y (third b1)))
(if (and (find `(t ,(- x 1) ,y) value-t :test #'equal) (find `(nil ,(- x 2) ,y) value-nil :test #'equal))
(push `((t ,x ,y) (t ,(- x 1) ,y)(nil ,(- x 2) ,y)) value-rel))
(if (and (find `(t ,(+ x 1) ,y) value-t :test #'equal) (find `(nil ,(+ x 2) ,y) value-nil :test #'equal))
(push `((t ,x ,y) (t ,(+ x 1) ,y) (nil ,(+ x 2) ,y)) value-rel))
(if (and (find `(t ,x ,(+ y 1)) value-t :test #'equal) (find `(nil ,x ,(+ y 2)) value-nil :test #'equal))
(push `((t ,x ,y) (t ,x ,(+ y 1)) (nil ,x ,(+ y 2))) value-rel))
(if (and (find `(t ,x ,(- y 1)) value-t :test #'equal) (find `(nil ,x ,(- y 2)) value-nil :test #'equal))
(push `((t ,x ,y)(t ,x ,(- y 1)) (nil ,x ,(- y 2))) value-rel))
(if (and (find `(t ,(- x 1) ,(+ y 1)) value-t :test #'equal) (find `(nil ,(- x 2) ,(+ y 2)) value-nil :test #'equal))
(push `((t ,x ,y) (t ,(- x 1) ,(+ y 1))(nil ,(- x 2) ,(+ y 2))) value-rel))
(if (and (find `(t ,(+ x 1) ,(+ y 1)) value-t :test #'equal) (find `(nil ,(+ x 2) ,(+ y 2)) value-nil :test #'equal))
(push `((t ,x ,y) (t ,(+ x 1) ,(+ y 1))(nil ,(+ x 2) ,(+ y 2))) value-rel))
(if (and (find `(t ,(+ x 1) ,(- y 1)) value-t :test #'equal)(find `(nil ,(+ x 2) ,(- y 2)) value-nil :test #'equal))
(push `((t ,x ,y)(t ,(+ x 1) ,(- y 1)) (nil ,(+ x 2) ,(- y 2))) value-rel))
(if (and (find `(t ,(- x 1) ,(- y 1)) value-t :test #'equal)(find `(nil ,(- x 2) ,(- y 2)) value-nil :test #'equal))
(push `((t ,x ,y) (t ,(- x 1) ,(- y 1))(nil ,(- x 2) ,(- y 2))) value-rel)))))
(defun zf-n (value-t value-nil value-rel) "空位数大于棋子数时使用该函数。"
(dolist (b1 value-nil value-rel)
(let ((x (second b1)) (y (third b1)))
(if (and (find `(t ,(- x 1) ,y) value-t :test #'equal) (find `(t ,(- x 2) ,y) value-t :test #'equal))
(push `((t ,(- x 2) ,y) (t ,(- x 1) ,y) ,b1) value-rel))
(if (and (find `(t ,(+ x 1) ,y) value-t :test #'equal) (find `(t ,(+ x 2) ,y) value-t :test #'equal))
(push `((t ,(+ x 2) ,y) (t ,(+ x 1) ,y) ,b1) value-rel))
(if (and (find `(t ,x ,(+ y 1)) value-t :test #'equal) (find `(t ,x ,(+ y 2)) value-t :test #'equal))
(push `((t ,x ,(+ y 2)) (t ,x ,(+ y 1)) ,b1) value-rel))
(if (and (find `(t ,x ,(- y 1)) value-t :test #'equal) (find `(t ,x ,(- y 2)) value-t :test #'equal))
(push `((t ,x ,(- y 2)) (t ,x ,(- y 1)) ,b1) value-rel))
(if (and (find `(t ,(- x 1) ,(+ y 1)) value-t :test #'equal) (find `(t ,(- x 2) ,(+ y 2)) value-t :test #'equal))
(push `((t ,(- x 2) ,(+ y 2)) (t ,(- x 1) ,(+ y 1)) ,b1) value-rel))
(if (and (find `(t ,(+ x 1) ,(+ y 1)) value-t :test #'equal) (find `(t ,(+ x 2) ,(+ y 2)) value-t :test #'equal))
(push `((t ,(+ x 2) ,(+ y 2)) (t ,(+ x 1) ,(+ y 1)) ,b1) value-rel))
(if (and (find `(t ,(+ x 1) ,(- y 1)) value-t :test #'equal)(find `(t ,(+ x 2) ,(- y 2)) value-t :test #'equal))
(push `((t ,(+ x 2) ,(- y 2)) (t ,(+ x 1) ,(- y 1)) ,b1) value-rel))
(if (and (find `(t ,(- x 1) ,(- y 1)) value-t :test #'equal)(find `(t ,(- x 2) ,(- y 2)) value-t :test #'equal))
(push `((t ,(- x 2) ,(- y 2)) (t ,(- x 1) ,(- y 1)) ,b1) value-rel)))))
(defun over-num1 (qiju)
"数子，看看棋局中还有多少个棋子。当返回值大于1时，表明该棋局这个走法无解。若为1则返回T否则返回nil。"
(if (= 1 (count-if #'(lambda (zuobiao) (car zuobiao)) qiju)) t nil))
(defun sa2 (zoubu qiju)
"返回在棋局(qiju)上走步(zoubu)后的棋局，一个列表，qiju的复制品被改变后的效果。
比如：(sa2 '((t 1 2) (t 3 4)(nil 5 6)) qiju),返回一个列表，是个棋局；
该返回的列表中的元素被改为((nil 1 2) (nil 3 4)(t 5 6))."
(let*((x0 qiju)
(x4 #'(lambda (x) (if (car x) (progn (pop x) (push nil x)) (progn (pop x) (push t x)))))
(x3 (funcall x4 (third zoubu)))
(x2 (funcall x4 (second zoubu)))
(x1 (funcall x4 (car zoubu))))
(if (delete (third zoubu) x0 :test #'equal) (push x3 x0))
(if (delete (second zoubu) x0 :test #'equal) (push x2 x0))
(if (delete (car zoubu) x0 :test #'equal) (push x1 x0))
x0))
(defun random-10z-26z-zm-seq (n)"新版，产生一个长度为n的字串，其元素为随机的字母或数字。首元素为字母。"
(do* ((b "qwertyuioplkjhgfdsazxcvbnm0123456789")
(b1 (make-array n :fill-pointer t :element-type 'character))
(b2 0 (incf b2))
(b3 (progn (setf (char b1 b2) (char (subseq b 0 26) (random 26 (make-random-state t)))) b1)
(progn (setf (char b1 b2) (char b (random 36 (make-random-state t)))) b1)))
((= b2 (1- n)) b3)))
(defun jc-x (n) "产生n个进程。"
(let (jc-list par (name-1 (random-10z-26z-zm-seq 5)))
(dotimes (x n (setf par (reverse par)))
(push (read-from-string (concatenate 'string name-1 (format nil"~A" x))) par))
(dolist (x par)
(push `(defun ,x (qiju lujinglist)
(declare (special panshu))
(let ((zoufalist (zf1 qiju)) zoufa)
(if zoufalist
(progn
(setf zoufa (nth (random (length zoufalist) (make-random-state t)) zoufalist))
(setf qiju (sa2 zoufa qiju))
(push zoufa lujinglist))
(if (over-num1 qiju)
(unwind-protect
(throw 'value-over (reverse lujinglist))
(format t "zai di ~A pan shi zhao dao jie.~%" panshu))
(return-from ,x nil))))
(list qiju lujinglist)) jc-list))
(setf jc-list (reverse (push `(quote ,par) jc-list)))
(push 'progn jc-list)
(eval jc-list)))
;jc-num不可为变量，默认为24。qiju不可为词法变量。
;参数jibie为程序的"智力"等级,其值为正整数，默认为2。
(defmacro apl1.1-jc (qiju &optional (jibie 2) (jc-num 24)) "进程管理器：创建、kill、控制进程执行顺序等。"
(let ((hsnamelist (jc-x jc-num)))
(let (a1 a2 a3 a4 let-list do-list z-t jc-qiju lujing-list doparlist )
(dotimes (x (length hsnamelist))
(progn
(setf a1 `(,(gensym) (copy-list ,qiju)))
(push (car a1) jc-qiju)
(push a1 a2))
(progn
(setf a3 `(,(gensym) '(,(1+ x) jincheng=)))
(push (Car a3) lujing-list)
(push a3 a4)))
(setf let-list (append a2 a4))
(do* ((x 0 (incf x))
(b1 (nth x jc-qiju) (nth x jc-qiju))
(b2 (nth x lujing-list) (nth x lujing-list))
(p-d nil nil))
((= x (length hsnamelist)) doparlist)
(push b2 p-d)
(push b1 p-d)
(push p-d doparlist))
(do* ((x 0 (incf x))
(b3 nil nil)
(b1 (nth x hsnamelist) (nth x hsnamelist))
(b2 (nth x doparlist) (nth x doparlist)))
((= x (length hsnamelist)) do-list)
(push b1 b2)
(push b2 b3)
(push b2 b3)
(push (gensym) b3)
(push b3 do-list))
(do* (z-do-b z2 z-qiju z-lujing z-lujing-v
(x 0 (incf x))
(b1 (nth x do-list) (nth x do-list)))
((= x (length hsnamelist)) z-t)
(progn (setf z-do-b (car b1)) (setf z2 (cadr b1)) (setf z-qiju (second z2)) (setf z-lujing (third z2)))
(dolist (y a4)
(if (equal (car y) z-lujing)
(setf z-lujing-v (cadr y))))
(push `(if (not ,z-do-b)
(progn
(setf ,z-qiju (copy-list ,qiju))
(setf ,z-lujing ,z-lujing-v)
(incf panshu))
(progn
(setf ,z-qiju (car ,z-do-b))
(setf ,z-lujing (second ,z-do-b))))
z-t))
`(catch 'value-over
(let ((jishu 0) (x (expt ,jibie 20)) (panshu ,jc-num))
(declare (special panshu))
(let ,let-list
(do ,do-list nil
(if (= jishu x)
(throw 'value-over "ke neng wu jie .")
(incf jishu))
,@z-t)))))))

居然发了78次才发出来。。。
这个比上一个版本多了一些东西，但是速度明显降下来了，郁闷啊。
如果没有重大改进，我将不再更新它，若有喜欢的吧友想改进它那就改吧。

我之所以到现在才发出文字版，实在是因为我犯了个错误，我以为把它发成图片格式后，只要是吧友把图片下载到本地就可以看了，我刚试了一下，发现是看不清的。。。抱歉。。。
而且这个的文字量比较大，要用文字把它发出来那得等到网络好的时候才行。

哦，还要说一句，这个你只要把它复制下来，存成.lisp格式后，在lispbox07中用load加载就可以用了，在ccl1.6中通过。

额，再废话一句，上一次我说会在爱问资料恢复运行后把该游戏的代码发在上面的，但是既然已经能够发上来了，那么我就不再发到那里了。

不明觉厉