diff --git a/cram_execution_trace/cram-execution-trace.asd b/cram_execution_trace/cram-execution-trace.asd index b3945cc..bed459c 100644 --- a/cram_execution_trace/cram-execution-trace.asd +++ b/cram_execution_trace/cram-execution-trace.asd @@ -26,6 +26,7 @@ (:file "offline-task" :depends-on ("package")) (:file "episode-knowledge-backend" :depends-on ("package" "episode-knowledge" "offline-task")) (:file "serialize" :depends-on ("package" "episode-knowledge" "episode-knowledge-backend")) + (:file "task-tree-serialize") (:file "interface" :depends-on ("package" "episode-knowledge" "serialize")) (:module "episode-knowledge" :depends-on ("package" "utils") diff --git a/cram_execution_trace/src/package.lisp b/cram_execution_trace/src/package.lisp index 4231be0..e8e0d5d 100644 --- a/cram_execution_trace/src/package.lisp +++ b/cram_execution_trace/src/package.lisp @@ -79,4 +79,7 @@ #:auto-tracing-enabled #:set-auto-tracing-directory #:setup-auto-tracing + ;; task tree serialization + #:store-tree + #:restore-tree )) diff --git a/cram_execution_trace/src/task-tree-serialize.lisp b/cram_execution_trace/src/task-tree-serialize.lisp new file mode 100644 index 0000000..dd4357c --- /dev/null +++ b/cram_execution_trace/src/task-tree-serialize.lisp @@ -0,0 +1,35 @@ +;;; +;;; Copyright (c) 2015 +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; * Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;;; POSSIBILITY OF SUCH DAMAGE. +;;; + +(in-package #:cram-execution-trace) + +(defun store-tree (tree filename) + (let ((newtree (cpl-impl:clear-illegal-function-names tree))) + (cl-store:store newtree filename))) + +(defun restore-tree (filename) + (cl-store:restore filename)) + diff --git a/cram_language/cram-language.asd b/cram_language/cram-language.asd index 1b62864..f60ba01 100644 --- a/cram_language/cram-language.asd +++ b/cram_language/cram-language.asd @@ -40,6 +40,7 @@ :components ((:file "fluent") (:file "value-fluent" :depends-on ("fluent")) + (:file "latch-fluent" :depends-on ("fluent")) (:file "fluent-net" :depends-on ("fluent")) (:file "pulse-fluent" :depends-on ("fluent")))) ;; WALKER @@ -55,6 +56,8 @@ ;; CRAM, The Language (:file "language" :depends-on ("packages" "walker" "tasks" "fluents" "logging" "with-policy" "default-policies")) (:file "plans" :depends-on ("packages" "tasks")) + (:file "ptr-language" :depends-on ("packages" "language" "plans")) + (:file "ptr-goals" :depends-on ("packages" "ptr-language")) (:file "goals" :depends-on ("packages" "tasks")) (:file "fluent-operators" :depends-on ("packages" "fluents")) (:file "swank-indentation" :depends-on ("packages")))))) diff --git a/cram_language/src/fluents/latch-fluent.lisp b/cram_language/src/fluents/latch-fluent.lisp new file mode 100644 index 0000000..2fe255f --- /dev/null +++ b/cram_language/src/fluents/latch-fluent.lisp @@ -0,0 +1,83 @@ +;;; +;;; Copyright (c) 2015, Mihai Pomarlan , +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; * Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; * Neither the name of Willow Garage, Inc. nor the names of its +;;; contributors may be used to endorse or promote products derived from +;;; this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;;; POSSIBILITY OF SUCH DAMAGE. +;;; + +(in-package :cpl-impl) + +(defclass latch-fluent (value-fluent) + ((monitored-fluent :initarg :monitored-fluent + :initform nil + :reader monitored-fluent + :writer (setf monitored-fluent) + :documentation "Boolean fluent. When it becomes true, the latch fluent is set to true."))) + +(defun setup-latch-fluent (monitored-fluent) + "Creates a latch fluent over a monitored fluent. + When monitored-fluent becomes non-NIL, the latch fluent will become T. + The latch fluent must be manually reset to NIL afterwards." + (let* ((lf (cpl:make-fluent :name :latch-fluent :class 'latch-fluent :value nil)) + (sf (cpl:fl-funcall (lambda (sig) + (if (cpl:value sig) + (setf (cpl:value lf) T)) + (cpl:value sig)) + monitored-fluent))) + (setf (monitored-fluent lf) sf) + lf)) + +(defun setup-accumulator-fluent (monitored-fluent accumulator-function &optional (init-value nil)) + "Creates an accumulator fluent over a monitored fluent. Accumulation is done by accumulator-function, +which must be of the form + +(lambda (monitored-value accumulated-value) &body) + +and returning a value of type compatible with accumulated-value. + +init-value is by default NIL. It is strongly recommended to provide an explicit starting value however, +because not all types of accumulated values are compatible with NIL (for example, REAL isn't). + +EXAMPLE: setting up a MAX fluent, which stores the maximum value reached by some other fluent. + +(defun acc-max (new-val old-val) + (if (< old-val new-val) + new-val + old-val)) + +(setup-accumulator-fluent monitored-fluent #'acc-max 0) + +NOTE: when setting an accumulator fluent, make sure the monitored-fluent has a reasonable value. + +For some fluents it is ok if this initial value is NIL (therefore, we can't use wait-for here). +In some cases however, for example when a monitored-fluent should contain a number, then having +a NIL value while setting up the accumulator will cause an error." + (let* ((lf (cpl:make-fluent :name :accumulator-fluent :class 'latch-fluent :value init-value)) + (sf (cpl:fl-funcall (lambda (sig) + (setf (cpl:value lf) (funcall accumulator-function (cpl:value sig) (cpl:value lf)))) + monitored-fluent))) + (setf (monitored-fluent lf) sf) + lf)) + diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index e2db340..d1dc5bb 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -93,6 +93,9 @@ ;; fluent.lisp #:fluent #:value-fluent + #:latch-fluent + #:setup-latch-fluent + #:setup-accumulator-fluent #:value #:peek-value #:wait-for @@ -149,12 +152,69 @@ #:fail #:on-fail #:simple-plan-failure #:plan-failure - #:with-failure-handling #:retry + #:plan-failure/get-code-path + #:with-failure-handling #:with-transformative-failure-handling #:retry #:with-retry-counters #:do-retry #:reset-counter #:get-counter #:common-lisp-error-envelope #:envelop-error #:*break-on-plan-failures* #:*debug-on-lisp-errors* + ;; ptr-function versions of plan macros + #:ptr-failure + #:ptr-circular-partial-order + #:ptr-malformed-partial-order + #:ptr-failure/message + #:ptr-failure/cdeps + #:ptr-failure/deps-issue + #:ptr-tag + #:ptr-tag/name + #:ptr-tag/fluent-object + #:ptr-tag/task-object + #:wait-for-ptr-tag + #:ptr-seq + #:ptr-try-in-order + #:ptr-with-task + #:ptr-with-task-suspended + #:ptr-try-each-in-order + #:ptr-par + #:ptr-pursue + #:ptr-try-all + #:ptr-par-loop + #:ptr-partial-order + #:get-dependent-partial-order-tasks + #:delete-partial-order-task + #:get-deps-result + #:function-application + #:function-application/task-tag + #:function-application/function-object + #:function-application/par-list + #:function-application-list + #:function-application-list/fn-list + #:make-fn-app-list + #:with-task-ptr-parameter + #:with-task-ptr-parameter/function-application + #:with-task-ptr-parameter/class + #:with-task-ptr-parameter/name + #:try-each-ptr-parameter + #:try-each-ptr-parameter/task-tag + #:try-each-ptr-parameter/function-object + #:try-each-ptr-parameter/options-list + #:make-try-each-ptr-par + #:partial-order-ptr-parameter + #:partial-order-ptr-parameter/fn-apps + #:partial-order-ptr-parameter/orderings + ;; ptr-goals + #:fluent-condition-failure + #:goal-recipes-failed + #:goal-pattern-not-found + #:goal-recipe-not-found + #:fmp/name + #:ptr-declare-goal + #:ptr-add-goal-pattern + #:ptr-add-goal-recipe + #:ptr-adjust-recipe-score + #:ptr-remove-recipe + #:ptr-clear-patterns ;; task-tree.lisp #:code #:code-parameters @@ -171,6 +231,9 @@ #:with-task-tree-node #:make-task-tree-node #:replaceable-function + #:replace-task-ptr-parameter + #:replace-task-code + #:get-ptr-parameter #:make-task #:sub-task #:task @@ -186,6 +249,9 @@ #:goal-task-tree-node-pattern #:goal-task-tree-node-parameter-bindings #:goal-task-tree-node-goal + #:*in-projection-environment* + #:*projection-signal-data* + #:*retry-path* ;; base.lisp #:top-level #:seq #:par #:tag #:with-tags #:with-task-suspended #:par-loop @@ -197,7 +263,7 @@ ;; plans.lisp #:on-def-top-level-plan-hook #:def-top-level-plan #:get-top-level-task-tree #:def-plan - #:def-cram-function #:def-top-level-cram-function + #:def-cram-function #:def-top-level-cram-function #:def-ptr-cram-function ;; goals.lisp #:declare-goal #:def-goal #:goal #:register-goal #:goal-context #:succeed #:describe-goal)) @@ -222,6 +288,8 @@ #:log-enable #:log-disable #:log-set + ;; task tree utils + #:clear-illegal-function-names ;; tasks #:name #:*save-tasks* diff --git a/cram_language/src/plans.lisp b/cram_language/src/plans.lisp index 1ec40e6..08958f7 100644 --- a/cram_language/src/plans.lisp +++ b/cram_language/src/plans.lisp @@ -65,25 +65,56 @@ :format-control "Use of deprecated form DEF-TOP-LEVEL-PLAN. Please use DEF-TOP-LEVEL-CRAM-FUNCTION instead.") `(def-top-level-cram-function ,name ,lambda-list ,@body)) +(defmacro def-cram-function-base (name lambda-list is-ptr-task &rest body) + (with-gensyms (call-args) + (multiple-value-bind (body-forms declarations doc-string) + (parse-body body :documentation t) + (let* ((op (if is-ptr-task + (list 'replaceable-ptr-function 'ptr-parameter) + (list 'replaceable-function)))) + `(progn + (eval-when (:load-toplevel) + (setf (get ',name 'plan-type) :plan) + (setf (get ',name 'plan-lambda-list) ',lambda-list) + (setf (get ',name 'plan-sexp) ',body)) + (defun ,name (&rest ,call-args) + ,doc-string + ,@declarations + (let* ((ptr-parameter (car ,call-args))) + (declare (ignorable ptr-parameter)) + (,@op ,name ,lambda-list ,call-args (list ',name) + (with-tags + ,@body-forms))))))))) + (defmacro def-cram-function (name lambda-list &rest body) "Defines a cram function. All functions that should appear in the - task-tree must be defined with def-cram-function. + task-tree must be defined with def-cram-function (or def-ptr-cram-function). CAVEAT: See docstring of def-top-level-cram-function." - (with-gensyms (call-args) - (multiple-value-bind (body-forms declarations doc-string) - (parse-body body :documentation t) - `(progn - (eval-when (:load-toplevel) - (setf (get ',name 'plan-type) :plan) - (setf (get ',name 'plan-lambda-list) ',lambda-list) - (setf (get ',name 'plan-sexp) ',body)) - (defun ,name (&rest ,call-args) - ,doc-string - ,@declarations - (replaceable-function ,name ,lambda-list ,call-args (list ',name) - (with-tags - ,@body-forms))))))) + `(def-cram-function-base ,name ,lambda-list nil ,@body)) + +(defmacro def-ptr-cram-function (name lambda-list &rest body) + "Defines a cram function. All functions that should appear in the + task-tree must be defined with def-cram-function (or def-ptr-cram-function). + + CAVEAT: See docstring of def-top-level-cram-function. + + Difference to def-cram-function: MUST have at least one argument in the lambda + list. First argument in lambda list is extracted and passed as ptr-parameter. + + When a ptr-cram-function is first called (there is no corresponding task tree + node) then the value of the ptr-parameter slot in the newly created node is + set to the value of the first parameter. + + When a ptr-cram-function is called and a corresponding node exists in the task + tree, then the first parameter in the lambda list is replaced by the ptr-param + stored in the task tree. + + (Corresponding node here means a node in the task tree at a path corresponding + to the place where the function was called inside the program. It might be the + case that a cram function gets called several times in a plan, then each place + gets a node.)" + `(def-cram-function-base ,name ,lambda-list T ,@body)) (defmacro def-plan (name lambda-list &rest body) (style-warn 'simple-style-warning diff --git a/cram_language/src/ptr-goals.lisp b/cram_language/src/ptr-goals.lisp new file mode 100644 index 0000000..357a52c --- /dev/null +++ b/cram_language/src/ptr-goals.lisp @@ -0,0 +1,507 @@ +;;; +;;; Copyright (c) 2015, Mihai Pomarlan +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; * Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; * Neither the name of Willow Garage, Inc. nor the names of its +;;; contributors may be used to endorse or promote products derived from +;;; this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;;; POSSIBILITY OF SUCH DAMAGE. +;;; + + +(in-package :cpl-impl) + +;; TODO: use keyvars here +(defparameter ptr-retry nil) +(defparameter ptr-return nil) +(defparameter ptr-fail nil) + +(define-condition fluent-condition-failure (condition) + ((failed-fluents + :initarg :failed-fluents + :initform nil))) + +(define-condition goal-pattern-not-found (condition) + ((pattern + :initarg :pattern + :initform nil) + (goal + :initarg :goal + :initform nil))) + +(define-condition goal-recipe-not-found (condition) + ((name + :initarg :name + :initform nil) + (pattern + :initarg :pattern + :initform nil) + (goal + :initarg :goal + :initform nil))) + +(define-condition goal-recipes-failed (condition) + ;; DO NOT make this a subtype of goal-pattern-not-found (or vice-versa). + ;; We do not want handlers for one to inadvertently catch the other. + ((pattern + :initarg :pattern + :initform nil) + (goal + :initarg :goal + :initform nil))) + +(defclass failure-monitored-process () + ((mutex + :reader fmp/mutex + ;; no writer, will never need to put a new mutex in the slot (the mutex's own slots are already changeable anyway) + ;; no initarg, default init below is the only sensible value + :initform (make-instance 'sb-thread:mutex) + :documentation "Needed if we want to change recipes/their scores on the fly.") + (parent + :accessor fmp/parent ;; do not export + :initarg :parent + :initform nil + :documentation "Used to trace which recipe belongs to which pattern, which pattern to which goal.") + (fluent-conditions + :reader fmp/fluent-conditions + ;; no writer, will never need to put a new hash in the slot (the hash contents are already changeable anyway) + ;; no initarg, default init below is the only sensible value + :initform (make-hash-table :test #'eq) + :documentation "A hash of (key:fluent expected-value) pairs. If any of the fluents in the hash deviates from its expected value, issue a fluent-condition-failure.") + (name + :reader fmp/name + ;; no writer, will never change a recipe name + :initarg :name + :initform nil + :documentation "Used to identify this particular recipe- each recipe in a pattern should have a unique name.") + (body + :accessor fmp/body + :initarg :body + :initform nil + :documentation "Function object of the proc.") ;;; Or, should we use source code here and do eval? + (failure-handlers + :accessor fmp/failure-handlers + :initform (make-hash-table :test #'eq) + :type hash-table + :documentation "A hash-table of (failure-type: function) pairs. Function objects should take exactly one parameter of condition type."))) + +(defclass ptr-goal-pattern-recipe (failure-monitored-process) + ((score + :accessor gpr/score + :initarg :score + :initform 0 + :type number + :documentation "Used to rank this recipe vs. others in a ptr-goal-pattern. Higher score means a recipe is tried first."))) + +(defclass ptr-goal-pattern (failure-monitored-process) + ((pattern + :reader gp/pattern + ;; no writer, will never change a pattern + :initarg :pattern + :initform nil + :documentation "Pattern to match, expressed in the usual Prolog-in-Lisp way (? prefixes variable names).") + (recipes + :accessor gp/recipes + :initarg :recipes + :initform nil + :type list + :documentation "List of recipes to pursue a particular goal pattern."))) + +(defclass ptr-goal (failure-monitored-process) + ((function + :reader goal/function + :writer (setf goal/function-w) + :initarg :function + :initform nil + :documentation "A link to the main function responsible to carry out this goal.") + (patterns + :reader goal/patterns + :writer (setf goal/patterns-w) + :initarg :patterns + :initform nil + :type list + :documentation "List of patterns (each with a collection of recipes to carry them out)."))) + +(defun find-handler (fmp err) + (sb-thread:with-mutex ((fmp/mutex fmp)) + (loop for ftype being the hash-keys of (fmp/failure-handlers fmp) + using (hash-value fh) + when (typep err ftype) return fh))) + +(defmacro failure-handler-dispatcher (fmp err default-action &key (spec-handler nil) (failures nil)) + "Look in fmp for a handler for the failure and depending on its return value, retry, resignal, or return + normally. If no handler, use default behavior. Default behavior uses either err or a longer collection + of previous failures if that exists." + `(let* ((handler (find-handler ,fmp ,err)) + (default-resig (if (and ,failures (< 1 (length ,failures))) + (make-condition 'composite-failure :failures (reverse ,failures)) + ,err))) + (if handler + (multiple-value-bind (action retval) (apply handler (list ,err :previous-failures ,failures)) + (cond + ((eq action 'ptr-return) (return retval)) + ((eq action 'ptr-retry) (retry)) + ((eq action 'ptr-fail) (fail retval)) + (T nil)))) + ;; If we're still here, then either a handler wasn't found or the action returned was + ;; not among PTR-RETRY, PTR-FAIL, PTR-RETURN, in which case revert to default behavior. + (if (and ,spec-handler (typep ,err (first ,spec-handler))) + (multiple-value-bind (action retval) (apply (second ,spec-handler) (list ,err :previous-failures ,failures)) + (cond + ((eq action 'ptr-return) (return retval)) + ((eq action 'ptr-retry) (retry)) + ((eq action 'ptr-fail) (fail retval)) + (T nil)))) + ;; Again, if we're still here, then either a handler wasn't found or the action returned was + ;; not among PTR-RETRY, PTR-FAIL, PTR-RETURN, in which case revert to default behavior. + (cond + ((eq ,default-action 'ptr-return) (return default-resig)) + ((eq ,default-action 'ptr-retry) (retry)) + (T (fail default-resig))))) + +(defmacro with-ptr-goal-failure-handler ((goal-object default-action &key (spec-handler nil)) &body body) + (with-gensyms (failures) + `(block nil + (let* ((,failures (list))) + (with-transformative-failure-handling + ((condition (err) + (setf ,failures (cons err ,failures)) + (failure-handler-dispatcher ,goal-object err ,default-action :spec-handler ,spec-handler :failures ,failures))) + ,@body))))) + +(defun init-failure-handlers (fmp failure-handlers) + (sb-thread:with-mutex ((fmp/mutex fmp)) + (clrhash (fmp/failure-handlers fmp)) + (loop for fh in failure-handlers do + (setf (gethash (first fh) (fmp/failure-handlers fmp)) + (second fh))))) + +(defun init-fluent-conditions (fmp fluent-conditions) + (sb-thread:with-mutex ((fmp/mutex fmp)) + (clrhash (fmp/fluent-conditions fmp)) + (loop for fc in fluent-conditions do + (setf (gethash (first fc) (fmp/fluent-conditions fmp)) + (second fc))))) + +(defun extend-fc-hash (acc ext) + (loop for key being the hash-keys of ext + using (hash-value value) + when (not (nth-value 1 (gethash key acc))) + do (setf (gethash key acc) value))) +(defun construct-fluent-condition (goal goal-pattern goal-recipe) + (sb-thread:with-mutex ((fmp/mutex goal)) + (sb-thread:with-mutex ((fmp/mutex goal-pattern)) + (sb-thread:with-mutex ((fmp/mutex goal-recipe)) + (let* ((goal-fcs (fmp/fluent-conditions goal)) + (gp-fcs (fmp/fluent-conditions goal-pattern)) + (gpr-fcs (fmp/fluent-conditions goal-recipe)) + (fcs (make-hash-table :test #'eq)) + (fls-list nil) + (expvals-list nil)) + (extend-fc-hash fcs gpr-fcs) + (extend-fc-hash fcs gp-fcs) + (extend-fc-hash fcs goal-fcs) + (setf fls-list + (loop for key being the hash-keys of fcs collect key into R finally (return R))) + (setf expvals-list + (loop for key being the hash-keys of fcs using (hash-value value) collect value into R finally (return R))) + (cons + (apply #'fl-funcall + (cons + (lambda (&rest args) + (let* ((expvals (car args)) + (fls (cdr args)) + (have-failure nil)) + (loop for fl in fls + for vl in expvals + when (not (equal (value fl) vl)) + do (progn + (setf have-failure T) + (return))) + have-failure)) + (cons + expvals-list + fls-list))) + (cons + expvals-list + fls-list))))))) + +(defun record-failed-fluents (fls-list expvals) + (remove + nil + (mapcar + (lambda (fl ev) + (if (not (equal (value fl) ev)) + (list fl (value fl) ev) + nil)) + fls-list + expvals))) + +(defun tried-recipe? (recipe tried-recipes) + (loop for tr in tried-recipes + when (equal (fmp/name recipe) (fmp/name tr)) do (return T))) + +;; This assumes the list of recipes in goal-pattern is sorted by score. +(defun find-next-recipe (goal-pattern tried-recipes) + (sb-thread:with-mutex ((fmp/mutex goal-pattern)) + (loop for recipe in (gp/recipes goal-pattern) + when (not (tried-recipe? recipe tried-recipes)) do (return recipe)))) + +(defun find-ptr-goal-pattern (goal args) + (sb-thread:with-mutex ((fmp/mutex goal)) + (loop for goal-pattern in (goal/patterns goal) do + (progn + (multiple-value-bind (bdgs ok?) (cut:pat-match (gp/pattern goal-pattern) args) + (if ok? + (return (values goal-pattern bdgs)))))))) + +(defun insert-goal-pattern-internal (gp-list gp &key (overwrite T)) + (let* ((cgp (car gp-list)) + (right-place (and cgp (equal (gp/pattern gp) (gp/pattern cgp))))) + (if right-place + (if overwrite + (setf (car gp-list) gp) + cgp) + (if cgp + (insert-goal-pattern-internal (cdr gp-list) gp :overwrite overwrite))))) +(defun insert-goal-pattern (goal goal-pattern &key (overwrite T)) + (sb-thread:with-mutex ((fmp/mutex goal)) + (let* ((ret-gp (insert-goal-pattern-internal (goal/patterns goal) goal-pattern :overwrite overwrite))) + (if ret-gp + ret-gp + (progn + (setf (goal/patterns-w goal) (nconc (goal/patterns goal) (list goal-pattern))) + goal-pattern))))) + +(defun ensure-gp (goal lambda-list) + (let* ((gp (make-instance + 'ptr-goal-pattern + :body (lambda (&rest args) (declare (ignore args)) nil) + :parent goal + :pattern lambda-list))) + (insert-goal-pattern goal gp :overwrite nil))) + +(defun replace-recipe-by-name (gpr-list gpr &key (only-update-score nil)) + (let* ((cgpr (car gpr-list))) + (if cgpr + (sb-thread:with-mutex ((fmp/mutex cgpr)) + (if (equal (fmp/name cgpr) (fmp/name gpr)) + (if only-update-score + (progn + (setf (gpr/score cgpr) (gpr/score gpr)) + ;; just to keep return type consistent on all branches: return a goal-pattern-recipe (or nil) + cgpr) + (setf (car gpr-list) gpr)) + (replace-recipe-by-name (cdr gpr-list) gpr :only-update-score only-update-score))) + nil))) +(defun update-goal-pattern-recipe (gp gpr &key (only-update-score nil)) + (sb-thread:with-mutex ((fmp/mutex gp)) + (let* ((replaced-by-name (replace-recipe-by-name (gp/recipes gp) gpr :only-update-score only-update-score))) + (if replaced-by-name + (setf (gp/recipes gp) (sort (gp/recipes gp) #'> :key #'gpr/score)) + (if only-update-score + nil + (setf (gp/recipes gp) (merge 'list (gp/recipes gp) (list gpr) #'> :key #'gpr/score))))))) + +(defmacro create-recipe-task (task-name parameters path-part body) + `(make-instance 'task + :name ,task-name + :thread-fun (lambda () + (with-task-tree-node + (:path-part ,path-part + :name ,task-name + :sexp (,task-name () (apply ,body ,parameters)) + :lambda-list () + :parameters ()) + (apply ,body ,parameters))))) + +(defun run-ptr-goal-recipe (goal goal-pattern goal-recipe bdgs) + (with-ptr-goal-failure-handler (goal-recipe 'ptr-fail) + (let* ((fc-aux (construct-fluent-condition goal goal-pattern goal-recipe)) ;; returns (fluent-condition expvals-list mon.fl1 mon.fl2 ...) + (fluent-condition (car fc-aux)) + (expvals (cadr fc-aux)) + (fls-list (cddr fc-aux)) + (body (fmp/body goal-recipe)) + (task-name (format nil "Goal-recipe-~a" (fmp/name goal-recipe))) + (pattern (gp/pattern goal-pattern)) + (lambda-list (reverse (cut:vars-in pattern))) ;; cut:vars-in reverses the order of appearance of variables, which is a bit ... counter-intuitive. + (parameters (mapcar (alexandria:rcurry #'cut:var-value bdgs) lambda-list)) + (path-part (list 'goal (cons (fmp/name goal-recipe) pattern))) + (recipe-task (create-recipe-task task-name parameters path-part body)) + (recipe-status (status recipe-task)) + (recipe-done-fluent (fl-funcall (lambda (fluent-condition recipe-status) + (or (value fluent-condition) + (equal (value recipe-status) :succeeded) + (equal (value recipe-status) :failed) + (equal (value recipe-status) :evaporated))) + fluent-condition + recipe-status))) + (wait-for recipe-done-fluent) + (if (value fluent-condition) + (progn + (evaporate recipe-task) + (fail 'fluent-condition-failure :failed-fluents (record-failed-fluents fls-list expvals)))) + (if (equal (value recipe-status) :failed) + (fail (result recipe-task)) + (result recipe-task))))) + +(defun run-ptr-goal-pattern (goal goal-pattern bdgs) + (sb-thread:with-mutex ((fmp/mutex goal-pattern)) + (if (fmp/body goal-pattern) + (let* ((pattern (gp/pattern goal-pattern)) + (lambda-list (reverse (cut:vars-in pattern))) ;; cut:vars-in reverses the order of appearance of variables, which is a bit ... counter-intuitive. + (parameters (mapcar (alexandria:rcurry #'cut:var-value bdgs) lambda-list))) + (apply (fmp/body goal-pattern) parameters)))) + (let* ((tried-recipes nil) + (pattern (gp/pattern goal-pattern)) + (tried-tail nil)) + (with-ptr-goal-failure-handler (goal-pattern 'ptr-retry + :spec-handler (list 'goal-recipes-failed + (lambda (err &key (previous-failures nil)) + (declare (ignorable err)) + (values 'ptr-fail (make-condition 'composite-failure :failures (reverse previous-failures)))))) + (let* ((next-recipe (find-next-recipe goal-pattern tried-recipes))) + (unless next-recipe + ;; Reset tried-recipes, just in case some user-defined handler for goal-recipes-failed decides to retry. + ;; (There probably shouldn't be user handlers for this signal, but we'll leave it in.) + (setf tried-recipes nil) + (setf tried-tail nil) + (fail 'goal-recipes-failed :goal goal :pattern pattern)) + ;; Rather than the usual (cons new-element list), we prefer to add elements to the tail of the list via the tail-tracking trick. + ;; Reason is, we'd rather search tried recipes in order of best-tried so far to last, to hopefully minimize comparisons. + ;; (And suspect that tail-tracking is more efficient than reversing for every search). + (if tried-recipes + (progn + (setf (cdr tried-tail) (cons next-recipe nil)) + (setf tried-tail (cdr tried-tail))) + (progn + (setf tried-recipes (cons next-recipe nil)) + (setf tried-tail tried-recipes))) + (setf tried-recipes (cons next-recipe tried-recipes)) + (run-ptr-goal-recipe goal goal-pattern next-recipe bdgs))))) + +(defmacro ptr-declare-goal ((name lambda-list &key (fluent-conditions nil) (failure-handlers nil)) &body body) + "Declare a ptr-goal: a logical collection of functions meant to achieve some plan goal. + Collection is empty after the execution of this function, and must be extended with + PTR-ADD-GOAL-RECIPE and/or adjusted with PTR-ADJUST-RECIPE-SCORE. + + Goals can only be called inside CRAM plans. + + FLUENT-CONDITIONS is a list of pairs: (fluent-object expected-value). A fluent object should + only appear once in the list (or, if it appears more, have EQUAL expected-value). During + execution of the goal or one of its subsumed recipes, the fluent-object must maintain the + expected value, or else a FLUENT-CONDITION-FAILURE is signalled. + + If a recipe subsumed by the goal defines a different expected-value for the fluent, the + recipe's expected value will be used instead while running that particular recipe. + + FAILURE-HANDLERS is a list of (type function) pairs where TYPE is a symbol describing a + condition type and FUNCTION is a function that takes one parameter of condition type + and a key parameter :previous-failures. + Conditions issued by the goal or one of its subsumed recipes (including FLUENT-CONDITION-FAILURE) + can be caught by these handlers. + + A subsumed recipe can define a handler for a condition that its parent goal also has a + handler for. In this case, the recipe's handle gets called first. If it doesn't resolve + the condition, the goal's handler is then called. + + FAILURE-HANDLERS should return two values: one is an action to take as a result of handling, + the second is an optional return value if the goal is supposed to return rather than + propagate a signal upwards. + + Actions to take after handling: + - 'PTR-RETRY: retry the body of the goal from scratch + - 'PTR-RETURN: return normally (return the value given by the failure handler) + - 'PTR-FAIL: propagate condition upwards (default). If the failure handler returns a value, + this should be of condition type and it will be signalled upwards." + (multiple-value-bind (forms declarations doc-string) + (parse-body body :documentation t) + (with-gensyms (args) + `(progn + (defparameter ,name + (make-instance 'ptr-goal + :name (format nil "~a" ',name) + :body (lambda ,lambda-list ,@declarations (with-tags ,@forms)))) + (def-ptr-cram-function ,name (&rest ,args) + ,doc-string + (with-ptr-goal-failure-handler (,name 'ptr-fail) + (flet ((before ,lambda-list + ,@declarations + ,@forms)) + (apply #'before ,args)) + (multiple-value-bind (goal-pattern bdgs) (find-ptr-goal-pattern ,name ,args) + (unless goal-pattern + (fail 'goal-pattern-not-found :goal ,name :pattern ,args)) + (run-ptr-goal-pattern ,name goal-pattern bdgs)))) + (setf (goal/function-w ,name) #',name) + (init-failure-handlers ,name ,failure-handlers) + (init-fluent-conditions ,name ,fluent-conditions))))) + +(defmacro ptr-add-goal-pattern ((goal lambda-list &key (fluent-conditions nil) (failure-handlers nil)) &body body) + (multiple-value-bind (forms declarations) + (parse-body body :documentation nil) + (with-gensyms (gp) + `(let* ((,gp (make-instance + 'ptr-goal-pattern + :pattern ',lambda-list + :body (lambda ,lambda-list ,@declarations (with-tags ,@forms)) + :parent ,goal))) + (init-failure-handlers ,gp ,failure-handlers) + (init-fluent-conditions ,gp ,fluent-conditions) + (insert-goal-pattern ,goal ,gp))))) + +(defmacro ptr-add-goal-recipe ((goal pattern name score &key (fluent-conditions nil) (failure-handlers nil)) &body body) + (multiple-value-bind (forms declarations) + (parse-body body :documentation nil) + (let* ((lambda-list (reverse (cut:vars-in pattern)))) + (with-gensyms (gp gpr) + `(let* ((,gp (ensure-gp ,goal ',pattern)) + (,gpr (make-instance + 'ptr-goal-pattern-recipe + :name ,name + :score ,score + :body (lambda ,lambda-list ,@declarations (with-tags ,@forms)) + :parent ,gp))) + (init-failure-handlers ,gpr ,failure-handlers) + (init-fluent-conditions ,gpr ,fluent-conditions) + (update-goal-pattern-recipe ,gp ,gpr)))))) + +(defun ptr-adjust-recipe-score (goal lambda-list name score) + (let* ((gp (ensure-gp goal lambda-list)) ;; todo: replace with a find pattern here. + (dummy-gpr (make-instance + 'ptr-goal-pattern-recipe + :name name + :score score))) + (if (update-goal-pattern-recipe gp dummy-gpr :only-update-score T) + T + (fail 'goal-recipe-not-found :name name :pattern lambda-list :goal goal)))) + +(defun ptr-remove-recipe (goal lambda-list name) + (let* ((gp (ensure-gp goal lambda-list))) ;; todo: replace with a find pattern here. + (sb-thread:with-mutex ((fmp/mutex gp)) + (setf (gp/recipes gp) (delete-if (lambda (a) + ;; Will never change name in a recipe, so no need for mutexes here. + (equal (fmp/name a) name)) + (gp/recipes gp)))))) + +(defun ptr-clear-patterns (goal) + (setf (goal/patterns-w goal) nil)) diff --git a/cram_language/src/ptr-language.lisp b/cram_language/src/ptr-language.lisp new file mode 100644 index 0000000..9cc98db --- /dev/null +++ b/cram_language/src/ptr-language.lisp @@ -0,0 +1,909 @@ +;;; +;;; Copyright (c) 2015, Mihai Pomarlan +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; * Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; * Neither the name of Willow Garage, Inc. nor the names of its +;;; contributors may be used to endorse or promote products derived from +;;; this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;;; POSSIBILITY OF SUCH DAMAGE. +;;; + + +(in-package :cpl-impl) + +;;; This file defines function versions of some of the macros that make up the plan language (seq, par, try-in-order etc.) +;;; +;;; The reason is that these ptr functions show up in the task tree. In particular, their ptr-argument is changeable by +;;; plan transformation, which means the plan could decide, at runtime, what to put inside a sequence or parallel block. + +;;; TODO: right now all these anonymous lambdas will mess up de/serialization. Will need some way to detect whether +;;; ptr-parameter slots in the task tree are safely serializable and/or provide a serialization mechanism for some +;;; reasonable class of function objects/closures. + +(defparameter *deps-result* nil "Parameter to store, for a task started inside ptr-partial-order, the results + of its deps as a list.") + +(defun get-deps-result () + *deps-result*) + +;;; Failure conditions + +(define-condition ptr-failure (plan-failure) + ((message :initarg :message :initform nil :reader ptr-failure/message))) + +(define-condition ptr-circular-partial-order (ptr-failure) + ((cdeps :initarg :cdeps :initform nil :reader ptr-failure/cdeps))) + +(define-condition ptr-malformed-partial-order (ptr-failure) + ((deps-issue :initarg :deps-issue :initform nil :reader ptr-failure/deps-issue))) + +;;; Graph classes and functions, used to detect circular dependencies in a call to ptr-partial-order +;;; These will not be exported, so we can name them however we like. + +(defclass dag-vertex () + ((node + :accessor dag-node + :initarg :node + :documentation "Identifier for the node. In the partial-order use case, will be a ptr-tag.") + (deps + :accessor dag-deps + :initarg :deps + :initform (make-hash-table :test #'eq) + :type hash-table + :documentation "\"Dependencies\" of a node. Key is a node identifier (eg., ptr-tag). Value is a dag-vertex [reference].") + (users + :accessor dag-users + :initarg :users + :initform (make-hash-table :test #'eq) + :type hash-table + :documentation "\"Users\" of a node (they have node in their deps). Key is a node identifier (eg., ptr-tag). Value is a dag-vertex [reference]."))) + +(defclass dag () + ((nodes + :accessor dag-nodes + :initarg :nodes + :initform (make-hash-table :test #'eq) + :type hash-table + :documentation "Hash table of vertices in a graph. Key is a node identifier (eg., ptr-tag). Value is a dag-vertex [reference]."))) + +(defun add-vertex (dag node-id) + "Adds an edgeless node to the dag." + (setf (gethash node-id (dag-nodes dag)) (make-instance 'dag-vertex :node node-id))) + +(defun add-dep (dag user-node-id dep-node-id) + "In graph supplied by dag, add a dependency to user-node-id on dep-node-id. + + Will check that both node ids are present in the graph; if one misses, returns nil. + + If both present, checks whether user-node-id and dep-node-id are the same. If so, + returns nil. + + Otherwise adds the dependency and returns true." + (if (and (nth-value 1 (gethash user-node-id (dag-nodes dag))) (nth-value 1 (gethash dep-node-id (dag-nodes dag))) (not (eq user-node-id dep-node-id))) + (let* ((user-node (gethash user-node-id (dag-nodes dag))) + (dep-node (gethash dep-node-id (dag-nodes dag)))) + (setf (gethash dep-node-id (dag-deps user-node)) dep-node) + (setf (gethash user-node-id (dag-users dep-node)) user-node) + T) + nil)) + +(defun get-free-nodes (dag) + "Returns a list of nodes from dag which have no deps." + (loop for node being the hash-values of (dag-nodes dag) + when (equal (hash-table-count (dag-deps node)) 0) + collect (dag-node node) into S + finally (return S))) + +(defun get-all-nodes-hash (dag) + (let* ((G (make-hash-table :test #'eq))) + (loop for node-id being the hash-keys of (dag-nodes dag) do + (setf (gethash node-id G) node-id)) + G)) + +(defun get-all-nodes-list (node-hash) + (loop for node-id being the hash-keys of node-hash + collect node-id into G + finally (return G))) + +(defun restore-deps (dag R) + "Restore dependencies in R into dag. R is a list of pairs (user-id dep-id). Useful because get-dag-kernel messes up the + dep structure in the process of detecting cycles, and will call this to restore the dag." + (loop for edge in R do + (let* ((user-node-id (first edge)) + (dep-node-id (second edge)) + (user-node (gethash user-node-id (dag-nodes dag))) + (dep-node (gethash dep-node-id (dag-nodes dag)))) + (setf (gethash dep-node-id (dag-deps user-node)) dep-node)))) + +(defun get-dag-kernel (dag &key (tail-id nil tail-id-p)) + "Returns two values: + - a list of node-ids from dag, of nodes that cannot be topologically sorted because they have cyclic deps. + - the list of nodes that could be topologically sorted, in some topologically sorted order. + + Use the first value to test for circular dependencies (nil if none exist). + Use the second when you want an actual topological sort. + + TAIL-ID is a node-id that, along with its (indirect) dependencies, you wish to appear at the end of the + topological order (and node-ids not (indirectly) dependent on tail-id must appear before it)." + (let* ((S (get-free-nodes dag)) + (G (get-all-nodes-hash dag)) + (R nil) + (L nil)) + (loop while S do + (let* ((x (if (and tail-id-p (> (length S) 1) (eq tail-id (car S))) + (progn + (setf S (reverse S)) + (car S)) + (car S)))) + (setf S (cdr S)) + (setf L (cons x L)) + (remhash x G) + (loop for user being the hash-values of (dag-users (gethash x (dag-nodes dag))) do + (remhash x (dag-deps user)) + (setf R (cons (list (dag-node user) x) R)) + (if (equal (hash-table-count (dag-deps user)) 0) + (setf S (cons (dag-node user) S)))))) + (restore-deps dag R) + (values + (get-all-nodes-list G) + (reverse L)))) + +;;; Auxiliary structures to pass ptr-parameters + +(defclass ptr-tag () + ((name + :accessor ptr-tag/name + :initarg :name + :initform "PTR-TASK" + :type (or string null) + :documentation "A name to give the task, for logging purposes.") + (fluent-object + :reader ptr-tag/fluent-object + :writer (setf ptr-tag/fluent-object-w) +;; Actually, there should be no clean way to set these slots from outside this package. +;; Reason is, the data inside is only useful for this package, and anything that +;; someone else might put here won't be valid anyway. +;; :initarg :fluent-object + :initform (make-fluent :name :tag-fluent :value nil) + :type (or fluent null) + :documentation "A fluent object used by ptr-partial-order.") + (task-object + :reader ptr-tag/task-object + :writer (setf ptr-tag/task-object-w) +;; Actually, there should be no clean way to set these slots from outside this package. +;; Reason is, the data inside is only useful for this package, and anything that +;; someone else might put here won't be valid anyway. +;; :initarg :task-object + :initform nil + :documentation "A task object."))) + +(defgeneric wait-for-ptr-tag (tag) + (:documentation "Wait for the fluent of a ptr-tag specified by arg to become non-nil")) + +(defmethod wait-for-ptr-tag ((tag ptr-tag)) + (wait-for (ptr-tag/fluent-object tag))) + +(defclass function-application () + ((task-tag + :accessor function-application/task-tag + :initarg :task-tag + :initform nil + :type (or ptr-tag null) + :documentation "Reference to a ptr-tag object used to store a reference to the task this function-application will create (useful for with-task-suspended).") + (function-object + :accessor function-application/function-object + :initarg :function-object + :initform (lambda () nil) + :type (or function compiled-function) + :documentation "A function object to run with the supplied parameters.") + (par-list + :accessor function-application/par-list + :initarg :par-list + :initform nil + :type list + :documentation "A list of parameters to apply the function to."))) + +(defclass function-application-list () + ((fn-list + :accessor function-application-list/fn-list + :initarg :fn-list + :initform nil + :type list + :documentation "A list of function-application objects."))) + +(defmacro make-fn-app (function-object &rest args) + `(make-instance 'function-application :function-object ,function-object :par-list ,args)) + +(defmacro make-fn-app-list (&body body) + "Takes a list of s-expressions and creates a function-application-list object (which can then be + passed as a parameter for ptr-seq, ptr-par etc). + + The cars of the s-expressions in body must be named, known functions." + `(make-instance 'function-application-list + :fn-list (mapcar (lambda (s-exp) + (make-instance 'function-application + :function-object (symbol-function (car s-exp)) + :par-list (cdr s-exp))) + ',body))) + +(defclass with-task-ptr-parameter () + ((function-application + :accessor with-task-ptr-parameter/function-application + :initarg :function-application + :initform (make-instance 'function-application + :function-object #'identity + :par-list (list nil)) + :type function-application + :documentation "A function object and parameters to apply it to, while running inside the task.") + (class + :accessor with-task-ptr-parameter/class + :initarg :class + :initform 'task + :type (or symbol null) + :documentation "Class of the task to start, default to 'task.") + (name + :accessor with-task-ptr-parameter/name + :initarg :name + :initform "WITH-TASK" + :type (or string null) + :documentation "Name of the task to start, default to \"WITH-TASK\"."))) + +(defclass try-each-ptr-parameter () + ((task-tag + :accessor try-each-ptr-parameter/task-tag + :initarg :task-tag + :initform nil + :type (or ptr-tag null) + :documentation "Reference to a ptr-tag object used to store a reference to the task this function-application will create (useful for with-task-suspended).") + (function-object + :accessor try-each-ptr-parameter/function-object + :initarg :function-object + :initform (lambda (&rest args) (declare (ignore args)) nil) + :type (or function compiled-function) + :documentation "A function object to run once for each option in options-list.") + (options-list + :accessor try-each-ptr-parameter/options-list + :initarg :options-list + :initform nil + :type (or list null) + :documentation "Options to feed, one by one, to function-object."))) + +;;(defclass par-loop-ptr-parameter () +;; ((function-object +;; :reader par-loop-ptr-parameter/function-object +;; :initarg :function-object +;; :initform (lambda (&rest args) (declare (ignore args)) nil) +;; :type (or function compiled-function) +;; :documentation "A function object to run on the supplied parameter options.") +;; (options-list +;; :reader par-loop-ptr-parameter/options-list +;; :initarg :options-list +;; :initform nil +;; :type (or list null) +;; :documentation "Options to feed, one by one, to function-object."))) + +(defmacro make-try-each-ptr-par (function-object &body body) + "Takes a function name and lists of parameters and creates a try-each-ptr-parameter." + `(make-instance 'try-each-ptr-parameter + :function-object ,function-object + :options-list (mapcar (lambda (arg) (list arg)) ',body))) + +(defclass partial-order-ptr-parameter () + ((fn-apps + :accessor partial-order-ptr-parameter/fn-apps + :initarg :fn-apps + :initform nil + :type (or function-application-list null) + :documentation "List of functions and parameters to call them with. Each element must + have a ptr-tag.") + (orderings + :accessor partial-order-ptr-parameter/orderings + :initarg :orderings + :initform nil + :type list + :documentation "List of orderings. Each element is of form (user-tag dep-tag1 dep-tag2 ...)."))) + +;;; Conversion from fn-app-list to the dag auxiliary type + +(defun get-dag-vertices (fn-app-list) + (let* ((dag (make-instance 'dag))) + (loop for fn-app in fn-app-list do + (if (function-application/task-tag fn-app) + (progn + (if (nth-value 1 (gethash (function-application/task-tag fn-app) (dag-nodes dag))) + (fail 'ptr-malformed-partial-order :message "PTR-PARTIAL-ORDER received two function applications with the same tag." :deps-issue fn-app)) + (add-vertex dag (function-application/task-tag fn-app))))) + dag)) + +(defun add-deps (dag deps) + (let* ((retq (mapcar (lambda (dep) + (add-dep dag (car deps) dep)) + (cdr deps)))) + (not (position nil retq)))) + +(defun get-dag-fl-list (node-hash) + (loop for node-id being the hash-keys of node-hash + collect (ptr-tag/fluent-object node-id) into G + finally (return G))) + +(defun get-dependent-partial-order-tasks (partial-order-ptr-parameter task-ptr-tag) + "Returns which task tags occuring in PARTIAL-ORDER-PTR-PARAMETER depend + on (tasks that depend on) the given TASK-PTR-TAG. + + Test used is EQ. + + Returns (cons error-condition tag-list). + + TAG-LIST is a list of ptr-tag objects appeating in + PARTIAL-ORDER-PTR-PARAMETER with the given dependency. + If ERROR-CONDITION, TAG-LIST is nil. + + ERROR-CONDITION is: + - PTR-MALFORMED-PARTIAL-ORDER if ordering constraints refer to task tags not present in the task list, + or contain tasks that depend on themselves. + - PTR-CIRCULAR-PARTIAL-ORDER if ordering constraints contain circular dependencies. + - nil otherwise." + (let* ((fn-apps (partial-order-ptr-parameter/fn-apps partial-order-ptr-parameter)) + (fn-list (if fn-apps + (function-application-list/fn-list fn-apps) + nil)) + (dag (get-dag-vertices fn-list)) + (malformed-orderings (loop for ordering in (partial-order-ptr-parameter/orderings partial-order-ptr-parameter) + when (not (add-deps dag ordering)) + collect ordering into R + finally + (return R))) + (mal-sig (if malformed-orderings + (make-condition 'ptr-malformed-partial-order :message "PTR-PARTIAL-ORDER received malformed ordering constraints." :deps-issue malformed-orderings) + nil)) + (dag-topsort (if mal-sig + nil + (multiple-value-list (get-dag-kernel dag :tail-id task-ptr-tag)))) + (dag-kernel (first dag-topsort)) + (dag-order (second dag-topsort)) + (dag-sig (if dag-kernel + (make-condition 'ptr-circular-partial-order :message "PTR-PARTIAL-ORDER received circular ordering constraints." :cdeps dag-kernel) + nil)) + (error-condition (or mal-sig dag-sig)) + (dag-relevant-order (if error-condition + nil + (member task-ptr-tag dag-order)))) + (cons error-condition dag-relevant-order))) + +(defun delete-partial-order-task (partial-order-ptr-parameter task-ptr-tag) + "Creates a new ptr-partial-order-parameter which is a copy of PARTIAL-ORDER-PTR-PARAMETER, + then removes from the copy the task associated to task-ptr-tag and also removes mentions + to this task from all ordering relations in the copy. + + Returns the copy. PARTIAL-ORDER-PTR-PARAMETER is not affected. + + Test used is EQ. + + DOES NOT remove tasks that depend on TASK-PTR-TAG. Before deleting a task + from a partial order, use get-dependent-partial-order-tasks to get a list + of tasks that depend on it. That way you get to choose which to remove, + if any." + (let* ((fn-apps (partial-order-ptr-parameter/fn-apps partial-order-ptr-parameter)) + (fn-list (if fn-apps + (function-application-list/fn-list fn-apps) + nil)) + (orderings (partial-order-ptr-parameter/orderings partial-order-ptr-parameter))) + (setf fn-list (remove-if (lambda (arg) + (eq (function-application/task-tag arg) task-ptr-tag)) + fn-list)) + (setf orderings (remove-if (lambda (arg) + (eq (car arg) task-ptr-tag)) + orderings)) + (setf orderings + (loop for ordering in orderings + collect (remove-if (lambda (arg) + (eq arg task-ptr-tag)) + ordering) + into orderings + finally (return orderings))) + (make-instance 'partial-order-ptr-parameter + :fn-apps (make-instance 'function-application-list + :fn-list fn-list) + :orderings orderings))) + +;;; Sequential running of function objects + +(def-ptr-cram-function ptr-seq (ptr-parameter) + "PTR-PARAMETER must be a function-application-list object. + + Run function objects from ptr-parameter in sequence. Returns the return value of the last function object. + + Function objects should be functions defined with def-[ptr-]cram-function if they are to show up in the task tree. + + Will fail as soon as one of the function objects produces a failure." + (car (last (mapcar (lambda (fn-app) + (if (function-application/task-tag fn-app) + (let* ((s-task (make-instance 'task + :name (ptr-tag/name (function-application/task-tag fn-app)) + :thread-fun (lambda () + (apply (function-application/function-object fn-app) + (function-application/par-list fn-app)))))) + (setf (ptr-tag/task-object-w (function-application/task-tag fn-app)) s-task) + (join-task s-task)) + (apply (function-application/function-object fn-app) + (function-application/par-list fn-app)))) + (function-application-list/fn-list ptr-parameter))))) + +(def-ptr-cram-function ptr-try-in-order (ptr-parameter) + "PTR-PARAMETER must be a function-application-list object. + + Execute function objects in ptr-parameter sequentially. Succeed if one succeeds, fail if all fail. + + Function objects should be defined with def-[ptr-]cram-function if they are to show up in the task tree. + + Return value is the return value of the first function object in ptr-parameter that succeeds. + In case of failure on all function objects, a composite-failure is signaled." + (block ablock + (let* ((failures (list))) + (mapcar (lambda (fn-app) + (block tryout-block + (with-failure-handling + ((plan-failure (err) + (setf failures (cons err failures)) + (return-from tryout-block))) + (return-from ablock (if (function-application/task-tag fn-app) + (let* ((s-task (make-instance 'task + :name (ptr-tag/name (function-application/task-tag fn-app)) + :thread-fun (lambda () + (apply (function-application/function-object fn-app) + (function-application/par-list fn-app)))))) + (setf (ptr-tag/task-object-w (function-application/task-tag fn-app)) s-task) + (join-task s-task)) + (apply (function-application/function-object fn-app) (function-application/par-list fn-app))))))) + (function-application-list/fn-list ptr-parameter)) + (assert-no-returning + (signal + (make-condition 'composite-failure + :failures (reverse failures))))))) + +(def-ptr-cram-function ptr-with-task (ptr-parameter) + "PTR-PARAMETER is a with-task-ptr-parameter object. Slots function-application, class, name. + + class and name slots are optional. If not provided, they default to + 'task and \"WITH-TASK\" respectively. + + Executes function-object in a separate task and joins it." + (let* ((function-object (function-application/function-object (with-task-ptr-parameter/function-application ptr-parameter))) + (par-list (function-application/par-list (with-task-ptr-parameter/function-application ptr-parameter))) + (task-class (with-task-ptr-parameter/class ptr-parameter)) + (par-name (with-task-ptr-parameter/name ptr-parameter)) + (task-name (gensym (format nil "[~a]-" par-name))) + (task (make-instance task-class + :name task-name + :thread-fun (lambda () (apply function-object par-list))))) + (join-task task))) + +(def-ptr-cram-function ptr-with-task-suspended (ptr-parameter task &key reason) + "PTR-PARAMETER must be a function-application-list object. + TASK must be a ptr-tag or task object. + + Execute function objects in ptr-parameter, in sequence, with 'task' being suspended. + + Returns the value returned by the last function object in ptr-parameter. + (NOTE: the return value is a difference to the with-task-suspended macro.)" + (let* ((task-sym (if (typep task 'ptr-tag) + (ptr-tag/task-object task) + task)) + (retq nil)) + (unwind-protect + (progn + (suspend task-sym :sync t :reason reason) + (wait-for (fl-eq (status task-sym) :suspended)) + (setf retq (car (last (mapcar (lambda (fn-app) + (if (function-application/task-tag fn-app) + (let* ((s-task (make-instance 'task + :name (ptr-tag/name (function-application/task-tag fn-app)) + :thread-fun (lambda () + (apply (function-application/function-object fn-app) + (function-application/par-list fn-app)))))) + (setf (ptr-tag/task-object-w (function-application/task-tag fn-app)) s-task) + (join-task s-task)) + (apply (function-application/function-object fn-app) + (function-application/par-list fn-app)))) + (function-application-list/fn-list ptr-parameter))))) + (wake-up task-sym) + retq)))) + +(def-ptr-cram-function ptr-try-each-in-order (ptr-parameter) + "PTR-PARAMETER is a try-each-ptr-parameter object. Slots are function-object + and options-list. + + options-list must contain at least one element, which must be a list of + parameters to pass to the function object. The function object should have + a lambda list compatible with the parameter lists supplied by options-list. + + Applies function-object to each element in options-list sequentially until + function-object succeeds. Returns the result of function-object as + soon as it succeeds and stops iterating. Otherwise, if all attempts + fail, signal a composite failure. + + NOTES: + + (1) Take care when using a ptr-cram-function as a function-object here, + the result may not be quite what you expect. Remember that such functions + take their parameter from their own corresponding node, so once that node + exists they'll ignore cars of parameter lists passed from this function. + + (2) ptr-try-each-in-order gives you a way to convert an older cram-function + into a ptr-cram-function without having to redefine it as one: + + (ptr-try-each-in-order (make-instance 'cpl-impl:try-each-ptr-parameter + :function-object some-cram-function + :parameter-list (list some-ptr-parameter))) + + (3) there's a difference here to the try-each-in-order macro: rather than + bindings to some global variables, we use parameter passing here." + (block ablock + (let* ((failures (list)) + (opt-list (try-each-ptr-parameter/options-list ptr-parameter)) + (function-object (try-each-ptr-parameter/function-object ptr-parameter)) + (task-tag (try-each-ptr-parameter/task-tag ptr-parameter))) + (dolist (arg opt-list (assert-no-returning + (signal + (make-condition 'composite-failure + :failures (reverse failures))))) + (block try-block + (with-failure-handling + ((plan-failure (condition) + (setf failures (cons condition failures)) + (return-from try-block))) + (return-from ablock (if task-tag + (let* ((s-task (make-instance 'task + :name (ptr-tag/name task-tag) + :thread-fun (lambda () + (apply function-object arg))))) + (setf (ptr-tag/task-object-w task-tag) s-task) + (join-task s-task)) + (apply function-object arg))))))))) + +;;; Parallel running of function objects + +;; We define this as a simple lisp function because we don't plan to export it +;; (it's only useful as an auxiliary inside this package) and we don't want it +;; to show up and clutter the task tree. +(defun ptr-with-parallel-children (name children-function-objects watcher-function-object) + "Execute each of children-function-objects in parallel tasks. Execute + watcher-function-object whenever a child changes state. + + name is used as a basis for the names of the child tasks. + + children-function-objects must be of function-application-list type + + watcher-function-object must have a lambda list containing three arguments: + + (lambda (running done failed) ...) + + The arguments are to be lists of tasks that are, respectively, running, + completed successfully, and failed. + + All spawned child tasks are terminated when this function terminates." + (let* ((parent-task-name-base (or name "WITH-PARALLEL-CHILDREN")) + (parent-task-name (format nil "~a" (gensym parent-task-name-base))) + (child-task-name-base (format nil "~a" (or name "PARALLEL"))) + (done nil) + (done-tail nil) + (parent-task (make-instance 'task + :name parent-task-name + :thread-fun (lambda () + (let* ((child-num (length (function-application-list/fn-list children-function-objects))) + (child-numbers (alexandria:iota child-num :start 1)) + (retq nil) + (task-list (mapcar (lambda (f-obj nr) + (let* ((task-tag (function-application/task-tag f-obj))) + (if task-tag + (progn + (setf (ptr-tag/task-object-w task-tag) + (make-instance 'task + :name (format nil "~a" + (format-gensym "[~A-CHILD-#~D/~D-~a]-" child-task-name-base nr child-num (ptr-tag/name task-tag))) + :thread-fun (lambda () + (apply (function-application/function-object f-obj) + (function-application/par-list f-obj))))) + (ptr-tag/task-object task-tag)) + (make-instance 'task + :name (format nil "~a" + (format-gensym "[~A-CHILD-#~D/~D]-" child-task-name-base nr child-num)) + :thread-fun (lambda () + (apply (function-application/function-object f-obj) + (function-application/par-list f-obj))))))) + (function-application-list/fn-list children-function-objects) + child-numbers)) + (cr-child-tasks (copy-list (child-tasks *current-task*))) + (cr-child-status (mapcar #'status cr-child-tasks))) + (declare (ignorable task-list)) + (wait-for (fl-apply #'notany (curry #'EQ :CREATED) cr-child-status)) + (whenever ((apply #'fl-or (mapcar (RCURRY #'fl-pulsed :handle-missed-pulses :once) cr-child-status))) + (multiple-value-bind (running failed) + (loop for task in cr-child-tasks + for i from 0 below (length cr-child-tasks) + when (and task (task-running-p task)) + collect task into running + when (and task (task-done-p task)) do + ;;collect task into done: we're adding to a variable defined above, and skipping nils, + ;;because we'd like the order of tasks in done to reflect the order in which the tasks + ;;finished. If we used a loop-local variable `done' for this purpose, the tasks would + ;;appear in the order in which they were created, because that's how the loop iterates + ;;on them + (progn + ;; use tail-tracking to add elements to the end of done. We'd like to avoid having to use reverse later + ;; (and we cannot use nreverse when calling the watcher-function-object, since + ;; we call the watcher-function-object whenever a task changes status, and + ;; the done list may still be in construction at that time) + (if (not done) + (progn + (setf done (cons task nil)) + (setf done-tail done)) + (progn + (setf (cdr done-tail) (cons task nil)) + (setf done-tail (cdr done-tail)))) + (setf (nth i cr-child-tasks) nil)) + when (and task (task-failed-p task)) + collect task into failed + ;;finally (return (values running done failed))) + finally (return (values running failed))) + (if (member + (make-keyword (string-upcase parent-task-name-base)) + +available-log-tags+) + (%log-event "~a" (list parent-task-name-base) + "~@[R: ~{~A~^, ~} ~] ~@[~:_D: ~{~A~^, ~} ~] ~@[~:_F: ~{~A~^, ~}~]" + (list (mapcar #'task-abbreviated-name running) + (mapcar #'task-abbreviated-name done) + (mapcar #'task-abbreviated-name failed))) + nil) + (setf retq (funcall watcher-function-object running done failed)) + (if (not running) + (return retq))))))))) + (join-task parent-task))) + +(def-ptr-cram-function ptr-par (ptr-parameter) + "PTR-PARAMETER is a function-application-list object. + Executes function objects in parallel. Fails if one fails. Succeeds if all + succeed. Returns the result of the task that finished last." + (block ptr-par-block + (ptr-with-parallel-children "PAR" + ptr-parameter + (lambda (running done failed) + (cond (failed + (assert-no-returning + (signal (result (car failed))))) + ((not running) + (result (car (last done))))))))) + +;; a bit of a hack to force a return from ptr-with-parallel-children when one task completes +;; in a PURSUE or TRY-ALL block. +(define-condition pursue-done (plan-failure) + ((result :initarg :result :initform nil :reader pursue-done/result))) + +(defun evaporate-subts (task) + (mapcar #'evaporate-subts (child-tasks task)) + (format T "Task: ~a~%" task) + (evaporate task)) + +(def-ptr-cram-function ptr-pursue (ptr-parameter) + "PTR-PARAMETER is a function-application-list object. + Executes function objects in parallel. Fails if one fails. Succeeds if one + succeeds, and returns the value returned by the first successful task." + (block ptr-pursue-block + ;; a bit of a hack to force a return from ptr-with-parallel-children when one task completes. + (with-failure-handling + ((pursue-done (e) + (mapcar #'evaporate (child-tasks *current-task*)) + (return-from ptr-pursue-block (pursue-done/result e)))) + (ptr-with-parallel-children "PURSUE" + ptr-parameter + (lambda (running done failed) + (declare (ignore running)) + (cond (failed + (assert-no-returning + (signal (result (car failed))))) + (done + (assert (eq (value (status (car done))) :succeeded)) + (result (car done)) + (assert-no-returning (signal (make-condition 'pursue-done :result (result (car done)))))))))))) + +(def-ptr-cram-function ptr-try-all (ptr-parameter) + "PTR-PARAMETER is a function-application-list object. + Executes function objects in parallel. Fails if all fail. Succeeds if one + succeeds, and returns the value returned by the first successful task. + + In case of failure, a condition of type 'composite-failure' is signaled, + containing the list of all error messages and data." + (block ptr-try-all-block + ;; a bit of a hack to force a return from ptr-with-parallel-children when one task completes. + (with-failure-handling + ((pursue-done (e) + (mapcar #'evaporate (child-tasks *current-task*)) + (return-from ptr-try-all-block (pursue-done/result e)))) + (ptr-with-parallel-children "TRY-ALL" + ptr-parameter + (lambda (running done failed) + (cond ((and (not running) (not done) failed) + (assert-no-returning + (signal + (make-condition 'composite-failure :failures (mapcar #'result failed))))) + (done + (assert-no-returning + (signal + (make-condition 'pursue-done :result (result (car done)))))))))))) + +(defun ptr-par-loop-internal (ptr-parameter) + (block ptr-par-loop-block + (let* ((ptr-parameter-adjusted (make-instance 'function-application-list + :fn-list (mapcar (lambda (arg) + (make-instance 'function-application + :function-object (try-each-ptr-parameter/function-object ptr-parameter) + :par-list arg)) + (try-each-ptr-parameter/options-list ptr-parameter))))) + (ptr-with-parallel-children "PAR-LOOP" + ptr-parameter-adjusted + (lambda (running done failed) + (cond (failed + (assert-no-returning + (signal (result (car failed))))) + ((not running) + (result (car (last done)))))))))) + +(def-ptr-cram-function ptr-par-loop (ptr-parameter) + "PTR-PARAMETER is a try-each-ptr-parameter object. Slots are function object + and options-list. + + For each element in options-list, runs (apply function-object element) in parallel. + Fails if one fails. Succeeds if all succeed. Returns the result of the task that finished last." + (if (try-each-ptr-parameter/task-tag ptr-parameter) + (let* ((task-tag (try-each-ptr-parameter/task-tag ptr-parameter)) + (s-task (make-instance 'task + :name (ptr-tag/name task-tag) + :thread-fun (lambda () + (ptr-par-loop-internal ptr-parameter))))) + (setf (ptr-tag/task-object-w task-tag) s-task) + (join-task s-task)) + (ptr-par-loop-internal ptr-parameter))) + +(def-ptr-cram-function ptr-partial-order (ptr-parameter) + "PTR-PARAMETER must be a partial-order-ptr-parameter object, + with slots fn-apps and orderings. + + fn-apps contains a list of function applications. Each function + application contains a function object and a list of parameters + to apply it to. Each function application should also contain a + reference to a ptr-tag object if it is to be part of or be + affected by ordering constraints; a tagless function application + will just run in parallel to the others. + + orderings contains a list, where each element is of the form + + (user-tag dep-tag1 dep-tag2 ...) + + and the interpretation is the following: before the task associated + to user-tag can run, tasks associated to dep-tag1, dep-tag2 etc. + must successfully complete. + + A task tag is an object whose contents will be manipulated by the + ptr functions. Do not rely on data placed by you the user in there + to remain. + + Runs the fn-apps in parallel, respecting the ordering conditions, + IF the ordering conditions are well specified and non-circular. + + To be well-specified, ordering conditions must: + + - refer only to ptr-tags referenced in fn-apps. + - no tag can depend on itself + + Will emit a failure if: + + - orderings not well specified or circular + - one of the function applications fails + + Otherwise returns the value returned by the last task to finish." + (let* ((fn-apps (partial-order-ptr-parameter/fn-apps ptr-parameter)) + (fn-list (if fn-apps + (function-application-list/fn-list fn-apps) + nil)) + (orderings (partial-order-ptr-parameter/orderings ptr-parameter)) + (dag (get-dag-vertices fn-list)) + (malformed-orderings (loop for ordering in orderings + when (not (add-deps dag ordering)) + collect ordering into R + finally + (return R))) + (mal-sig (if malformed-orderings + (fail 'ptr-malformed-partial-order :message "PTR-PARTIAL-ORDER received malformed ordering constraints." :deps-issue malformed-orderings) + nil)) + (dag-kernel (get-dag-kernel dag)) + (dag-sig (if dag-kernel + (fail 'ptr-circular-partial-order :message "PTR-PARTIAL-ORDER received circular ordering constraints." :cdeps dag-kernel) + nil)) + (ptr-tags (loop for fn-app in fn-list + when (function-application/task-tag fn-app) + collect (function-application/task-tag fn-app) into R + finally + (return R))) + (ptr-parameter-adjusted (make-instance 'function-application-list))) + (declare (ignore mal-sig) (ignore dag-sig)) +;; Once all tests on well-formedness and circularity are done, we can proceed with the actual construction of tasks. + +;; First, initialize the ptr-tag objects to contain new fluents, each of which is initialized to nil. We do this now, because it means +;; these fluents are guaranteed to exist, and therefore make meaningful targets to wait on, when we generate tasks later. + (loop for ptr-tag in ptr-tags do + (setf (ptr-tag/fluent-object-w ptr-tag) (make-fluent :name :ptr-tag-fluent :value nil))) +;; Second, when we generate tasks, we will, for each task: +;; - prepend waits on fluents from deps ptr-tags. We wait on the fluents (which we know exist at this stage) rather than task fluents, +;; which are not yet constructed +;; - append a setting of the fluent from the corresponding ptr-tag to T. + (loop for fn-app in fn-list do + (let* ((task-tag (function-application/task-tag fn-app)) + (fn-ob (function-application/function-object fn-app)) + (par-list (function-application/par-list fn-app)) + (dag-node (if task-tag + (gethash task-tag (dag-nodes dag)) + nil)) + (dep-fl-list (if dag-node + (get-dag-fl-list (dag-deps dag-node)) + nil)) + (dep-tag-list (if dag-node + (mapcar #'dag-node (get-all-nodes-list (dag-deps dag-node))) + nil)) + (have-deps (if dep-fl-list T nil))) + (setf (function-application-list/fn-list ptr-parameter-adjusted) + (cons (make-instance 'function-application + :task-tag task-tag + :function-object (lambda (&rest args) + (let* ((retq nil) + (dep-fluent (if dep-fl-list + (apply #'fl-funcall + (cons + (lambda (&rest args) + (equal (position nil args) nil)) + dep-fl-list)) + (make-fluent :name :ptr-tag-fluent :value T)))) + (if have-deps + (progn + (wait-for dep-fluent) + (setf *deps-result* + (mapcar (lambda (a-tag) + (list + (ptr-tag/name a-tag) + (ptr-tag/task-object a-tag))) + dep-tag-list)))) + (setf retq (apply fn-ob args)) + (if task-tag + (setf (value (ptr-tag/fluent-object task-tag)) T)) + retq)) + :par-list par-list) + (function-application-list/fn-list ptr-parameter-adjusted))))) +;; Third, run the created task functions in parallel. + (block ptr-partial-order-block + (ptr-with-parallel-children "PARTIAL-ORDER" + ptr-parameter-adjusted + (lambda (running done failed) + (cond (failed + (assert-no-returning + (signal (result (car failed))))) + ((not running) + (result (car (last done)))))))))) + diff --git a/cram_language/src/tasks/failures.lisp b/cram_language/src/tasks/failures.lisp index 2181d55..f86484a 100644 --- a/cram_language/src/tasks/failures.lisp +++ b/cram_language/src/tasks/failures.lisp @@ -37,7 +37,12 @@ "Indicates if the debugger should be entered at the location where a common lisp error is raised.") -(define-condition plan-failure (serious-condition) () +(defvar *retry-path* nil "Path variable used by the with-failure-handling and with-transformative-failure-handling macros. It denotes the path of the macros' BODY inside the task tree.") + +(define-condition plan-failure (serious-condition) + ((code-path :initarg :code-path + :reader plan-failure/get-code-path + :initform nil)) (:documentation "Condition which denotes a plan failure.")) @@ -100,16 +105,20 @@ (signal condition)))))) (defun fail (&rest args) + "Function to generate a fail condition which includes the current code path among +its member data if (car args) is of typep symbol." (if (null args) - (%fail "Plan failure." nil) - (%fail (car args) (cdr args)))) + (%fail 'plan-failure (list :code-path *current-path*)) + (if (typep (car args) 'condition) + (%fail (car args) (cdr args)) + (%fail (car args) (append (cdr args) `(:code-path ,*current-path*)))))) (cut:define-hook cram-language::on-with-failure-handling-begin (clauses)) (cut:define-hook cram-language::on-with-failure-handling-end (id)) (cut:define-hook cram-language::on-with-failure-handling-handled (id)) (cut:define-hook cram-language::on-with-failure-handling-rethrown (id)) -(defmacro with-failure-handling (clauses &body body) +(defmacro with-failure-handling-base (clauses &body body) "Macro that replaces handler-case in cram-language. This is necessary because error handling does not work across multiple threads. When an error is signaled, it is put into an envelope to @@ -119,12 +128,12 @@ this envelope must also be taken into account. We also need a mechanism to retry since errors can be caused by plan execution and the environment is highly non-deterministic. Therefore, it is possible to use the function `retry' that is lexically bound -within with-failure-handling and causes a re-execution of the body. +within with-failure-handling-base and causes a re-execution of the body. When an error is unhandled, it is passed up to the next failure handling form (exactly like handler-bind). Errors are handled by invoking the retry function or by doing a non-local exit. Note that -with-failure-handling implicitly creates an unnamed block, +with-failure-handling-base implicitly creates an unnamed block, i.e. `return' can be used." (with-gensyms (wfh-block-name) (let* ((clauses @@ -141,14 +150,16 @@ i.e. `return' can be used." (loop for clause in clauses collecting (cons (car clause) (gensym (symbol-name (car clause))))))) - `(let ((log-id (first (cram-language::on-with-failure-handling-begin + `(let ((*retry-path* *current-path*) (log-id (first (cram-language::on-with-failure-handling-begin (list ,@(mapcar (lambda (clause) (write-to-string (car clause))) clauses)))))) + (declare (special *retry-path*)) (unwind-protect (block nil (tagbody ,wfh-block-name (flet ((retry () + (if (and (boundp *reset-on-retry*) *reset-on-retry*) (clear-tasks (task-tree-node *retry-path*)) nil) (go ,wfh-block-name))) (declare (ignorable (function retry))) (flet ,(mapcar (lambda (clause) @@ -183,6 +194,45 @@ i.e. `return' can be used." (return (progn ,@body))))))) (cram-language::on-with-failure-handling-end log-id)))))) +(defmacro with-failure-handling (clauses &body body) + "Macro that replaces handler-case in cram-language. This is +necessary because error handling does not work across multiple +threads. When an error is signaled, it is put into an envelope to +avoid invocation of the debugger multiple times. When handling errors, +this envelope must also be taken into account. + +We also need a mechanism to retry since errors can be caused by plan +execution and the environment is highly non-deterministic. Therefore, +it is possible to use the function `retry' that is lexically bound +within with-failure-handling and causes a re-execution of the body. + +When an error is unhandled, it is passed up to the next failure +handling form (exactly like handler-bind). Errors are handled by +invoking the retry function or by doing a non-local exit. Note that +with-failure-handling implicitly creates an unnamed block, +i.e. `return' can be used. + +NOTE: currently calls with-failure-handling-base with *reset-on-retry* set to nil. +This is the default CRAM behavior: retry will simply run the body again, and leave +the task tree intact." + `(let ((*reset-on-retry* nil)) + (declare (special *reset-on-retry*)) + (with-failure-handling-base ,clauses ,@body))) + +(defmacro with-transformative-failure-handling (clauses &body body) + "Version of with-failure-handling that enables plan transformation as a means of error handling. +See with-failure-handling for the CRAM basic approach to failure handling and its reasons. + +NOTE: calls with-failure-handling-base with *reset-on-retry* set to T. +This is the only difference to the with-failure-handling case, and results +in the task tree resetting from the node corresponding to body downwards +to the leaves. The clauses are assumed to transform the plan in order to +handle failure; the task tree reset is so that the transformations are +guaranteed to be run." + `(let ((*reset-on-retry* T)) + (declare (special *reset-on-retry*)) + (with-failure-handling-base ,clauses ,@body))) + (defmacro with-retry-counters (counter-definitions &body body) "Lexically binds all counters in `counter-definitions' to the intial values specified in `counter-definitions'. `counter-definitions' is diff --git a/cram_language/src/tasks/task-tree.lisp b/cram_language/src/tasks/task-tree.lisp index 60b9655..ea15824 100644 --- a/cram_language/src/tasks/task-tree.lisp +++ b/cram_language/src/tasks/task-tree.lisp @@ -45,7 +45,8 @@ sexp function task - parameters) + parameters + ptr-parameter) (defstruct task-tree-node (code nil) @@ -99,10 +100,10 @@ (path-part (error "Path parameter is required.")) (name "WITH-TASK-TREE-NODE") - sexp lambda-list parameters + sexp lambda-list parameters ptr-parameter is-ptr-task log-parameters log-pattern) &body body) - "Executes a body under a specific path. Sexp, lambda-list and parameters are optional." + "Executes a body under a specific path. Sexp, lambda-list, ptr-parameter and parameters are optional." (with-gensyms (task) `(let* ((*current-path* (cons ,path-part *current-path*)) (*current-task-tree-node* (ensure-tree-node *current-path*))) @@ -116,6 +117,8 @@ (let ((,task (make-task :name ',(gensym (format nil "[~a]-" name)) :sexp ',(or sexp body) + :ptr-parameter ,ptr-parameter + :is-ptr-task ,is-ptr-task :function (lambda ,lambda-list ,@body) :parameters ,parameters))) @@ -123,6 +126,17 @@ ,task))) (cram-language::on-finishing-task-execution log-id)))))) +(defmacro replaceable-function-base (name lambda-list parameters path-part ptr-parameter is-ptr-task + &body body) + `(with-task-tree-node (:path-part ,path-part + :name ,(format nil "REPLACEABLE-FUNCTION-~a" name) + :sexp `(replaceable-function ,',name ,',lambda-list . ,',body) + :lambda-list ,lambda-list + :is-ptr-task ,is-ptr-task + :ptr-parameter ,ptr-parameter + :parameters ,parameters) + ,@body)) + (defmacro replaceable-function (name lambda-list parameters path-part &body body) "Besides the replacement of simple code parts defined with 'with-task-tree-node', @@ -133,12 +147,26 @@ the code-sexp. More specifically, the sexp is built like follows: `(replaceable-function ,name ,lambda-list ,@body). The 'parameters' parameter contains the values to call the function with." - `(with-task-tree-node (:path-part ,path-part - :name ,(format nil "REPLACEABLE-FUNCTION-~a" name) - :sexp `(replaceable-function ,',name ,',lambda-list . ,',body) - :lambda-list ,lambda-list - :parameters ,parameters) - ,@body)) + `(replaceable-function-base ,name ,lambda-list ,parameters ,path-part nil nil ,@body)) + +(defmacro replaceable-ptr-function (ptr-parameter name lambda-list parameters path-part + &body body) + "Besides the replacement of simple code parts defined with 'with-task-tree-node', + it is necessary to also pass parameters to the replaceable code + parts. For that, replaceable functions can be defined. They are not + real functions, i.e. they do change any symbol-function or change + the lexical environment. 'name' is used to mark such functions in + the code-sexp. More specifically, the sexp is built like follows: + `(replaceable-function ,name ,lambda-list ,@body). + The 'parameters' parameter contains the values to call the function with. + + ptr-parameter: its initial value gets stored in the task tree, and thereafter + it is from the task tree that its value is retrieved when running the cram function. + This has two consequences: + + - it should only be used to send 'compile-time' values to the cram function OR + - it can be used to send values tweaked by plan transformation." + `(replaceable-function-base ,name ,lambda-list ,parameters ,path-part ,ptr-parameter T ,@body)) (defun execute-task-tree-node (node) (let ((code (task-tree-node-effective-code node))) @@ -159,6 +187,12 @@ (car replacements) (task-tree-node-code node)))) +(defun get-ptr-parameter () + "Return the currently effective ptr-parameter for the current node. + The currently effective ptr-parameter is in the car of code-replacements + or, if there are no code-replacements, in the code of the node." + (code-ptr-parameter (task-tree-node-effective-code (task-tree-node *current-path*)))) + (defun path-next-iteration (path-part) (let ((iterations-spec (member :call path-part))) (if iterations-spec @@ -169,25 +203,33 @@ (sexp nil) (function nil) (path *current-path*) + (ptr-parameter nil) + (is-ptr-task nil) (parameters nil)) "Returns a runnable task for the path" - (let ((node (register-task-code sexp function :path path))) + (let ((node (register-task-code sexp function :ptr-parameter ptr-parameter :path path))) (sb-thread:with-recursive-lock ((task-tree-node-lock node)) - (let ((code (task-tree-node-effective-code node))) + (let* ((code (task-tree-node-effective-code node)) + (parameters-when-ptr (cons (code-ptr-parameter code) (cdr parameters))) + (cr-parameters (if is-ptr-task + parameters-when-ptr + parameters))) (cond ((not (code-task code)) - (setf (code-parameters code) parameters) + (setf (code-parameters code) cr-parameters) (setf (code-task code) (make-instance 'task :name name :thread-fun (lambda () (apply (code-function code) - parameters)) + cr-parameters)) :run-thread nil :path path))) ((executed (code-task code)) (make-task :name name :sexp sexp :function function + :ptr-parameter ptr-parameter + :is-ptr-task is-ptr-task :path `(,(path-next-iteration (car path)) . ,(cdr path)) :parameters parameters)) (t @@ -221,9 +263,9 @@ (mapc (compose #'clear-tasks #'cdr) (task-tree-node-children task-tree-node)) task-tree-node) -(defun task-tree-node (path) +(defun task-tree-node (path &optional (node *task-tree*)) "Returns the task-tree node for path or nil." - (labels ((get-tree-node-internal (path &optional (node *task-tree*)) + (labels ((get-tree-node-internal (path node) (let ((child (cdr (assoc (car path) (task-tree-node-children node) :test #'equal)))) (cond ((not (cdr path)) @@ -232,7 +274,7 @@ nil) (t (get-tree-node-internal (cdr path) child)))))) - (get-tree-node-internal (reverse path)))) + (get-tree-node-internal (reverse path) node))) (defun ensure-tree-node (path &optional (task-tree *task-tree*)) (labels ((worker (path node walked-path) @@ -252,14 +294,29 @@ (worker (cdr path) child current-path)))))) (worker (reverse path) task-tree nil))) -(defun replace-task-code (sexp function path &optional (task-tree *task-tree*)) - "Adds a code replacement to a specific task tree node." - (let ((node (ensure-tree-node path task-tree))) +(defun replace-task-ptr-parameter (ptr-parameter path &key (task-tree *task-tree*)) + (let* ((node (ensure-tree-node path task-tree)) + (code (task-tree-node-effective-code node))) + (sb-thread:with-mutex ((task-tree-node-lock node)) + (setf (code-ptr-parameter code) ptr-parameter)))) + +(defun replace-task-code (sexp function path &key (ptr-parameter nil given-ptr-parameter) (task-tree *task-tree*)) + "Adds a code replacement to a specific task tree node. + +(Note: the parameters slot is refilled on each run of the plan with the parameter values actually passed +to the replaceable function. Changing the values in the parameters slot will have no effect on the plan's +running. Use the ptr-parameter slot when you want plan transformation to supply parameters to functions.)" + (let* ((node (ensure-tree-node path task-tree)) + (old-ptr-parameter (code-ptr-parameter (task-tree-node-effective-code node))) + (cr-ptr-parameter (if given-ptr-parameter + ptr-parameter + old-ptr-parameter))) (sb-thread:with-mutex ((task-tree-node-lock node)) - (push (make-code :sexp sexp :function function) + (push (make-code :sexp sexp :function function :ptr-parameter cr-ptr-parameter) (task-tree-node-code-replacements node))))) (defun register-task-code (sexp function &key + (ptr-parameter nil) (path *current-path*) (task-tree *task-tree*) (replace-registered nil)) "Registers a code as the default code of a specific task tree @@ -271,11 +328,12 @@ (cond ((or replace-registered (not code)) (setf (task-tree-node-code node) - (make-code :sexp sexp :function function))) + (make-code :sexp sexp :function function :ptr-parameter ptr-parameter))) ((or (not (code-function code)) (not (code-sexp code))) (setf (code-sexp code) sexp) (setf (code-function code) function) + (setf (code-ptr-parameter code) ptr-parameter) (when (and (code-task code) (not (executed (code-task code)))) (setf (slot-value (code-task code) 'thread-fun) @@ -286,6 +344,54 @@ ;;; Task tree utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun is-legal-function-name-p (obj) + "A bit of a hack to support serialization of named functions in task tree nodes. + +This is because code replacements will be inserted by named functions, whereas the +original replaceable function macros put lambda expressions in the task tree. Also +cl-store can re/store the names of named function and have them rerunnable, but if +un-named functions are restored they will cause an error. + +WHAT IT SHOULD DO: return true if obj is a named function (example #'+), otherwise +false (example (lambda (&rest args) (+ args))). + +WHAT IT ACTUALLY DOES: get the string representation of obj and counts parantheses +because valid function names should not contain those." + (eql 0 + (count #\( + (format nil "~A" obj)))) + +(defun clear-code-of-illegal-function-names (code) + (if code + (setf (code-task code) nil)) + (if code + (if (is-legal-function-name-p (code-function code)) + code + (setf (code-function code) nil)) + nil)) + +(defun clear-illegal-function-names-internal (tree) + (clear-code-of-illegal-function-names (task-tree-node-code tree)) + (setf (task-tree-node-code-replacements tree) + (mapcar #'clear-code-of-illegal-function-names (task-tree-node-code-replacements tree))) + (setf (task-tree-node-children tree) + (mapcar (lambda (child-spec) + (cons (car child-spec) (clear-illegal-function-names-internal (cdr child-spec)))) + (task-tree-node-children tree))) + tree) + +(defun clear-illegal-function-names (tree) + "Checks FUNCTION slots in CODE and CODE-TASK slots. If the function +object is a reference to an unnamed function, it is set to nil instead. + +This is to allow serialization of task trees to restore code-replacements. +cl-store can't serialize something like (lambda (&rest args) &body), but +can serialize something like #'some-function, including giving the tree +the ability to call that function when needed." +;; TODO: perhaps define a deep copy function for task trees, so that the +;;parameter of this function isn't changed by its operation. + (clear-illegal-function-names-internal tree)) + ;;; ;;; STALE TASK TREE NODES ;;; @@ -309,7 +415,7 @@ "Returns a copy of the task tree which contains only nodes that satisfy `predicate'. CAVEAT: If a node does not satisfy `predicate' then none of its descendants will appear in the filtered tre, even if they satisfy - `preidacte'. Assume that the root saisfies `predicate', otherwise there + `predicate'. Assume that the root satisfies `predicate', otherwise there would be no tree to return." (assert (funcall predicate tree)) ;; We assume the task object has no reference to the task tree nodes (which diff --git a/cram_language/src/tasks/task.lisp b/cram_language/src/tasks/task.lisp index 26ff536..a3a2679 100644 --- a/cram_language/src/tasks/task.lisp +++ b/cram_language/src/tasks/task.lisp @@ -42,6 +42,9 @@ (defvar *synchronous-events* t "Indicates if we want to use synchronized events") +(defvar *in-projection-environment* nil "Used by the with-transformative-tryouts macro to identify whether a projection environment is active for the current run.") +(defvar *projection-signal-data* nil "Used by the with-transformative-tryouts macro to contain results from a run in a projection environment.") + (defclass abstract-task () ((name :reader task-name diff --git a/cram_projection/src/package.lisp b/cram_projection/src/package.lisp index 50ae881..79f8837 100644 --- a/cram_projection/src/package.lisp +++ b/cram_projection/src/package.lisp @@ -33,6 +33,9 @@ (:export define-projection-environment define-special-projection-variable with-projection-environment *projection-environment* + with-transformative-tryouts + projection-ended + projection-ended/get-projection-outcome clock-time clock-wait linear-clock partially-ordered-clock partially-ordered-clock-enabled diff --git a/cram_projection/src/projection-environment.lisp b/cram_projection/src/projection-environment.lisp index 6343ce9..ae071dd 100644 --- a/cram_projection/src/projection-environment.lisp +++ b/cram_projection/src/projection-environment.lisp @@ -166,3 +166,40 @@ variable according to CPL:DEFINE-TASK-VARIABLE." :format-control "Cannot find projection environment `~a'." :format-arguments (list ',name))) (execute-in-projection-environment environment #'body-function)))) + +(define-condition projection-ended (simple-condition) + ((projection-outcome :initarg :projection-outcome + :reader projection-ended/get-projection-outcome + :initform nil)) + (:documentation + "Condition which denotes that a projection run has finished, used in the with-transformative-tryouts macro.")) + +(defmacro with-transformative-tryouts (projection-environment-name transformation-clause &body body) +"Macro to run BODY in a projection environment, return to code that will judge projection results +and transform BODY or rerun it outside the projection environment. Returns after a run outside +projection. Must be called inside a CRAM-FUNCTION or TOPLEVEL-CRAM-FUNCTION. + +Parameters: + projection-environment-name: symbol or string naming an existing projection environment + transformation-clause: a clause to be invoked after the projection environment returns + body: code to run. + +Defines variables: + cpl-impl:*in-projection-environment*: should be T or NIL. Set to NIL to have the next run of BODY +outside projection. + cpl-impl:*projection-signal-data*: a signal variable containing the result of projection. You can +access the results with (cram-projection:projection-ended/get-projection-outcome cpl-impl:*projection-signal-data*). + +Other effects: + + Task tree will contain only nodes from the final, outside of projection run." + `(let* ((cpl-impl:*in-projection-environment* T)) + (declare (special cpl-impl:*in-projection-environment*)) + (cpl-impl:with-transformative-failure-handling + ((projection-ended (cpl-impl:*projection-signal-data*) ,transformation-clause)) + (if cpl-impl:*in-projection-environment* + (let* ((projection-outcome (with-projection-environment ,projection-environment-name + ,@body)) + (projection-ended-signal (make-condition 'projection-ended :projection-outcome projection-outcome))) + (signal projection-ended-signal)) + (progn ,@body))))) diff --git a/cram_reasoning/src/fact-groups.lisp b/cram_reasoning/src/fact-groups.lisp index bca8a57..d0efa4f 100644 --- a/cram_reasoning/src/fact-groups.lisp +++ b/cram_reasoning/src/fact-groups.lisp @@ -198,7 +198,7 @@ (defmacro def-fact-group (fact-group-name extendable-predicates &body facts) "Define a group of facts. Predicates already defined by other fact groups may only be extended if the corresponding functor ist listed in - `extendable-prediactes'." + `extendable-predicates'." (let ((list-of-facts (gensym "LIST-OF-FACTS-"))) `(macrolet ((<- (fact-head &body fact-code) `(setf ,',list-of-facts