;; -*- Mode: LISP; Syntax: Common-lisp; Package: LOOM; Base: 10. -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                             ;
;  Copyright (c) 1988, 1995, 1999 by the University of Southern California    ;
;  All rights reserved.                                                       ;
;                                                                             ;
;  Permission to use, copy, modify, and distribute this software and its      ;
;  documentation in source and binary forms for non-commercial purposes       ;
;  and without fee is hereby granted, provided that this notice               ;
;  be reproduced in any copy or modification thereof, and that                ;
;  any documentation, advertising materials, and other materials related      ;
;  to such distribution and use acknowledge that the software was             ;
;  developed by the University of Southern California, Information            ;
;  Sciences Institute.  The name of the University may not be used to         ;
;  endorse or promote products derived from this software without             ;
;  specific prior written permission.                                         ;
;                                                                             ;
;  THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT THE   ;
;  SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS PROVIDED   ;
;  "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,          ;
;  WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND          ;
;  FITNESS FOR A PARTICULAR PURPOSE.                                          ;
;                                                                             ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; TASKS (ABOX)

(in-package "LOOM")

(export '( perform fail perform-task
	  schedule schedule-task scheduled-p 
	  undo-task kill-task
	  initialize-tasks list-tasks
;	  perform-all
	  ))

;;; Functions which implement the LOOM task facility


  ;;
;;;;;; "perform", "perform-task", "fail"
  ;;

;;; The perform functions define the heart of the task performance
;;;    mechanism; "meta-rule" reasoning used to select which
;;;    operator-method to execute occurs here.

