From 2cd90012ac4e4d1216d54647a483c090dee44666 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Wed, 27 May 2015 13:28:25 +0200 Subject: [PATCH 01/11] Defined replace-task-code, with-transformative-failure-handling, task tree (de)serialization; modified plan-failure and the fail function to add code-path information about the point of failure. --- cram_execution_trace/cram-execution-trace.asd | 1 + cram_execution_trace/src/package.lisp | 3 + .../src/task-tree-serialize.lisp | 35 ++++++++++ cram_language/src/packages.lisp | 5 +- cram_language/src/tasks/failures.lisp | 62 ++++++++++++++++-- cram_language/src/tasks/task-tree.lisp | 64 +++++++++++++++++-- 6 files changed, 157 insertions(+), 13 deletions(-) create mode 100644 cram_execution_trace/src/task-tree-serialize.lisp 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/src/packages.lisp b/cram_language/src/packages.lisp index e2db340..d6ce6be 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -149,7 +149,7 @@ #:fail #:on-fail #:simple-plan-failure #:plan-failure - #:with-failure-handling #:retry + #:with-failure-handling #:with-transformative-failure-handling #:retry #:with-retry-counters #:do-retry #:reset-counter #:get-counter #:common-lisp-error-envelope #:envelop-error @@ -171,6 +171,7 @@ #:with-task-tree-node #:make-task-tree-node #:replaceable-function + #:replace-task-code #:make-task #:sub-task #:task @@ -222,6 +223,8 @@ #:log-enable #:log-disable #:log-set + ;; task tree utils + #:clear-illegal-function-names ;; tasks #:name #:*save-tasks* diff --git a/cram_language/src/tasks/failures.lisp b/cram_language/src/tasks/failures.lisp index 2181d55..189fdd7 100644 --- a/cram_language/src/tasks/failures.lisp +++ b/cram_language/src/tasks/failures.lisp @@ -37,7 +37,10 @@ "Indicates if the debugger should be entered at the location where a common lisp error is raised.") -(define-condition plan-failure (serious-condition) () +(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 +103,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 +126,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 +148,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 +192,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..604a0cd 100644 --- a/cram_language/src/tasks/task-tree.lisp +++ b/cram_language/src/tasks/task-tree.lisp @@ -185,6 +185,8 @@ :run-thread nil :path path))) ((executed (code-task code)) + (evaporate (code-task code)) + (setf (code-task code) nil) (make-task :name name :sexp sexp :function function @@ -221,9 +223,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 +234,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) @@ -253,7 +255,11 @@ (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." + "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.)" (let ((node (ensure-tree-node path task-tree))) (sb-thread:with-mutex ((task-tree-node-lock node)) (push (make-code :sexp sexp :function function) @@ -286,6 +292,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 +363,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 From 6ef57fc93f9bf05d89382fb6d50b4c10f4b2bdb6 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Mon, 29 Jun 2015 14:58:40 +0200 Subject: [PATCH 02/11] Defined the with-transformative-tryouts macro and auxiliaries. --- cram_language/src/packages.lisp | 2 + cram_language/src/tasks/task.lisp | 3 ++ cram_projection/src/package.lisp | 3 ++ .../src/projection-environment.lisp | 37 +++++++++++++++++++ 4 files changed, 45 insertions(+) diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index d6ce6be..a33350a 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -187,6 +187,8 @@ #:goal-task-tree-node-pattern #:goal-task-tree-node-parameter-bindings #:goal-task-tree-node-goal + #:*in-projection-environment* + #:*projection-signal-data* ;; base.lisp #:top-level #:seq #:par #:tag #:with-tags #:with-task-suspended #:par-loop 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))))) From 20bb90db36256cc3b67a46d993a081046ce2ce1f Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Mon, 29 Jun 2015 15:35:07 +0200 Subject: [PATCH 03/11] Exported *retry-path*. --- cram_language/src/packages.lisp | 1 + cram_language/src/tasks/failures.lisp | 2 ++ 2 files changed, 3 insertions(+) diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index a33350a..f1b1175 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -189,6 +189,7 @@ #: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 diff --git a/cram_language/src/tasks/failures.lisp b/cram_language/src/tasks/failures.lisp index 189fdd7..f86484a 100644 --- a/cram_language/src/tasks/failures.lisp +++ b/cram_language/src/tasks/failures.lisp @@ -37,6 +37,8 @@ "Indicates if the debugger should be entered at the location where a common lisp error is raised.") +(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 From c3b051d8b0fadcacfdb54ac5225ed5567d417625 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Tue, 30 Jun 2015 16:43:25 +0200 Subject: [PATCH 04/11] Created latch fluent. --- cram_language/cram-language.asd | 1 + cram_language/src/packages.lisp | 2 ++ 2 files changed, 3 insertions(+) diff --git a/cram_language/cram-language.asd b/cram_language/cram-language.asd index 1b62864..d480547 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 diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index f1b1175..b96b46a 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -93,6 +93,8 @@ ;; fluent.lisp #:fluent #:value-fluent + #:latch-fluent + #:setup-latch-fluent #:value #:peek-value #:wait-for From b58a40e6c6065be0fc395a0afddd7ce055a0c842 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Wed, 1 Jul 2015 11:17:20 +0200 Subject: [PATCH 05/11] Created accumulator fluent. --- cram_language/src/packages.lisp | 1 + 1 file changed, 1 insertion(+) diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index b96b46a..45fb606 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -95,6 +95,7 @@ #:value-fluent #:latch-fluent #:setup-latch-fluent + #:setup-accumulator-fluent #:value #:peek-value #:wait-for From 259879167458d2f4882f754789a7016b2c92cbc2 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Wed, 1 Jul 2015 13:10:10 +0200 Subject: [PATCH 06/11] Added latch-fluent file. --- cram_language/src/fluents/latch-fluent.lisp | 83 +++++++++++++++++++++ 1 file changed, 83 insertions(+) create mode 100644 cram_language/src/fluents/latch-fluent.lisp 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)) + From 588530237f3d92d55e65e3bd0c7ca61eba5871f1 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Wed, 8 Jul 2015 15:55:48 +0200 Subject: [PATCH 07/11] Added compile time parameters. --- cram_language/src/packages.lisp | 4 +- cram_language/src/plans.lisp | 52 ++++++++++++++++++++++++- cram_language/src/tasks/task-tree.lisp | 53 ++++++++++++++++++++++---- 3 files changed, 99 insertions(+), 10 deletions(-) diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index 45fb606..b1c209c 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -152,6 +152,7 @@ #:fail #:on-fail #:simple-plan-failure #:plan-failure + #: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 @@ -175,6 +176,7 @@ #:make-task-tree-node #:replaceable-function #:replace-task-code + #:get-ptr-parameter #:make-task #:sub-task #:task @@ -204,7 +206,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)) diff --git a/cram_language/src/plans.lisp b/cram_language/src/plans.lisp index 1ec40e6..2497887 100644 --- a/cram_language/src/plans.lisp +++ b/cram_language/src/plans.lisp @@ -67,7 +67,7 @@ (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) @@ -85,6 +85,56 @@ (with-tags ,@body-forms))))))) +(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. + + Note that the function defined in &body sees a lambda list from which the + ptr-parameter has been removed. As a result, functions that are compatible + to replace a ptr-cram-function have lambda lists that are one shorter than + the ptr-cram-function. Example: + + (def-ptr-cram-function example-ptr (ptr-param X Y Z) &body) + + (defun compatible-ptr-replacement (X Y Z) &body) + + However, when called inside the plan, supply the ptr-param like so: + + (... + (example-ptr \"A value\" X Y Z) + ...) + + Since ptr-parameter is not actually passed as a parameter to the forms in + &body, it needs to be accessible in another way. This is done by: + + (cpl-impl:get-ptr-parameter)" + (with-gensyms (call-args) + (multiple-value-bind (body-forms declarations doc-string) + (parse-body body :documentation t) + (let* ((lambda-list-cdr (cdr lambda-list))) + `(progn + (eval-when (:load-toplevel) + (setf (get ',name 'plan-type) :plan) + (setf (get ',name 'plan-lambda-list) ',lambda-list-cdr) + (setf (get ',name 'plan-sexp) ',body)) + (defun ,name (&rest ,call-args) + ,doc-string + ,@declarations + (let* ((inner-call-args (cdr ,call-args)) + (ptr-parameter (car ,call-args))) + (replaceable-ptr-function ,name ,lambda-list-cdr inner-call-args (list ',name) ptr-parameter + (with-tags + ,@body-forms))))))))) + (defmacro def-plan (name lambda-list &rest body) (style-warn 'simple-style-warning :format-control "Use of deprecated form DEF-PLAN. Please use DEF-CRAM-FUNCTION instead.") diff --git a/cram_language/src/tasks/task-tree.lisp b/cram_language/src/tasks/task-tree.lisp index 604a0cd..692dd79 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 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,7 @@ (let ((,task (make-task :name ',(gensym (format nil "[~a]-" name)) :sexp ',(or sexp body) + :ptr-parameter ,ptr-parameter :function (lambda ,lambda-list ,@body) :parameters ,parameters))) @@ -140,6 +142,31 @@ :parameters ,parameters) ,@body)) +(defmacro replaceable-ptr-function (name lambda-list parameters path-part ptr-parameter + &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." + `(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 + :ptr-parameter ,ptr-parameter + :parameters ,parameters) + ,@body)) + (defun execute-task-tree-node (node) (let ((code (task-tree-node-effective-code node))) (assert code) @@ -159,6 +186,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,9 +202,10 @@ (sexp nil) (function nil) (path *current-path*) + (ptr-parameter 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))) (cond ((not (code-task code)) @@ -190,6 +224,7 @@ (make-task :name name :sexp sexp :function function + :ptr-parameter ptr-parameter :path `(,(path-next-iteration (car path)) . ,(cdr path)) :parameters parameters)) (t @@ -254,18 +289,19 @@ (worker (cdr path) child current-path)))))) (worker (reverse path) task-tree nil))) -(defun replace-task-code (sexp function path &optional (task-tree *task-tree*)) +(defun replace-task-code (sexp function path &key (ptr-parameter nil) (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.)" +running. Use the ptr-parameter slot when you want plan transformation to supply parameters to functions.)" (let ((node (ensure-tree-node path task-tree))) (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 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 @@ -277,11 +313,12 @@ running.)" (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) From d1eee71051c3b3258c9f8aeb1b0e1270c008f205 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Thu, 9 Jul 2015 13:25:57 +0200 Subject: [PATCH 08/11] Added ptr-language.lisp and made ptr-functions a bit less weird in how they treat their lambda lists. --- cram_language/cram-language.asd | 1 + cram_language/src/packages.lisp | 2 + cram_language/src/plans.lisp | 79 ++++++++++---------------- cram_language/src/ptr-language.lisp | 54 ++++++++++++++++++ cram_language/src/tasks/task-tree.lisp | 43 ++++++++------ 5 files changed, 112 insertions(+), 67 deletions(-) create mode 100644 cram_language/src/ptr-language.lisp diff --git a/cram_language/cram-language.asd b/cram_language/cram-language.asd index d480547..443aa9b 100644 --- a/cram_language/cram-language.asd +++ b/cram_language/cram-language.asd @@ -56,6 +56,7 @@ ;; 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 "goals" :depends-on ("packages" "tasks")) (:file "fluent-operators" :depends-on ("packages" "fluents")) (:file "swank-indentation" :depends-on ("packages")))))) diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index b1c209c..7598a4f 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -159,6 +159,8 @@ #:envelop-error #:*break-on-plan-failures* #:*debug-on-lisp-errors* + ;; ptr-function versions of plan macros + #:seq-ptr ;; task-tree.lisp #:code #:code-parameters diff --git a/cram_language/src/plans.lisp b/cram_language/src/plans.lisp index 2497887..08958f7 100644 --- a/cram_language/src/plans.lisp +++ b/cram_language/src/plans.lisp @@ -65,25 +65,33 @@ :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 (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 @@ -98,42 +106,15 @@ node) then the value of the ptr-parameter slot in the newly created node is set to the value of the first parameter. - Note that the function defined in &body sees a lambda list from which the - ptr-parameter has been removed. As a result, functions that are compatible - to replace a ptr-cram-function have lambda lists that are one shorter than - the ptr-cram-function. Example: - - (def-ptr-cram-function example-ptr (ptr-param X Y Z) &body) - - (defun compatible-ptr-replacement (X Y Z) &body) - - However, when called inside the plan, supply the ptr-param like so: - - (... - (example-ptr \"A value\" X Y Z) - ...) + 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. - Since ptr-parameter is not actually passed as a parameter to the forms in - &body, it needs to be accessible in another way. This is done by: - - (cpl-impl:get-ptr-parameter)" - (with-gensyms (call-args) - (multiple-value-bind (body-forms declarations doc-string) - (parse-body body :documentation t) - (let* ((lambda-list-cdr (cdr lambda-list))) - `(progn - (eval-when (:load-toplevel) - (setf (get ',name 'plan-type) :plan) - (setf (get ',name 'plan-lambda-list) ',lambda-list-cdr) - (setf (get ',name 'plan-sexp) ',body)) - (defun ,name (&rest ,call-args) - ,doc-string - ,@declarations - (let* ((inner-call-args (cdr ,call-args)) - (ptr-parameter (car ,call-args))) - (replaceable-ptr-function ,name ,lambda-list-cdr inner-call-args (list ',name) ptr-parameter - (with-tags - ,@body-forms))))))))) + (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-language.lisp b/cram_language/src/ptr-language.lisp new file mode 100644 index 0000000..df0e049 --- /dev/null +++ b/cram_language/src/ptr-language.lisp @@ -0,0 +1,54 @@ +;;; +;;; 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. + +(def-ptr-cram-function seq-ptr (ptr-parameter) +"Run function objects from ptr-parameter in sequence. Returns the return value of the last function object. + +PTR-PARAMETER must be a list of function objects. Example: + +(list (lambda () (some-function arg-1 arg-2...)) (lambda () ...)) + +Function objects should wrap 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. + +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." + (car (last (mapcar #'funcall ptr-parameter)))) + + diff --git a/cram_language/src/tasks/task-tree.lisp b/cram_language/src/tasks/task-tree.lisp index 692dd79..e1cbd06 100644 --- a/cram_language/src/tasks/task-tree.lisp +++ b/cram_language/src/tasks/task-tree.lisp @@ -100,7 +100,7 @@ (path-part (error "Path parameter is required.")) (name "WITH-TASK-TREE-NODE") - sexp lambda-list parameters ptr-parameter + 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, ptr-parameter and parameters are optional." @@ -118,6 +118,7 @@ :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))) @@ -125,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', @@ -135,14 +147,9 @@ 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 (name lambda-list parameters path-part ptr-parameter +(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 @@ -159,13 +166,7 @@ - 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." - `(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 - :ptr-parameter ,ptr-parameter - :parameters ,parameters) - ,@body)) + `(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))) @@ -203,19 +204,24 @@ (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 :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)) @@ -225,6 +231,7 @@ :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 From f2e99c8741880f5f7a7983b91de8daf6a40a5a29 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Thu, 9 Jul 2015 13:46:09 +0200 Subject: [PATCH 09/11] Changed the default ptr-parameter behavior in replace-task-code: now takes the previously effective ptr-parameter as a default. --- cram_language/src/tasks/task-tree.lisp | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/cram_language/src/tasks/task-tree.lisp b/cram_language/src/tasks/task-tree.lisp index e1cbd06..54ae34b 100644 --- a/cram_language/src/tasks/task-tree.lisp +++ b/cram_language/src/tasks/task-tree.lisp @@ -296,15 +296,19 @@ (worker (cdr path) child current-path)))))) (worker (reverse path) task-tree nil))) -(defun replace-task-code (sexp function path &key (ptr-parameter nil) (task-tree *task-tree*)) +(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))) + (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 :ptr-parameter ptr-parameter) + (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 From 835bbef45f5df72e3af08bf15cef70f7f721a73c Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Thu, 9 Jul 2015 17:37:31 +0200 Subject: [PATCH 10/11] Added ptr-versions for some cram-language macros, and fixed a loop bug in the ptr implementation. --- cram_language/src/packages.lisp | 5 +- cram_language/src/ptr-language.lisp | 142 +++++++++++++++++++++++-- cram_language/src/tasks/task-tree.lisp | 2 - cram_reasoning/src/fact-groups.lisp | 2 +- 4 files changed, 141 insertions(+), 10 deletions(-) diff --git a/cram_language/src/packages.lisp b/cram_language/src/packages.lisp index 7598a4f..eef9e7a 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -160,7 +160,10 @@ #:*break-on-plan-failures* #:*debug-on-lisp-errors* ;; ptr-function versions of plan macros - #:seq-ptr + #:ptr-seq + #:ptr-try-in-order + #:ptr-with-task-suspended + #:ptr-try-each-in-order ;; task-tree.lisp #:code #:code-parameters diff --git a/cram_language/src/ptr-language.lisp b/cram_language/src/ptr-language.lisp index df0e049..ad9e4df 100644 --- a/cram_language/src/ptr-language.lisp +++ b/cram_language/src/ptr-language.lisp @@ -35,7 +35,11 @@ ;;; 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. -(def-ptr-cram-function seq-ptr (ptr-parameter) +;;; 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. + +(def-ptr-cram-function ptr-seq (ptr-parameter) "Run function objects from ptr-parameter in sequence. Returns the return value of the last function object. PTR-PARAMETER must be a list of function objects. Example: @@ -44,11 +48,137 @@ PTR-PARAMETER must be a list of function objects. Example: Function objects should wrap 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. - -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." +Will fail as soon as one of the function objects produces a failure." (car (last (mapcar #'funcall ptr-parameter)))) +(def-ptr-cram-function ptr-try-in-order (ptr-parameter) + "PTR-PARAMETER must be a list of function objects. Example: + + (list (lambda () (some-function arg-1 arg-2...)) (lambda () ...)) + + Execute function objects in ptr-parameter sequentially. Succeed if one succeeds, fail if all fail. + + 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 (form) + (block tryout-block + (with-failure-handling + ((plan-failure (err) + (setf failures (cons err failures)) + (return-from tryout-block))) + (return-from ablock (funcall form))))) + ptr-parameter) + (assert-no-returning + (signal + (make-condition 'composite-failure + :failures (reverse failures))))))) + +(def-ptr-cram-function ptr-with-task-suspended (ptr-parameter task &key reason) + "PTR-PARAMETER must be a list of function objects. Example: + + (list (lambda () (some-function arg-1 arg-2...)) (lambda () ...)) + + Execute function objects in ptr-parameter 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 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 #'funcall ptr-parameter)))) + (wake-up task-sym) + retq)))) + +(def-ptr-cram-function ptr-try-each-in-order (ptr-parameter) + "PTR-PARAMETER must be a list containing (function-object list) + + The function object must have a lambda list with exactly one + argument. Example: + + (lambda (arg) ...) + + Applies function-object to each element in `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. + + NOTE: there's a difference here to the try-each-in-order macro: + rather than bind the element of list to some global variable, it + is passed as a parameter to function-object. If you do want to + bind the element to a global variable, you'd need something like: + + (ptr-try-each-in-order + (list + (lambda (arg) + (setf global-variable arg) + (some-function)) + list-of-options))" + (block ablock + (let* ((failures (list)) + (opt-list (second ptr-parameter)) + (function-object (first 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 (funcall function-object arg)))))))) + +;;;; TODO: implement ptr-functions of the following: + +;;(def-plan-macro with-task ((&key (class 'task) (name "WITH-TASK")) &body body) +;; "Executes body in a separate task and joins it." ...) + +;;(defmacro with-parallel-childs (name (running done failed) child-forms +;; &body watcher-body) +;; "Execute `child-forms' in parallel and execute `watcher-body' +;; whenever any child changes its status. +;; +;; Lexical bindings are established for `running', `done' and `failed' +;; around `watcher-body', and bound to lists of all running, done and +;; failed tasks. `watcher-body' is executed within an implicit block +;; named NIL. +;; +;; `name' is supposed to be the name of the plan-macro that's +;; implemented on top of WITH-PARALLEL-CHILDS. `name' will be used to +;; name the tasks spawned for `child-forms'. +;; +;; All spawned child tasks will be terminated on leave." ...) + +;;(def-plan-macro par (&body forms) +;; "Executes forms in parallel. Fails if one fails. Succeeds if all +;; succeed." ...) + +;;(def-plan-macro pursue (&body forms) +;; "Execute forms in parallel. Succeed if one succeeds, fail if one +;; fails." ...) + +;;(def-plan-macro try-all (&body forms) +;; "Try forms in parallel. Succeed if one succeeds, fail if all fail. +;; In the case of a failure, a condition of type 'composite-failure' +;; is signaled, containing the list of all error messages and data." ...) + +;;(def-plan-macro partial-order ((&body steps) &body orderings) +;; "Specify ordering constraints for `steps'. `steps' are executed in +;;an implicit PAR form. `orderings' is a list of orderings. An ordering +;;always has the form: +;; +;; (:order ) +;; +;;`constraining-task' and `constrained-task' are task objects. That +;;means, they can be either be defined in the current lexical +;;environment (over a :tag) or by either using the function TASK to +;;reference the task by its absolute path or the function SUB-TASK to +;;reference it by its path relative to the PARTIAL-ORDER form." ...) +;;(def-plan-macro par-loop ((var sequence) &body body) +;; "Executes body in parallel for each `var' in `sequence'." ...) diff --git a/cram_language/src/tasks/task-tree.lisp b/cram_language/src/tasks/task-tree.lisp index 54ae34b..fd7769c 100644 --- a/cram_language/src/tasks/task-tree.lisp +++ b/cram_language/src/tasks/task-tree.lisp @@ -225,8 +225,6 @@ :run-thread nil :path path))) ((executed (code-task code)) - (evaporate (code-task code)) - (setf (code-task code) nil) (make-task :name name :sexp sexp :function function 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 From b686e1411ca78e73dbdb1a1d8522c171c648d8f6 Mon Sep 17 00:00:00 2001 From: Mihai Pomarlan Date: Tue, 1 Sep 2015 17:39:35 +0200 Subject: [PATCH 11/11] Added function versions of some CRAM control flow macros and a new version for goal handling that allows more recipes for the same goal pattern, with scores for each recipe to rank and order how they are attempted. --- cram_language/cram-language.asd | 1 + cram_language/src/packages.lisp | 52 ++ cram_language/src/ptr-goals.lisp | 507 ++++++++++++++ cram_language/src/ptr-language.lisp | 903 ++++++++++++++++++++++--- cram_language/src/tasks/task-tree.lisp | 6 + 5 files changed, 1380 insertions(+), 89 deletions(-) create mode 100644 cram_language/src/ptr-goals.lisp diff --git a/cram_language/cram-language.asd b/cram_language/cram-language.asd index 443aa9b..f60ba01 100644 --- a/cram_language/cram-language.asd +++ b/cram_language/cram-language.asd @@ -57,6 +57,7 @@ (: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/packages.lisp b/cram_language/src/packages.lisp index eef9e7a..d1dc5bb 100644 --- a/cram_language/src/packages.lisp +++ b/cram_language/src/packages.lisp @@ -160,10 +160,61 @@ #:*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 @@ -180,6 +231,7 @@ #:with-task-tree-node #:make-task-tree-node #:replaceable-function + #:replace-task-ptr-parameter #:replace-task-code #:get-ptr-parameter #:make-task 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 index ad9e4df..9cc98db 100644 --- a/cram_language/src/ptr-language.lisp +++ b/cram_language/src/ptr-language.lisp @@ -39,89 +39,529 @@ ;;; ptr-parameter slots in the task tree are safely serializable and/or provide a serialization mechanism for some ;;; reasonable class of function objects/closures. -(def-ptr-cram-function ptr-seq (ptr-parameter) -"Run function objects from ptr-parameter in sequence. Returns the return value of the last function object. +(defparameter *deps-result* nil "Parameter to store, for a task started inside ptr-partial-order, the results + of its deps as a list.") -PTR-PARAMETER must be a list of function objects. Example: +(defun get-deps-result () + *deps-result*) -(list (lambda () (some-function arg-1 arg-2...)) (lambda () ...)) +;;; Failure conditions -Function objects should wrap functions defined with def-[ptr-]cram-function if they are to show up in the task tree. +(define-condition ptr-failure (plan-failure) + ((message :initarg :message :initform nil :reader ptr-failure/message))) -Will fail as soon as one of the function objects produces a failure." - (car (last (mapcar #'funcall ptr-parameter)))) +(define-condition ptr-circular-partial-order (ptr-failure) + ((cdeps :initarg :cdeps :initform nil :reader ptr-failure/cdeps))) -(def-ptr-cram-function ptr-try-in-order (ptr-parameter) - "PTR-PARAMETER must be a list of function objects. Example: +(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."))) - (list (lambda () (some-function arg-1 arg-2...)) (lambda () ...)) +(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 (form) + (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 (funcall form))))) - ptr-parameter) + (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-suspended (ptr-parameter task &key reason) - "PTR-PARAMETER must be a list of function objects. Example: +(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))) - (list (lambda () (some-function arg-1 arg-2...)) (lambda () ...)) +(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 with 'task' being suspended. + 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 task) + (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 #'funcall ptr-parameter)))) + (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 must be a list containing (function-object list) + "PTR-PARAMETER is a try-each-ptr-parameter object. Slots are function-object + and options-list. - The function object must have a lambda list with exactly one - argument. Example: - - (lambda (arg) ...) + 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 `list' sequentially until + 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. - NOTE: there's a difference here to the try-each-in-order macro: - rather than bind the element of list to some global variable, it - is passed as a parameter to function-object. If you do want to - bind the element to a global variable, you'd need something like: - - (ptr-try-each-in-order - (list - (lambda (arg) - (setf global-variable arg) - (some-function)) - list-of-options))" + 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 (second ptr-parameter)) - (function-object (first ptr-parameter))) + (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 @@ -131,54 +571,339 @@ Will fail as soon as one of the function objects produces a failure." ((plan-failure (condition) (setf failures (cons condition failures)) (return-from try-block))) - (return-from ablock (funcall function-object arg)))))))) - -;;;; TODO: implement ptr-functions of the following: - -;;(def-plan-macro with-task ((&key (class 'task) (name "WITH-TASK")) &body body) -;; "Executes body in a separate task and joins it." ...) - -;;(defmacro with-parallel-childs (name (running done failed) child-forms -;; &body watcher-body) -;; "Execute `child-forms' in parallel and execute `watcher-body' -;; whenever any child changes its status. -;; -;; Lexical bindings are established for `running', `done' and `failed' -;; around `watcher-body', and bound to lists of all running, done and -;; failed tasks. `watcher-body' is executed within an implicit block -;; named NIL. -;; -;; `name' is supposed to be the name of the plan-macro that's -;; implemented on top of WITH-PARALLEL-CHILDS. `name' will be used to -;; name the tasks spawned for `child-forms'. -;; -;; All spawned child tasks will be terminated on leave." ...) - -;;(def-plan-macro par (&body forms) -;; "Executes forms in parallel. Fails if one fails. Succeeds if all -;; succeed." ...) - -;;(def-plan-macro pursue (&body forms) -;; "Execute forms in parallel. Succeed if one succeeds, fail if one -;; fails." ...) - -;;(def-plan-macro try-all (&body forms) -;; "Try forms in parallel. Succeed if one succeeds, fail if all fail. -;; In the case of a failure, a condition of type 'composite-failure' -;; is signaled, containing the list of all error messages and data." ...) - -;;(def-plan-macro partial-order ((&body steps) &body orderings) -;; "Specify ordering constraints for `steps'. `steps' are executed in -;;an implicit PAR form. `orderings' is a list of orderings. An ordering -;;always has the form: -;; -;; (:order ) -;; -;;`constraining-task' and `constrained-task' are task objects. That -;;means, they can be either be defined in the current lexical -;;environment (over a :tag) or by either using the function TASK to -;;reference the task by its absolute path or the function SUB-TASK to -;;reference it by its path relative to the PARTIAL-ORDER form." ...) - -;;(def-plan-macro par-loop ((var sequence) &body body) -;; "Executes body in parallel for each `var' in `sequence'." ...) + (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/task-tree.lisp b/cram_language/src/tasks/task-tree.lisp index fd7769c..ea15824 100644 --- a/cram_language/src/tasks/task-tree.lisp +++ b/cram_language/src/tasks/task-tree.lisp @@ -294,6 +294,12 @@ (worker (cdr path) child current-path)))))) (worker (reverse path) task-tree nil))) +(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.