;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File - tasks
;; Description - Tasks implementation using structure trees
;; Author - Gail Anderson (ga at HELLESVEAN)
;; Created On - Mon Feb 14 22:19:53 2000
;; Last Modified On - Thu Apr 26 23:01:18 2001
;; Last Modified By - Gail Anderson (ga at HELLESVEAN)
;; Update Count - 293
;; Status - Unknown
;;
;; $Id: tasks.lisp,v 1.1.1.1 2002/12/12 02:15:47 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cl:in-package :tasks)
;;; Part 1 : Parameters
;;; the character used to separate parts of a task name
(defparameter *task-sep-char* #\/)
;;; Part 2 : Names for tasks
;;; Assuming the default *task-sep-char* (/): The name is a string
;;; beginning with a /; the name is a path through the task tree. The
;;; root of the global task tree is referred to as /, and all tasks
;;; can be supertasks of new tasks. So for example, if a task is
;;; called "/projects/teaching/lisp" then it is a subtask of
;;; "/projects/teaching" which is itself a subtask of "/projects"
;;; which is a subtask of the root task, "/". If two or more
;;; occurrences of the *task-sep-char* appear onsecutively in the
;;; name, with no other characters in between (e.g. "/a//b"), then all
;;; consecutive occurrences are treated as one. Therefore "/a//b" is
;;; the same name as "/a/b". Similarly final trailing occurrences of
;;; the *task-sep-char* are ignored e.g. "/a/b/" is the same as
;;; "/a/b".
;;; Parses a task name as follows:
;;; e.g. "/abc/def/ghi" becomes ("abc" "def" "ghi")
(defun parse-name (name &key (schar *task-sep-char*))
(labels
((pn (togo hc tc hg tg)
;; togo is the part of the name still to be parsed (initially
;; argument name to parse-name)
;; hc and tc are the head and tail of a list containing the
;; characters in the part of the name currently being parsed;
;; hg and tg are the head and tail of the parsed name, as it
;; is in the process of being parsed;
(cond ((and (null togo) (null hc) (null hg)) '())
((and (null togo) (null hg)) (list (coerce hc 'string)))
((and (null togo) (null hc)) hg)
((null togo) (setf (cdr tg) (list (coerce hc 'string))) hg)
((and (eq (first togo) schar) (null hc)) (pn (rest togo) hc tc hg tg))
((and (eq (first togo) schar))
(let ((dn (list (coerce hc 'string))))
(if (null hg)
(pn (rest togo) '() '() dn dn)
(pn (rest togo) '() '() hg (setf (cdr tg) dn)))))
(t (let ((dn (list (first togo))))
(if (null hc)
(pn (rest togo) dn dn hg tg)
(pn (rest togo) hc (setf (cdr tc) dn) hg tg)))))))
(if (eq (elt name 0) schar)
(pn (coerce name 'list) '() '() '() '())
(error "Name must begin with separation character ~C" schar))))
;;; Returns t if name sub is a subtask of name super; argument
;;; n specifies how many generations apart they are;
;;; a name is a 0th generation supertask of itself
;;; e.g. (subtasknamep '("abc") '("abc" "def") :n 1) => t
;;; (subtasknamep '("abc") '("abc" "def") :n 2) => nil
;;; (subtasknamep '("abc") '("abc" "def" "ghi") :n 2) => t
;;; (subtasknamep '("abc") '("abc") :n 0) => t
(defun subtasknamep (super sub &key (n 1))
(cond ((null sub) nil)
((null super) (= n (length sub)))
((and (equalp super sub) (= n 0)) t)
((equalp (first super) (first sub))
(subtasknamep (rest super) (rest sub) :n n))))
;;; Returns the name of the supertask of name sub
;;; n is how many generations back to go
(defun supertaskname (sub &key (n 1))
(cond ((= (length sub) n) '())
((null sub) (error "Not enough generations"))
(t (cons (first sub) (supertaskname (rest sub) :n n)))))
;;; Returns a new subtask name constructed from name super and
;;; partial name part
(defun make-subtaskname (super part)
(append super part))
;;; Outputs a task name as a string, e.g. (assuming the default *task-sep-char*):
;; (output-name '("abc" "def" "ghi")) => "/abc/def/ghi")
(defun output-name (name &key (schar *task-sep-char*))
(labels ((nm-list (name)
(if (null name)
'()
(append (list schar) (coerce (first name) 'list) (nm-list (rest name))))))
(if (null name)
'"/"
(coerce (nm-list name) 'string))))
;;; Top level structure type for tasks. Assumes clients are just
;;; strings - of course they could be complex data structures
;;; If a task doesn't have a client specified, it inherits its client
;;; from its parent task
;;;
;;; Tasks have a value slot which is available for applications to use:
;;; for example, if using a tasks in a timesheet application, it might
;;; make sense to store a cons of two integers, representing hours and
;;; minutes, in the value slot
(defstruct task
(pname '()) ; parsed name
(client "")
(value nil))
(defun task-name (task)
(output-name (task-pname task)))
;;; the root of the task tree
(defparameter *tasks*
(make-tree-node :value (make-task)))
;;; Part 3 : Creating tasks
;;; Creates a new subtask of a given task
(defun add-subtask (task-node name &key (client nil) (value nil))
(let* ((parent (tree-node-value task-node))
(new-node (make-tree-node :name name))
(new-task
(make-task
:pname (make-subtaskname (task-pname parent) (list name))
:client (or client (or (task-client parent)))
:value value)))
(setf (tree-node-value new-node) new-task)
(add-child-to-tree-node task-node new-node)))
;;; Creates a new task within the given task-tree
;;; Works by finding the appropriate point in the tree to hook in the
;;; child task, comparing names with string=
(defun create-task (task-name &key (task-tree *tasks*) (client nil) (value nil))
(let ((parsed-name (parse-name task-name)))
(labels ((ct (node name client)
(if (equalp (task-pname (tree-node-value node)) parsed-name)
t
(let* ((next-name (first name))
(next-node
(or (find-tree-node-child node next-name)
(progn
(add-subtask node next-name :client client :value value)
(find-tree-node-child node next-name)))))
(ct next-node (rest name) client)))))
(ct task-tree parsed-name client))))
;;; Part 4 : Finding tasks
;;; need to make reverse pointers tasks to tree nodes
;;; need error checking
(defun find-task (task-name &key (task-tree *tasks*))
(let ((parsed-name (parse-name task-name)))
(labels ((ftt (node name)
(if (equalp (task-pname (tree-node-value node)) parsed-name)
(tree-node-value node)
(let* ((next-name (first name))
(next-node (find-tree-node-child node next-name)))
(if next-node
(ftt next-node (rest name))
(warn "no such node as ~A" next-node))))))
(ftt task-tree parsed-name))))
;;; Part 5: Printing tasks
;;; Default printing function for printing task values
(defun print-task-value (task &key (indent 4) (stream t))
(dotimes (n indent)
(princ #\space stream))
(format stream "Value: ~S ~%" (task-value task)))
;;; Prints out a single task
(defun print-task (task &key (indent 4) (stream t) (print-value #'print-task-value))
(dotimes (n indent)
(princ #\space stream))
(format stream "Name: ~S ~%" (task-name task))
(dotimes (n indent)
(princ #\space stream))
(format stream "Client: ~S~%" (task-client task))
(funcall print-value task :indent indent :stream stream)
t)
;;; Prints out all tasks from the root of a given task tree
(defun print-all-tasks (&key (nodes nil) (task-tree *tasks*) (stream t))
(print-all-tree-nodes task-tree
:printer #'print-tree-node
:print-name (if nodes #'print-tree-node-name)
:print-value
#'(lambda (n &key (stream stream))
(funcall #'print-task n
:stream stream
:indent (if nodes 4 0)))
:print-child (if nodes #'print-tree-node-child)
:stream stream))