lisp 程式碼示例

非原創，抄來的：

!article/FuncProgram/2185



剛學lisp不久：）有些地方還不是很清楚，所以用了比較笨的辦法，還請大家多多指教
//bow
  
;; s 開始狀態
;; 結束狀態集
;; rules 規則集
;; delta 轉移函式
  
;; search.lisp
;; 22 March 2004
  
(defpackage search-base
   (:export BFS DFS)
   (:use common-lisp))
(in-package search-base)
  
(defvar finish-status '()
   "The finished status set")
(defvar rules-set '())
(defvar expand-func #'(lambda () ()))
(defvar update-open-lst #'(lambda () ()))
  
(defun search-init (K rules delta lstop)
   "initialize the global values used by search base"
   (setq finish-status K)
   (setq rules-set rules)
   (setq expand-func delta)
   (setq update-open-lst lstop)
   t)
  
(defun search-start (open closed)
   (let ((q (first open))
         (seq (rest open)))
     (cond ((null open) nil)
           ((find q finish-status :test 'equal) (list seq (cons q closed)))
           (t (search-start (funcall
                             update-open-lst
                             seq
                             (expand-vertex q rules-set expand-func (cons q closed))
                             )
                            (cons q closed))))))
  
;; s 開始狀態
;; 結束狀態集
;; rules 規則集
;; delta 轉移函式
  
;; 寬度優先
(defun BFS (s K rules delta)
   "Breadth first search"
   (let ((lstop #'(lambda (lst1 lst2)
                    (append lst1 lst2)))
         )
     (search-init K rules delta lstop)
     (search-start (list s) nil)))
  
;; 深度優先
(defun DFS (s K rules delta)
   "Deep first search"
   (let ((lstop #'(lambda (lst1 lst2)
                   (append lst2 lst1)))
         )
     (search-init K rules delta lstop)
     (search-start (list s) nil)))
  
(defun expand-vertex (vertex rules delta closed)
   (let ((lst (mapcar
               #'(lambda (r)
                   (let ((v (funcall delta vertex r))
                         )
                     (cond ((find v closed :test 'equal) nil)
                           (t v))))
               rules))
         )
     (remove nil lst)))
  
(defun test-delta (v r)
   (+ v r))
  
;; 下面是用分水問題來作測試
;; water.lisp
  
(load "search")
  
(defvar rules '(
               (0 1)
               (0 2)
               (1 0)
               (1 2)
               (2 0)
               (2 1)
               ))
  
(defvar limits '(8 5 3))
(defvar start '(8 0 0))
(defvar finish '(
                (4 4 0)
                ))
  
(defun index(lst idx)
   (cond ((equal idx 0) (car lst))
         (t (index (cdr lst) (1- idx)))))
  
(defun setidx-base(lst idx val ret)
   (let ((first-lst (car lst))
         (rest-lst (cdr lst))
         )
     (cond ((eql 0 idx) (append ret (cons val rest-lst)))
           (t (setidx-base
               rest-lst
               (1- idx)
               val
               (append ret (list first-lst)))))))
  
(defun setidx(lst idx val)
   (setidx-base lst idx val nil))
  
(defun pour-water (q src dst)
   (let* ((src-wt (index q src))
          (dst-wt (index q dst))
          (empty (- (index limits dst) dst-wt))
          )
     (cond ((equal 0 src-wt) q)
           ((> src-wt empty)
            (let* ((new (setidx q src (- src-wt empty)))
                   (new (setidx new dst (index limits dst)))
                   )
              new))
           (t (let* ((new (setidx q src 0))
                     (new (setidx new dst (+ src-wt dst-wt)))
                     )
                new)))))
  
(defun pour (q r)
   (pour-water q (first r) (second r)))
  
(print (search-base:DFS start finish rules 'pour))
  
(quit)
--
(defun power-set (set)
   (if (null set) '(())
     (let ((pset-of-rest (power-set (cdr set))))
       (append
       (mapcar #'(lambda (subset) (cons (car set) subset))  
               pset-of-rest) pset-of-rest))))