【PAIP】6 Building Software Tools (その3)

• 6.3 A Rule-Based Translator Tool
  
• ここはあっさり。
  
  
• 6.4 A Set of Searching Tools
  
• prependって、先頭にくっつけるって意味なんだ。手元の英和辞書に出てなかった。
  
• あとはコードとコメントで。「日本語のコメントと#+test」以外はNorvig。
  

  
  ;;; 6.4 A Set of searching tools
  
  (defun tree-search (states goal-p successors combiner)
    "Find a state that satisfies goal-p.  Start with states,
    and search according to successors and combiner."
    (dbg :search "~&:: Search: ~a" states)
    (cond ((null states) fail)  ; =1=
   ((funcall goal-p (first states)) (first states)) ; =2=
   (t (tree-search   ; =3=
       (funcall combiner  ; =4=
         (funcall successors (first states))
         (rest states)) ; =5=
       goal-p successors combiner))))
  ;; =1= : statesが空ならfail。
  ;; =2= : (first states)がゴールなら終了。
  ;; =3= : 再帰。
  ;; =4= : 次に探索すべきstates作り。given combinerが作る。
  ;; =5= : (first states)の後続と(rest states)が引数。
  
  
  (defun depth-first-search (start goal-p successors)
    "Search new states first until goal is reached."
    (tree-search (list start) goal-p successors #'append))
  ;; combinerが#'appendなので、
  ;; tree-searchの再帰におけるstatesは、
  ;; (funcall successors (first states)) (rest states)
  ;; の順になる。なので、(first states)の後続をどんどん
  ;; 進んでいく。ゆえにdepth-first。
  
  
  (defun binary-tree (x) (list (* 2 x) (+ 1 (* 2 x))))
  ;; 動きを理解する。
  ;; 入力 -> 出力
  ;; 1 -> (2 3)
  ;; 2 -> (4 5)
  ;; 3 -> (6 7)
  ;; 4 -> (8 9)
  ;; 5 -> (10 11)
  ;; テスト用のきれいなbinary treeだな。
  
  (defun is (value) #'(lambda (x) (eql x value)))
  
  #+test
  (my-debug :search)
  #+test
  (depth-first-search 1 (is 12) #'binary-tree)
  
  (defun prepend (x y) "Prepend y to start of x" (append y x))
  
  (defun breadth-first-search (start goal-p successors)
    "Search old states first until goal is reached."
    (tree-search (list start) goal-p successors #'prepend))
  ;; combinerが#'prependなので、
  ;; tree-searchの再帰におけるstatesは、
  ;;  (rest states) (funcall successors (first states))
  ;; の順になる。なので、given statesをひととおりチェック
  ;; してから(first states)の後続の検査となる。ゆえにbreadth-first。
  
  #+test
  (breadth-first-search 1 (is 12) 'binary-tree)
  
  (defun finite-binary-tree (n)
    "Return a successor function that generate a binary tree
    with n nodes."
    #'(lambda (x)
        (remove-if #'(lambda (child) (> child n))
     (binary-tree x))))
  ;; 試して動作を理解する。
  #+test
  (setf fn (finite-binary-tree 3))
  (funcall fn 1)    ; => (2 3)
  (funcall fn 2)    ; => nil
  (setf fn (finite-binary-tree 4))
  (funcall fn 1)    ; => (1 2)
  (funcall fn 2)    ; => (4)
  ;; そうか先のきれいなbinary treeにおいては、
  ;; nodeの値がnode総数と同じだからこれでいいんだ。
  
  (depth-first-search 1 (is 12) (finite-binary-tree 15))
  
  
  ;;; Guiding the Search
  
  (defun diff (num)
    "Return the function that finds the difference from num."
    #'(lambda (x) (abs (- x num))))
  
  (defun sorter (cost-fn)
    "Return a combinator function that sorts according to cost-fn."
    #'(lambda (new old)
        (sort (append new old) #'< :key cost-fn)))
  
  (defun best-first-search (start goal-p successors cost-fn)
    "Search lowest cost states first until goal is reached."
    (tree-search (list start) goal-p successors (sorter cost-fn)))
  
  #+test
  (best-first-search 1 (is 12) #'binary-tree (diff 12))
  
  (defun price-is-right (price)
    "Return a function that measures the difference from price,
    but gives a big peralty for going over price."
    #'(lambda (x) (if (> x price)
        most-positive-fixnum
      (- price x))))
  
  #+test
  (best-first-search 1 (is 12) #'binary-tree (price-is-right 12))
  
  (defun beam-search (start goal-p successors cost-fn beam-width)
    "Search highest scoring states first until goal is reached,
    but never consider more than beam-width states at a time."
    (tree-search (list start) goal-p successors
          #'(lambda (old new)
       (let ((sorted (funcall (sorter cost-fn) old new)))
         (if (> beam-width (length sorted))
      sorted
           (subseq sorted 0 beam-width))))))
  
  #+test
  (beam-search 1 (is 12) #'binary-tree (price-is-right 12) 2)
  
  #+test
  (beam-search 1 (is 12) #'binary-tree (diff 12) 2)
  

  
  

とりあえずここまで。こつこつ。