Ex4.4 The Not Looking after You Don't Leap Problem. その２

ヒントの通りにachieveに引数を追加します。

これをappropriate-opsからappropriate-pまで伝播させます。
appropriate-pでいずれかのprotected-goalが削除される場合、適用出来ない様にします。
achieveはachieve-eachから呼ばれているので、achieve-eachも修正します。

(defun achieve-each (state goals goal-stack)
  "Achieve each goal, and make sure they still hold at the end."
  (let ((current-state state))
    (if (and (every #'(lambda (g)
                        (setf current-state
                              (achieve current-state g (remove g goals) goal-stack)))
                    goals)
             (subsetp goals current-state :test #'equal))
        current-state)))

(defun appropriate-p (goal protected-goals op)
  "An op is appropriate to a goal if it is in its add list."
  (and (member-equal goal (op-add-list op))
       (not (some #'(lambda (protected-goal)
		      (member-equal protected-goal (op-del-list op)))
		  protected-goals))))

(defun appropriate-ops (goal protected-goals state)
  "Return a list of appropriate operators, 
  sorted by the number of unfulfilled preconditions."
  (sort (copy-list (find-all goal *ops*
			     :test #'(lambda (goal op)
				       (appropriate-p goal protected-goals op))))  #'<
        :key #'(lambda (op) 
                 (count-if #'(lambda (precond)
                               (not (member-equal precond state)))
                           (op-preconds op)))))

(defun achieve (state goal protected-goals goal-stack)
  "A goal is achieved if it already holds,
  or if there is an appropriate op for it that is applicable."
  (dbg-indent :gps (length goal-stack) "Goal: ~a (~a)" goal protected-goals)
  (cond ((member-equal goal state) state)
        ((member-equal goal goal-stack) nil)
        (t (some #'(lambda (op) (apply-op state goal op goal-stack))
                 (appropriate-ops goal protected-goals state)))))

解決は出来た模様。

(gps '(son-at-home have-money car-works)
     '(son-at-school have-money) *school-ops*)

;; => ((PAIP.GPSV2::START) (PAIP.GPSV2::EXECUTING DRIVE-SON-TO-SCHOOL))

(gps '(son-at-home have-money car-works)
     '(son-at-school) *school-ops*)

;; => ((PAIP.GPSV2::START) (PAIP.GPSV2::EXECUTING TAXI-SUN-TO-SCHOOL))

achieveのみを修正するバージョン

ヒントを良く読むと、apply-opが返すリストを検査し、他のゴールが削除されていた場合、失敗させる方法らしいです。
確かにそっちの方が修正範囲が少なくてすみますね。
appropriate-opsとappropriate-pは修正前に戻しました。

intersectionでstateに含まれるother-goalsを取り出し、protected-goalsとします。
apply-op後に全てのprotected-goalがapply-opの結果に含まれていることを確認します。

(defun achieve (state goal other-goals goal-stack)
  "A goal is achieved if it already holds,
  or if there is an appropriate op for it that is applicable."
  (dbg-indent :gps (length goal-stack) "Goal: ~a (~a)" goal other-goals)
  (cond ((member-equal goal state) state)
        ((member-equal goal goal-stack) nil)
        (t (let ((protected-goals (intersection state other-goals :test #'equal)))
	     (some #'(lambda (op)
		       (let ((result (apply-op state goal op goal-stack)))
			 (when (every #'(lambda (protected-goal)
					  (member-equal protected-goal result))
				      protected-goals)
			   result)))
		   (appropriate-ops goal state))))))

(defun appropriate-ops (goal state)
  "Return a list of appropriate operators, 
  sorted by the number of unfulfilled preconditions."
  (sort (copy-list (find-all goal *ops* :test #'appropriate-p)) #'<
	:key #'(lambda (op) 
                 (count-if #'(lambda (precond)
                               (not (member-equal precond state)))
                           (op-preconds op)))))
(defun appropriate-p (goal op)
  "An op is appropriate to a goal if it is in its add list."
  (member-equal goal (op-add-list op)))

当然、同じ結果になりました。

(gps '(son-at-home have-money car-works)
     '(son-at-school have-money) *school-ops*)

;; => ((PAIP.GPSV2::START) (PAIP.GPSV2::EXECUTING DRIVE-SON-TO-SCHOOL))

(gps '(son-at-home have-money car-works)
     '(son-at-school) *school-ops*)

;; => ((PAIP.GPSV2::START) (PAIP.GPSV2::EXECUTING TAXI-SUN-TO-SCHOOL))

さらにヒントをよく見ると…

残った全てのゴールがapply-opの結果で達成できるかを確認すれば良かっただけ
の模様…。

(defun achieve (state goal other-goals goal-stack)
  "A goal is achieved if it already holds,
  or if there is an appropriate op for it that is applicable."
  (dbg-indent :gps (length goal-stack) "Goal: ~a (~a)" goal other-goals)
  (cond ((member-equal goal state) state)
        ((member-equal goal goal-stack) nil)
        (t (some #'(lambda (op)
		     (achieve-all (apply-op state goal op goal-stack) other-goals goal-stack))
		 (appropriate-ops goal state)))))

これでも解決。

(gps '(son-at-home have-money car-works)
     '(son-at-school have-money) *school-ops*)

;; => ((PAIP.GPSV2::START) (PAIP.GPSV2::EXECUTING DRIVE-SON-TO-SCHOOL))

(gps '(son-at-home have-money car-works)
     '(son-at-school) *school-ops*)

;; => ((PAIP.GPSV2::START) (PAIP.GPSV2::EXECUTING TAXI-SUN-TO-SCHOOL))

ヒントはちゃんと読むべきですね。