(defmacro perform ((actionName &rest arguments) &key (returnType :value) undoable-p)
  ;; Apply action named "actionName" to the arguments "arguments";
  ;; Return either a value, a success predicate, or a task object, depending
  ;;    on whether "returnType" is :value, :success-p, or :task;
  ;; If "returnType" equals :task, or if "undoable-p" is set, create a task
  ;;    object representing the task to be performed;
  ;; If "undoable-p", start an undo log if one is not already started;
  (cond
    ((or undoable-p (eq returnType :task)) 
     `(perform-task
	(make-loom-instance 'TASK		; DGB 8/29/90
			    :action (get-action ',actionName :no-error-p nil)
			    :arguments (list ,@arguments))
	,returnType))
    ((eq returnType :success-p)
     `(multiple-value-bind (value successP)
	  (apply-action
;	    (get-action ',actionName :no-error-p nil)	; rmm 6/8/89
	    ',actionName			;  dgb 6/13/89 (quote)
	    (list ,@arguments))
        (declare (ignore value))
	successP))
    (t						; (eq returnType :value)
     `(apply-action
	',actionName				; rmm 6/8/89, dgb 6/13/89 (quote)
	(list ,@arguments)))) )

(defmacro fail (&optional result)
  ;; Expand into a throw to the tag "failed-method-catcher";
  ;; Called from within a method when it can't succeeed;
  ;; Return "result" as the value of the failed method;
  `(throw 'failed-method-catcher ,result) )

(defun perform-task (task returnOption)
  ;; Perform task "task";
  ;; "returnOption" takes values :value, :success-p, or :task,
  ;;    and indicates what sort of value the task should return;
  (when *current-task*
      (add-link super-task task *current-task*))
  (setf *current-task* task)
  ;; push "task" onto undo log if it is undoable;
  (when (undoable-p task)
      (push task *undo-log*))
  (multiple-value-bind (value successP)
      (apply-action (action task) (arguments task))
    (setf (value task) value)
    (setf (success-p task) successP)
    (setf (status task) :completed)
    (setq *current-task* (super-task task))	; nil if no super task
    (ecase returnOption
      (:success-p successP)
      (:task task)
      (:value value))) )


  ;;
;;;;;; task priority queues
  ;;

;;; These are low-level routines for manipulating the entries in
;;;    the task priority queues.

(defun initialize-tasks ()
  ;; Clear task queues and current task variable;
  (setq *task-queue-table*
	(loop for p in *task-priorities* collect (list p)))
  (setq *current-task* nil) )

#+CLTL2 (declaim (inline create-task enqueue-task select-next-task
			 where-is-task delete-task))
#-CLTL2 (proclaim '(inline create-task enqueue-task select-next-task
			   where-is-task delete-task))

(defun create-task (arguments action goalPredicate priority &key undoable-p)
  ;; Create and fill-in a (pending) task;
  (make-loom-instance				; DGB 8/29/90
    'TASK
    :arguments arguments
    :action action
    :goal-predicate goalPredicate
    :priority priority
    :undoable-p undoable-p
    :status :pending) )

(defun enqueue-task (task priority)
  ;; Place "task" on the queue indicated by "priority";
  ;; An individual queue is a list containing a priority symbol and
  ;;    zero or move task instantiations;
  ;; The current methodBody places new tasks at the ends of queues;
  ;;    A more sophisticated methodBody will make this behavior
  ;;    optional;
  ;; TO DO: IF DUPLICATE EXISTS, REMOVE IT (LOGICALLY, OR PHYSICALLY
  ;;     IF IT HAS DIFFERENT PRIORITY)
  (let ((queue (assoc (or priority *default-task-priority*)
		      *task-queue-table*)))
    (setf (cdr (last queue))
	  (list task)) ) )
    
(defun select-next-task ()
  ;; Return the task having highest priority;
  ;; Currently, this the task at the front of the highest priority
  ;;    non-empty queue;
  ;; Return nil if *current-task* has higher priority than anything
  ;;    else on the queue;
  ;; TO DO: IMPLEMENT MEANS FOR SUSPENDING TASK AND WAKING IT UP WHEN
  ;;    SUBTASKS COMPLETE.  MEANWHILE, WE DON'T RUN SUBTASKS UNTIL
  ;;    SUPER TASK FINISHES;
  (when *current-task*
    ;; WE DON'T HANDLE RECURSIVE SCHEDULING YET:
    (return-from select-next-task nil))
  (let (nextTask)
    (loop for queue in *task-queue-table*
	 do
	 (when (setq nextTask (pop (cdr queue)))
	     (return nextTask))) ))

(defun list-tasks (&key priorities)
  "Return a list of the task queues having the specified `priorites',
or all task queues if `priorites' is not supplied.  Each task queue
is a list of the form (<priority> <task>*), where priority is currently
either :high or :low."
  (setq priorities (list-of priorities))
  (if priorities
      (loop for queue in *task-queue-table*
	    when (member (first queue) priorities)
	    collect queue)
      *task-queue-table*) )

(defun where-is-task (task)
  ;; Return the queue containing "task", or nil if its not scheduled;
  (loop for queue in *task-queue-table*
       when (member task queue)
       return queue) )
       
(defun delete-task (task)
  ;; Find "task" and remove it;
  ;; Return "task" if deletion actually occurred;
  (loop for queue on *task-queue-table* by #'cdr
      when (member task (car queue))
      do (delf (car queue) task)
      and return task) )


  ;;
;;;;;; "schedule", "schedule-task", "perform-all", "kill-task"
  ;;

;;; These routines are called to create and schedule tasks
;;;    onto the task priority queues, and to perform them.

(defmacro schedule ((actionName &rest arguments) &key undoable-p priority)
  ;; Create and schedule a task which will apply the action named
  ;;    "actionName" to the arguments "arguments";
  ;; Return the new task object;
  ;; Set the task's priority to "priority";
  ;; If "undoable-p", start an undo log if one is not already started;
  `(schedule-task
     (create-task
       (list ,@arguments)
       (get-action ',actionName)
       nil					; no goal predicate
       ,(cond     ; ensure that a non-nil priority is passed on to "create-task":
	 ((null priority) `',*default-task-priority*)
	 ((member priority *task-priorities*) `',priority)
	 (t priority))				; assume "priority" is a variable
       :undoable-p ,undoable-p)) )

(defun schedule-task (task)
  ;; Place "task" on the appropriate queue, and return it;
  (enqueue-task task (priority task))
  (when (or (null *current-task*)
	    nil ; (higher-priority-p task *current-task*) <= IMPLEMENT OR REMOVE
	    )
    (setq *higher-priority-task-is-pending-p* t
          *match-is-pending-p* t))      ;  TAR 8/8/94 ; Make sure we advance time & run task
  task )

(defun scheduled-p (task)
  ;; Return t if "task" is still scheduled;
  (where-is-task task) )

(defun kill-task (task)
  ;; Remove "task" from a task queue, if its still there;
  ;; Return "task" if deletion actually occurred;
  (when (delete-task task)
    (setf (status task) :killed)
    task) )

;; THIS HAS BEEN REPLACED BY "match&perform-all":
;(defun perform-all ()
;  ;; Perform all tasks on all task queues;
;  ;; Note: new tasks may be scheduled during this process -- these get
;  ;;    performed as well;
;  (let (nextTask)
;    (loop
;       (setq nextTask (select-next-task))
;       (when (null nextTask)
;	   (return nil))				; exit loop
;       ;; found a task to perform
;       (perform-task nextTask :success-p)	; :success-p makes "perform-task" happy
;       ) ; end loop
;    (setq *current-task* nil) ))


  ;;
;;;;;; "undo-task"
  ;;

;;; The undo operation is performed by restoring database instances
;;;    to have values indicated in the *undo-log*;  The undo log is rolled
;;;    back to the point where a specific task object was positioned;

;;; An undo log entry is either a task, or a list with one of the following forms:
;;;    (:old-fillers instance role fillers)
;;;    (:new-link instance role filler)
;;;    (:old-link instance role filler)
;;;    (:old-conjuncts instance conjuncts)
;;;    (:old-features instance features)
;;;    (:interned instance)
;;;    (:uninterned instance)

(defun undo-task (task)
  ;; Undo the database modifications that occurred during the
  ;;    execution of "task", and rerun the matcher;
  ;; (1) Verify that task is not shadowed within the task log;
  ;; (2) Roll back log entries until "task" is found;
  ;; (3) Remove "task" from the task log;
  (let (undoneInstances)
    ;; NOT YET IMPLEMENTED: VALIDATE CHOICE OF TASK
;    (loop for tail on *undo-log*
;       do
;       (let ((entry (car tail)))
;	 (cond
;	   ((consp entry)			; undo a log entry
;	    (pushnew (apply-undo entry) undoneInstances))
;	   ((eq entry task)			; found "task" in log
;	    (setq *undo-log* (cdr tail))	; remove "task" from log
;	    (return nil)))			; exit loop
;	 ))
    (loop for i in undoneInstances
	 when i
	 do
	 (post-non-analyzable-modified-instance i :retraction nil))
    (rerecognize-instances)					; CONSIDER DISABLING RULES
    ;; remove task from *task-log*
    (cond
      ((super-task task)
       (del-link super-task task (super-task task)))
      (t					; "task" is top-level in task log
       (setq *task-log* nil))) ))

;(defun undo-log-entry (logEntry)
;  ;; Restore the database as indicated in "logEntry";
;  ;; Return an instance whose values where modified (or nil if an
;  ;;    instance that was created is now being destroyed;
;  ;; "logEntry" is a list whose first value is a keyword indicating
;  ;;    what kind of update was logged;
;  (let ((instance (second logEntry)))
;    (ecase (car logEntry)
;      (:fillers					; role with no inverse
;       (set-slot-value instance (third logEntry) (fourth logEntry))
;       instance)
;      (:new-link
;       "NOT YET IMPLEMENTED")
;      (:old-link
;       "NOT YET IMPLEMENTED")
;      (:old-conjuncts
;       ;; THIS IS PROBABLY BOGUS:
;       (setf (conjuncts-table instance) (third logEntry))
;       instance)
;      (:old-features				; MAYBE FEATURES NEED TO BE CLASSFIED???
;       (setf (asserted-features instance) (third logEntry))
;       instance)
;      (:interned
;       ;; destroy previously-created object
;       (unintern-object instance :instances *context*)
;       nil)
;      (:uninterned
;       ;; recreate previously-destroyed object
;       (intern-object (name instance) instance :instances *context*)
;       instance)) ))


;;; TO DO:

#|

IMPLEMENT MEANS FOR SUSPENDING TASK AND WAKING IT UP WHEN
   SUBTASKS COMPLETE.  MEANWHILE, WE DON'T RUN SUBTASKS UNTIL
   SUPER TASK FINISHES;

|#
