From e8f0ce6caa4fe707aa2155dd4285eb36041cc9e2 Mon Sep 17 00:00:00 2001 From: Ben Kuehnert Date: Sun, 29 Mar 2020 19:54:54 -0400 Subject: [PATCH 1/5] integrate timegraph --- norm/macro.lisp | 12 ++ norm/norm-time.lisp | 233 ++++++++++++++-------------- norm/timegraph.lisp | 226 +++++++++++++++++++++++++++ norm/timepoint.lisp | 363 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 713 insertions(+), 121 deletions(-) create mode 100644 norm/macro.lisp create mode 100644 norm/timegraph.lisp create mode 100644 norm/timepoint.lisp diff --git a/norm/macro.lisp b/norm/macro.lisp new file mode 100644 index 0000000..086804b --- /dev/null +++ b/norm/macro.lisp @@ -0,0 +1,12 @@ +;; Graham's alambda +(defmacro alambda (parms &body body) + `(labels ((self ,parms ,@body)) + #'self)) + +;; Graham's flatten +(defun flatten (x) + (labels ((rec (x acc) + (cond ((null x) acc) + ((atom x) (cons x acc)) + (t (rec (car x) (rec (cdr x) acc)))))) + (rec x nil))) diff --git a/norm/norm-time.lisp b/norm/norm-time.lisp index 8f6d2a9..eb35c21 100644 --- a/norm/norm-time.lisp +++ b/norm/norm-time.lisp @@ -1,12 +1,7 @@ -; Include guard for load-mats.lisp, which isn't nicely -; reloadable due to constant symbol redefinitions. -(if (not (boundp 'AIA-MATS-LOADED)) - (progn (load "load-mats.lisp") (setf AIA-MATS-LOADED t))) - (load "real_util.lisp") (load "norm-el.lisp") +(load "timegraph.lisp") -(initialize-allen-arrays) ; A "time model" is a list of infix relation triples ; where the first and third elements are Lisp symbols @@ -29,57 +24,23 @@ ; (E1.SK (p m o) NOW1) ; (E2.SK (p) E3.SK) -(defparameter *TIME-PROP-ALLEN-RELS* +(defparameter *TIME-PROP-RELS* (mk-hashtable '( - ; TODO: cause.v implies (p m o), but not vice versa. - ; This should affect the certainty scores. - ( - ; prop - cause.v - ; equivalent Allen rel disjunction - (p m o) - ) - ( - consec - (m) - ) - ( - same-time - (=) - ) - ( - at-about - (d s f =) - ) - ( - before - (p m o) - ) - ( - strictly-before - (p) - ) - ( - after - (pi mi oi) - ) - ( - during - (s d f =) - ) - ( - precond-of - (p m) - ) - ( - postcond-of - (pi mi) - ) -)) -) - + (cause.v t) + (consec t) + (same-time t) + (at-about t) + (before t) + (strictly-before t) + (after t) + (during t) + (precond-of t) + (postcond-of t)))) + + (setf *TIME-MODEL-HASH* nil) (setf *TIME-MODEL* nil) +(setf *TIME-GRAPH* nil) (defun is-now? (s) (and @@ -132,38 +93,64 @@ ; BELOW HERE: Ben adds timegraph model code - ; Clear the state of the AIA solver. - (clear) + ; Clear Timegraph + (setf *TIME-GRAPH* (make-timegraph)) ; Load the relationship triples into - ; the AIA solver's internal data model. - (loop for rel in *TIME-MODEL* do (block inner - (setf allen-rel (convert-time-prop rel)) - (dbg 'time "asserting ~s~%" allen-rel) - (if (null allen-rel) - (progn - (dbg 'time "invalid temporal proposition ~s~%" rel) - (return-from outer nil) - ) - ) - - (allen-assert (car allen-rel) (second allen-rel) (third allen-rel)) - )) + ; the timegraph's internal data model. + (dolist (rel *TIME-MODEL*) + (when (time-prop? rel) + (let ((pred (prop-pred rel)) + (e1 (first (prop-all-args rel))) + (e2 (second (prop-all-args rel)))) + + (cond + ((and (or (equal pred "cause.v") + (equal pred "before")) + (not (ep-not-before-p *TIME-GRAPH* e1 e2))) + (ep-assert-before *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred "precond-of") + (equal pred "strictly-before")) + (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) + (ep-assert-precond-of *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred "at-about") + (equal pred "during")) + (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) + (ep-assert-at-about *TIME-GRAPH* e1 e2)) + + ((and (equal pred "consec") + (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) + (ep-assert-consec *TIME-GRAPH* e1 e2)) + + ((and (equal pred "same-time") + (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) + (ep-assert-equals *TIME-GRAPH* e1 e2)) + + ((and (equal pred "after") + (not (ep-not-before-p *TIME-GRAPH* e2 e1))) + (ep-assert-before *TIME-GRAPH* e2 e1)) + + ((and (equal pred "postcond-of") + (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) + (ep-assert-precond-of *TIME-GRAPH* e2 e1)) + + (t + (dbg 'time "temporal proposition ~s is inconsistent with time model ~s~%" + rel tm)))))) - ; Reduce the AIA solver's model to obtain - ; the strictest possible pairwise relations. - (allen-reduce) ) ) (defun time-pred? (p) - (not (null (gethash p *TIME-PROP-ALLEN-RELS*))) + (not (null (gethash p *TIME-PROP-RELS*))) ) -; convert-time-prop takes a temporal proposition -; and returns its equivalent Allen relation form. -(defun convert-time-prop (prop) -(block outer + +; check if temporal proposition is valid +(defun time-prop? (prop) +(block outer (setf pred (prop-pred prop)) (if (not (time-pred? pred)) @@ -171,6 +158,7 @@ (dbg 'time "~s isn't a valid temporal predicate~%" pred) (return-from outer nil) ) + ) (setf args (prop-all-args prop)) @@ -182,59 +170,62 @@ ) ) - (setf allen-rels (gethash pred *TIME-PROP-ALLEN-RELS*)) + (return-from outer t) +)) - (return-from outer (list (car args) allen-rels (second args))) -) -) +(defun eval-time-prop (prop) + (when (not (time-prop? prop)) + (dbg 'time "invalid temporal proposition ~s~%" prop) + nil) + + (let ((pred (prop-pred prop)) + (e1 (first (prop-all-args prop))) + (e2 (second (prop-all-args prop)))) + + (cond + + ((and (or (equal pred "cause.v") + (equal pred "before")) + (not (ep-not-before-p *TIME-GRAPH* e1 e2))) + (ep-before-p *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred "precond-of") + + (equal pred "strictly-before")) + + (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) + + (ep-precond-of-p *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred "at-about") + (equal pred "during")) + (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) + (ep-at-about-p *TIME-GRAPH* e1 e2)) -(defun time-prop? (p) - (not (null (convert-time-prop p))) -) + ((and (equal pred "consec") + (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) + (ep-consec-p *TIME-GRAPH* e1 e2)) -(defun eval-time-prop (prop) -; BELOW HERE: Ben evaluates using timegraph instead of Allen -(block outer - (setf allen-rel (convert-time-prop prop)) - (if (null allen-rel) - (progn - (dbg 'time "invalid temporal proposition ~s~%" prop) - (return-from outer nil) - ) - ) + ((and (equal pred "same-time") + (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) + (ep-equals-p *TIME-GRAPH* e1 e2)) - ; Evaluate the relationship in the time model. - ; (dbg 'time "evaluating Allen rel ~s~%" allen-rel) + ((and (equal pred "after") + (not (ep-not-before-p *TIME-GRAPH* e2 e1))) + (ep-before-p *TIME-GRAPH* e2 e1)) - (setf allen-result (second (allen-fhow (car args) (second args)))) + ((and (equal pred "postcond-of") + (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) + (ep-precond-of-p *TIME-GRAPH* e2 e1)) - (dbg 'time "allen result: ~s~%" allen-result) - (dbg 'time "allen rels: ~s~%" allen-rels) + (t nil)) + + ;(dbg 'time "allen result: ~s~%" allen-result) + ;(dbg 'time "allen rels: ~s~%" allen-rels) - (if (equal allen-result 'ANY) - ; This doesn't confirm the proposition, but it doesn't - ; necessarily refute it, either. - (return-from outer nil) - ) ; TODO: handle cases (via certainty scores) where ; the relationship could be an Allen relation that ; doesn't support the predicate, but it could also ; be one that supports it. - (if (not (listp allen-result)) - ; then - (if (member allen-result allen-rels :test #'equal) - ; then - (return-from outer t) - ; else - (return-from outer nil) - ) - ) - (if (subset allen-result allen-rels) - ; (if (not (null (intersection allen-result allen-rels :test #'equal))) - (return-from outer t) - ) - - (return-from outer nil) -) -) +)) diff --git a/norm/timegraph.lisp b/norm/timegraph.lisp new file mode 100644 index 0000000..51dfebc --- /dev/null +++ b/norm/timegraph.lisp @@ -0,0 +1,226 @@ +(load "timepoint.lisp") + +;;; A timegraph is a pair of hashtable. The first hashtable resolves an +;;; episode symbol to the timepoint representing the start of the +;;; episode. Similarly, the second hashtable resolves an episode symbol +;;; to the timepoint representing the end of the episode. +(defun make-timegraph () + (list (make-hash-table :test #'equal) + (make-hash-table :test #'equal))) + +; Assertion Functions +; ------------------------------------------------------------------------- + +;;; For two epsiodes e1 and e2, assert that +;;; e1.st <= e1.end = e2.st <= e2.end +(defun ep-assert-consec (tg e1 e2) + (let* ((pair1 (tp-assert-before (gethash e1 (first tg)) + (gethash e1 (second tg)))) + (pair2 (tp-assert-equals tg + (second pair1) + (gethash e2 (first tg)))) + (pair3 (tp-assert-before (second pair2) + (gethash e2 (second tg)))) + (t1 (first pair1)) + (t2 (first pair2)) + (t3 (second pair3))) + (setf (gethash e1 (first tg)) t1) + (setf (gethash e2 (first tg)) t2) + (setf (gethash e1 (second tg)) t2) + (setf (gethash e2 (second tg)) t3) + (push e1 (tp-brefs t1)) + (push e2 (tp-brefs t2)) + (push e1 (tp-erefs t2)) + (push e2 (tp-erefs t3)))) + +;;; For two epsiodes e1 and e2, assert that +;;; e1.st = e2.st && e2.end = e2.end +(defun ep-assert-equals (tg e1 e2) + (let* ((pair1 (tp-assert-equals (gethash e1 (first tg)) + tg + (gethash e2 (first tg)))) + (pair2 (tp-assert-equals tg + (gethash e1 (second tg)) + (gethash e2 (second tg)))) + (t1 (first pair1)) + (t2 (first pair2))) + (setf (gethash e1 (first tg)) t1) + (setf (gethash e2 (first tg)) t1) + (setf (gethash e1 (second tg)) t2) + (setf (gethash e2 (second tg)) t2) + (push e1 (tp-brefs t1)) + (push e2 (tp-brefs t1)) + (push e1 (tp-erefs t2)) + (push e2 (tp-erefs t2)))) + +;;; For two epsiodes e1 and e2, assert that +;;; e1.st <= e2.st && e1.st <= e1.end && e2.st <= e2.end +(defun ep-assert-before (tg e1 e2) + (let* ((pair1 (tp-assert-before (gethash e1 (first tg)) + (gethash e2 (first tg)))) + (pair2 (tp-assert-before (first pair1) + (gethash e1 (second tg)))) + (pair3 (tp-assert-before (second pair1) + (gethash e2 (second tg)))) + (t1 (first pair2)) + (t2 (second pair2)) + (t3 (first pair3)) + (t4 (second pair3))) + + (setf (gethash e1 (first tg)) t1) + (setf (gethash e2 (first tg)) t3) + (setf (gethash e1 (second tg)) t2) + (setf (gethash e2 (second tg)) t4) + (push e1 (tp-brefs t1)) + (push e2 (tp-brefs t3)) + (push e1 (tp-erefs t2)) + (push e2 (tp-erefs t4)))) + +;;; For two epsiodes e1 and e2, assert that +;;; e2.st <= e1.st <= e1.end <= e2.end +(defun ep-assert-at-about (tg e1 e2) + (let* ((pair1 (tp-assert-before (gethash e2 (first tg)) + (gethash e1 (first tg)))) + (pair2 (tp-assert-before (second pair1) + (gethash e1 (second tg)))) + (pair3 (tp-assert-before (second pair2) + (gethash e2 (second tg)))) + (t1 (first pair1)) + (t2 (first pair2)) + (t3 (first pair3)) + (t4 (second pair3))) + + (setf (gethash e1 (first tg)) t2) + (setf (gethash e2 (first tg)) t1) + (setf (gethash e1 (second tg)) t3) + (setf (gethash e2 (second tg)) t4) + (push e1 (tp-brefs t2)) + (push e2 (tp-brefs t1)) + (push e1 (tp-erefs t3)) + (push e2 (tp-erefs t4)))) + +;;; For two epsiodes e1 and e2, assert that +;;; e1.st <= e2.end <= e2.st <= e2.end +(defun ep-assert-precond-of (tg e1 e2) + (let* ((pair1 (tp-assert-before (gethash e1 (first tg)) + (gethash e1 (second tg)))) + (pair2 (tp-assert-before (second pair1) + (gethash e2 (first tg)))) + (pair3 (tp-assert-before (second pair2) + (gethash e2 (second tg)))) + (t1 (first pair1)) + (t2 (first pair2)) + (t3 (second pair2)) + (t4 (second pair3))) + + (setf (gethash e1 (first tg)) t1) + (setf (gethash e2 (first tg)) t2) + (setf (gethash e1 (second tg)) t3) + (setf (gethash e2 (second tg)) t4) + (push e1 (tp-brefs t1)) + (push e2 (tp-brefs t3)) + (push e1 (tp-erefs t2)) + (push e2 (tp-erefs t4)))) + + +; Querying functions +; ------------------------------------------------------------------------- + +(defun ep-consec-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (and (tp-before-p e1str e1end) + (tp-equals-p e1end e2str) + (tp-before-p e2str e2end)))) + +(defun ep-not-consec-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (or (tp-not-before-p e1str e1end) + (tp-not-equals-p e1end e2str) + (tp-not-before-p e2str e2end)))) + +(defun ep-equals-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (and (tp-equals-p e1str e2str) + (tp-equals-p e2end e2end)))) + +(defun ep-not-equals-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (or (tp-not-equals-p e1str e2str) + (tp-not-equals-p e1end e2end)))) + +(defun ep-before-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (and (tp-before-p e1str e2str) + (tp-before-p e1str e1end) + (tp-before-p e2str e2end)))) + +(defun ep-not-before-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (or (tp-not-before-p e1str e2str) + (tp-not-before-p e1str e1end) + (tp-not-before-p e2str e2end)))) + +(defun ep-at-about-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (and (tp-before-p e2str e1str) + (tp-before-p e1str e1end) + (tp-before-p e1end e2end)))) + +(defun ep-not-at-about-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (or (tp-not-before-p e2str e1str) + (tp-not-before-p e1str e1end) + (tp-not-before-p e1end e2end)))) + +(defun ep-precond-of-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (and (tp-before-p e1str e1end) + (tp-before-p e1end e2str) + (tp-before-p e2str e2end)))) + +(defun ep-not-precond-of-p (tg e1 e2) + (let ((e1str (gethash e1 (first tg))) + (e1end (gethash e1 (second tg))) + (e2str (gethash e2 (first tg))) + (e2end (gethash e2 (second tg)))) + + (or (tp-not-before-p e1str e1end) + (tp-not-before-p e1end e2str) + (tp-not-before-p e2str e2end)))) + diff --git a/norm/timepoint.lisp b/norm/timepoint.lisp new file mode 100644 index 0000000..451a0dc --- /dev/null +++ b/norm/timepoint.lisp @@ -0,0 +1,363 @@ +(load "macro.lisp") + +;;; * chain: Unique chain identifier. Two timepoints will have the same +;;; chain value iff they are on the same chain. +;;; +;;; * prev: Previous timepoint in the chain. +;;; +;;; * next: Next timepoint in the chain. +;;; +;;; * ptime: Pseudotime of a timepoint +;;; +;;; * inc: List of timepoints that have cross chain links into the +;;; timepoint. +;;; +;;; * out: List of timepoints that have cross chain links out of the +;;; timepoint. +;;; +;;; * upper: Numerical absolute upper bound on the timepoint. +;;; +;;; * lower: Numerical absolute lower bound on the timepoint. +;;; +;;; * refs: List of episode names which point to the timepoint. + +(defclass timepoint () + ((chain :initarg :chain + :accessor tp-chain) + (prev :initarg :prev + :accessor tp-prev) + (next :initarg :next + :accessor tp-next) + (ptime :initarg :ptime + :accessor tp-ptime) + (inc :initarg :inc + :accessor tp-inc) + (out :initarg :out + :accessor tp-out) + (upper :initarg :upper + :accessor tp-upper) + (lower :initarg :lower + :accessor tp-lower) + (brefs :initarg :brefs + :accessor tp-brefs) + (erefs :initarg :erefs + :accessor tp-erefs))) + +(defun make-timepoint (&key (chain (sxhash (gensym))) + prev next (ptime 1) in out upper lower brefs erefs) + (make-instance 'timepoint + :chain chain + :prev prev + :next next + :ptime ptime + :inc in + :out out + :upper upper + :lower lower + :brefs brefs + :erefs erefs)) + +;;; Utility Functions +;;; ----------------------------------------------------------------------- + +;;; Get list of direct successors of a timepoint t1 +(defun get-successors (t1) + (cond ((not t1) nil) + ((not (tp-next t1)) (tp-out t1)) + (t (cons (tp-next t1) (tp-out t1))))) + +;;; Get list of direct ancestors of a timepoint t1 +(defun get-ancestors (t1) + (cond ((not t1) nil) + ((not (tp-prev t1)) (tp-inc t1)) + (t (cons (tp-prev t1) (tp-inc t1))))) + +;;; Get list of all successors of a timepoint t1 +(defun get-all-successors (t1) + (flatten + (funcall + (alambda (t1 seen) + (cond ((not (gethash t1 seen)) + (setf (gethash t1 seen) t) + (cons t1 (mapcar (lambda (tk) + (self tk seen)) (get-successors t1)))))) + t1 (make-hash-table :test #'equal)))) + +;;; Get list of all ancestors of a timepoint t1 +(defun get-all-ancestors (t1) + (flatten + (funcall + (alambda (t1 seen) + (cond + ((not (gethash t1 seen)) + (setf (gethash t1 seen) t) + (cons t1 (mapcar (lambda (tk) + (self tk seen)) (get-ancestors t1)))))) + t1 (make-hash-table :test #'equal)))) + +;;; Check if a timepoint t1 is the last in its chain +(defun last-p (t1) + (not (tp-next t1))) + +;;; Check if a timepoint t1 is the first in its chain +(defun first-p (t1) + (not (tp-prev t1))) + +;;; Insertion methods +;;; ----------------------------------------------------------------------- + +;;; Given a timepoint t1, creates and returns a new timepoint which is +;;; directly after t1 in the graph. +(defun insert-timepoint-after (t1 &key brefs erefs) + (let ((ret (gensym))) + (cond + ((not t1) nil) ;;; add error message here + ((last-p t1) + (setf ret (make-timepoint + :chain (tp-chain t1) + :prev t1 + :ptime (1+ (tp-ptime t1)) + :lower (tp-lower t1) + :brefs brefs + :erefs erefs)) + (setf (tp-next t1) ret) + ret) + (t + (setf ret (make-timepoint + :in (list t1) + :lower (tp-lower t1) + :brefs brefs + :erefs erefs)) + (setf (tp-out t1) (cons ret (tp-out t1))) + ret)))) + +;;; Given a timepoint t1, creates and returns a new timepoint which is +;;; directly before t1 in the graph. +(defun insert-timepoint-before (t1 &key brefs erefs) + (let ((ret (gensym))) + (cond + ((first-p t1) + (setf ret (make-timepoint + :chain (tp-chain t1) + :next t1 + :ptime (1- (tp-ptime t1)) + :upper (tp-upper t1) + :brefs brefs + :erefs erefs)) + (setf (tp-prev t1) ret) + ret) + (t + (setf ret (make-timepoint + :out (list t1) + :upper (tp-upper t1) + :brefs brefs + :erefs erefs)) + (setf (tp-inc t1) (cons ret (tp-inc t1))) + ret)))) + +;;; t1 and t2 are timepoints (either are possibly nil), assert that t1 is +;;; before t2 and return them. Preconditions: If t1 and t2 are not nil, +;;; then it must be the case that t2 is not before t1, otherwise, the +;;; timegraph will be in a contradictory state after running this +;;; function. +(defun tp-assert-before (t1 t2) + (cond + ((tp-before-p t1 t2) + (list t1 t2)) + + ((and (not t1) (not t2)) + (let* ((t1 (make-timepoint)) + (t2 (insert-timepoint-after t1))) + (list t1 t2))) + + ((not t1) + (list (insert-timepoint-before t2) t2)) + + ((not t2) + (list t1 (insert-timepoint-after t1))) + + ((and (last-p t1) (first-p t2)) + (setf (tp-next t1) t2) + (setf (tp-prev t2) t1) + (funcall (alambda (tk ptime hash) + (when tk + (setf (tp-ptime tk) (+ ptime (tp-ptime tk))) + (setf (tp-chain tk) hash) + (self (tp-next tk) ptime hash))) + t2 (tp-ptime t1) (tp-chain t1))) + + (t + (push t2 (tp-out t1)) + (push t1 (tp-inc t2))))) + +;;; t1 and t2 are timepoints (either are possibly nil), assert that t1 is +;;; equal to t2 and return (t1 t2). Preconditions: none. Function also +;;; requires reference to a timegraph tg, since updates to the timegraph's +;;; references are needed in some cases. +(defun tp-assert-equals (tg t1 t2) + (cond + ((tp-equals-p t1 t2) + (list t1 t2)) + + ((and (not t1) (not t2)) + (let ((t1 (make-timepoint))) + (list t1 t1))) + + ((not t1) + (list t2 t2)) + + ((not t2) + (list t1 t1)) + + ((tp-before-p t1 t2) + (tp-assert-equal-helper tg t1 t2) + (list t1 t2)) + + ((tp-before-p t2 t1) + (tp-assert-equal-helper tg t2 t1) + (list t1 t2)))) + +;;; In the case that t1 and t2 exist and t2 is after t1, then in order +;;; to assert tat t1 = t2, all timepoints between t2 and t1 must be +;;; set equal to eachother (and thus equal to t1). This helper function +;;; searches for such points and updates their references with a given +;;; timegraph object tg. +(defun tp-assert-equal-helper (tg t1 t2) + (let* ((t1suc (get-all-successors t1)) + (t2anc (get-all-ancestors t2)) + (quo (intersection t1suc t2anc))) + (dolist (tk quo) + (when (tp-prev tk) + (setf (tp-inc t1) (adjoin (tp-prev tk) (tp-inc t1))) + (setf (tp-out (tp-prev tk)) (adjoin tk (tp-out (tp-prev tk)))) + (setf (tp-next (tp-prev tk)) nil)) + (when (tp-next tk) + (setf (tp-inc t1) (adjoin (tp-prev tk) (tp-inc t1))) + (setf (tp-out (tp-prev tk)) (adjoin tk (tp-out (tp-prev tk)))) + (setf (tp-prev (tp-next tk)) nil)) + + (setf (tp-inc t1) (union (tp-inc t1) + (remove-if (lambda (x) (member x quo)) + (tp-inc tk)))) + (setf (tp-out t1) (union (tp-out t1) + (remove-if (lambda (x) (member x quo)) + (tp-out tk)))) + + (setf (tp-brefs t1) (union (tp-brefs t1) (tp-brefs tk))) + (setf (tp-erefs t1) (union (tp-erefs t1) (tp-erefs tk))) + (dolist (bref (tp-brefs tk)) + (setf (gethash bref (first tg)) t1)) + (dolist (eref (tp-erefs tk)) + (setf (gethash eref (second tg)) t1))))) + +;;; Querying functions +;;; ---------------------------------------------------------------------- + +;;; Returns t if t1 is before or equal to t2. Returns nil if t1 is after +;;; t2 or there is no relation found. +(defun tp-before-p (t1 t2) + (if (or (not t1) (not t2)) + nil + (funcall + (alambda (src dst seen) + (cond + ((and (equal (tp-chain src) (tp-chain dst))) + (<= (tp-ptime src) (tp-ptime dst))) + ((not (gethash src seen)) + (setf (gethash src seen) t) + (dolist (node (get-successors src)) + (if (self node dst seen) + t))))) + t1 t2 (make-hash-table :test #'equal)))) + +;;; Returns t if and only if the timegraph contains evidence that t1 is +;;; not before t2. +(defun tp-not-before-p (t1 t2) + (and (not (equal t1 t2)) + (tp-before-p t2 t1))) + +;;; Returns t if t1 is equal to t2. Returns nil if the inference cannot be +;;; made. +(defun tp-equals-p (t1 t2) + (if (or (not t1) (not t2)) + nil + (equal t1 t2))) + +;;; Returns t if the inference that t1 is not equal to t2 can be made. +;;; Note: due to the strength of timegraph, this inference can never be +;;; made. +(defun tp-not-equals-p (t1 t2) + nil) + +;;; For two timepoints t1 and t2, compute the relation (if one exists) +;;; between the two timepoints. Possible return values are: +;;; - nil : no relation found +;;; - 1 : t1 before or equals t2 +;;; - 2 : t1 after or equals t2 +;;; - 3 : t1 equal to t2 + +(defun get-relation (t1 t2) + (cond + ((or (not t1) (not t2)) nil) + ((and (equal (tp-chain t1) (tp-chain t2)) + (< (tp-ptime t1) (tp-ptime t2))) 1) + ((and (equal (tp-chain t1) (tp-chain t2)) + (> (tp-ptime t1) (tp-ptime t2))) 2) + ((equal t1 t2) 3) + ((tp-before-p t1 t2) 1) + ((tp-before-p t2 t1) 2) + (t nil))) + + +;;; Quantitative bounds (needs some work) +;;; ---------------------------------------------------------------------- + +;(defun insert-lower-bound (t1 bound) +; (progn +; (setf (tp-lower t1) bound) +; (prop-lower-bound t1))) +; +;(defun insert-upper-bound (t1 bound) +; (progn +; (setf (tp-upper t1) bound) +; (prop-upper-bound t1))) +; +;;;; Propogate lower bound +;(defun prop-lower-bound (t1) +; (dolist (tk (get-successors t1)) +; (prop-bound-down tk (tp-lower t1)))) +; +;;;; Propogate upper bound +;(defun prop-upper-bound (t1) +; (dolist (tk (get-ancestors t1)) +; (prop-bound-up tk (tp-upper t1)))) +; +;(defun prop-bounds (t1) +; (progn +; (prop-upper-bound t1) +; (prop-lower-bound t1))) +; +;;; Propogate timebounds up +;(defun prop-bound-down (t1 bound) +; (cond +; ((not t1) nil) +; ((or (not (tp-lower t1)) (< (tp-lower t1) bound)) +; (setf (tp-lower t1) bound) +; (dolist (tk (get-successors t1)) +; (prop-bound-down tk bound))))) +; +;;;; Propogate timebounds down +;(defun prop-bound-up (t1 bound) +; (cond +; ((not t1) nil) +; ((or (not (tp-upper t1)) (> (tp-upper t1) bound)) +; (setf (tp-upper t1) bound) +; (dolist (tk (get-ancestors t1)) +; (prop-bound-up tk bound))))) + +;;; testing functions +;;; ----------------------------------------------------------------------- + +(defun print-tp (tp) + (format t "prev: ~A~%next: ~A~%links: ~A" + (tp-prev tp) (tp-next tp) (tp-out tp))) From a1e9af10055d369f75b613d4479385c08aedb704 Mon Sep 17 00:00:00 2001 From: Ben Kuehnert Date: Tue, 14 Apr 2020 12:23:49 -0400 Subject: [PATCH 2/5] add printing func --- norm/timegraph.lisp | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/norm/timegraph.lisp b/norm/timegraph.lisp index 51dfebc..81f9cd7 100644 --- a/norm/timegraph.lisp +++ b/norm/timegraph.lisp @@ -8,6 +8,15 @@ (list (make-hash-table :test #'equal) (make-hash-table :test #'equal))) +; Print Functions +; ------------------------------------------------------------------------- +(defun print-timegraph (tg) + (progn + (maphash #'print-tp (first tg)) + (maphash #'print-tp (second tg)))) + + + ; Assertion Functions ; ------------------------------------------------------------------------- @@ -24,6 +33,7 @@ (t1 (first pair1)) (t2 (first pair2)) (t3 (second pair3))) + (setf (gethash e1 (first tg)) t1) (setf (gethash e2 (first tg)) t2) (setf (gethash e1 (second tg)) t2) @@ -44,6 +54,7 @@ (gethash e2 (second tg)))) (t1 (first pair1)) (t2 (first pair2))) + (setf (gethash e1 (first tg)) t1) (setf (gethash e2 (first tg)) t1) (setf (gethash e1 (second tg)) t2) @@ -100,7 +111,7 @@ (push e2 (tp-erefs t4)))) ;;; For two epsiodes e1 and e2, assert that -;;; e1.st <= e2.end <= e2.st <= e2.end +;;; e1.st <= e1.end <= e2.st <= e2.end (defun ep-assert-precond-of (tg e1 e2) (let* ((pair1 (tp-assert-before (gethash e1 (first tg)) (gethash e1 (second tg)))) @@ -224,3 +235,5 @@ (tp-not-before-p e1end e2str) (tp-not-before-p e2str e2end)))) + + From a84acfb542ce55dafb92c13a6c6e8c30d74b2e35 Mon Sep 17 00:00:00 2001 From: Ben Kuehnert Date: Tue, 14 Apr 2020 12:24:18 -0400 Subject: [PATCH 3/5] fix bug + improve print func --- norm/timepoint.lisp | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/norm/timepoint.lisp b/norm/timepoint.lisp index 451a0dc..6d88f9b 100644 --- a/norm/timepoint.lisp +++ b/norm/timepoint.lisp @@ -188,7 +188,8 @@ (t (push t2 (tp-out t1)) - (push t1 (tp-inc t2))))) + (push t1 (tp-inc t2)) + (list t1 t2)))) ;;; t1 and t2 are timepoints (either are possibly nil), assert that t1 is ;;; equal to t2 and return (t1 t2). Preconditions: none. Function also @@ -267,7 +268,7 @@ (setf (gethash src seen) t) (dolist (node (get-successors src)) (if (self node dst seen) - t))))) + (return t)))))) t1 t2 (make-hash-table :test #'equal)))) ;;; Returns t if and only if the timegraph contains evidence that t1 is @@ -358,6 +359,6 @@ ;;; testing functions ;;; ----------------------------------------------------------------------- -(defun print-tp (tp) - (format t "prev: ~A~%next: ~A~%links: ~A" - (tp-prev tp) (tp-next tp) (tp-out tp))) +(defun print-tp (ep tp) + (format t "EP: ~A -> ~A~%prev: ~A~%next: ~A~%links: ~A~%~%" + ep tp (tp-prev tp) (tp-next tp) (tp-out tp))) From c0a248d813ec5defa3f80680501080facf97134b Mon Sep 17 00:00:00 2001 From: Ben Kuehnert Date: Tue, 14 Apr 2020 12:25:08 -0400 Subject: [PATCH 4/5] change from strings to lisp objects --- norm/norm-time.lisp | 46 +++++++++++++++++++++------------------------ 1 file changed, 21 insertions(+), 25 deletions(-) diff --git a/norm/norm-time.lisp b/norm/norm-time.lisp index be70db3..bf0ba57 100644 --- a/norm/norm-time.lisp +++ b/norm/norm-time.lisp @@ -91,7 +91,6 @@ ; BELOW HERE: Ben adds timegraph model code - ; Clear Timegraph (setf *TIME-GRAPH* (make-timegraph)) @@ -104,34 +103,34 @@ (e2 (second (prop-all-args rel)))) (cond - ((and (or (equal pred "cause.v") - (equal pred "before")) + ((and (or (equal pred 'cause.v) + (equal pred 'before)) (not (ep-not-before-p *TIME-GRAPH* e1 e2))) (ep-assert-before *TIME-GRAPH* e1 e2)) - ((and (or (equal pred "precond-of") - (equal pred "strictly-before")) + ((and (or (equal pred 'precond-of) + (equal pred 'strictly-before)) (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) (ep-assert-precond-of *TIME-GRAPH* e1 e2)) - ((and (or (equal pred "at-about") - (equal pred "during")) + ((and (or (equal pred 'at-about) + (equal pred 'during)) (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) (ep-assert-at-about *TIME-GRAPH* e1 e2)) - ((and (equal pred "consec") + ((and (equal pred 'consec) (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) (ep-assert-consec *TIME-GRAPH* e1 e2)) - ((and (equal pred "same-time") + ((and (equal pred 'same-time) (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) (ep-assert-equals *TIME-GRAPH* e1 e2)) - ((and (equal pred "after") + ((and (equal pred 'after) (not (ep-not-before-p *TIME-GRAPH* e2 e1))) (ep-assert-before *TIME-GRAPH* e2 e1)) - ((and (equal pred "postcond-of") + ((and (equal pred 'postcond-of) (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) (ep-assert-precond-of *TIME-GRAPH* e2 e1)) @@ -139,6 +138,7 @@ (dbg 'time "temporal proposition ~s is inconsistent with time model ~s~%" rel tm)))))) + ) ) @@ -182,38 +182,34 @@ (e2 (second (prop-all-args prop)))) (cond - - ((and (or (equal pred "cause.v") - (equal pred "before")) + ((and (or (equal pred 'cause.v) + (equal pred 'before)) (not (ep-not-before-p *TIME-GRAPH* e1 e2))) (ep-before-p *TIME-GRAPH* e1 e2)) - ((and (or (equal pred "precond-of") - - (equal pred "strictly-before")) - + ((and (or (equal pred 'precond-of) + (equal pred 'strictly-before)) (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) - (ep-precond-of-p *TIME-GRAPH* e1 e2)) - ((and (or (equal pred "at-about") - (equal pred "during")) + ((and (or (equal pred 'at-about) + (equal pred 'during)) (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) (ep-at-about-p *TIME-GRAPH* e1 e2)) - ((and (equal pred "consec") + ((and (equal pred 'consec) (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) (ep-consec-p *TIME-GRAPH* e1 e2)) - ((and (equal pred "same-time") + ((and (equal pred 'same-time) (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) (ep-equals-p *TIME-GRAPH* e1 e2)) - ((and (equal pred "after") + ((and (equal pred 'after) (not (ep-not-before-p *TIME-GRAPH* e2 e1))) (ep-before-p *TIME-GRAPH* e2 e1)) - ((and (equal pred "postcond-of") + ((and (equal pred 'postcond-of) (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) (ep-precond-of-p *TIME-GRAPH* e2 e1)) From beaa6f416048c0b1d58dd80ec0ff698b5ab86ce1 Mon Sep 17 00:00:00 2001 From: Ben Kuehnert Date: Tue, 14 Apr 2020 12:27:51 -0400 Subject: [PATCH 5/5] move timegraph version of norm-time to new file --- norm/norm-time.lisp | 228 ++++++++++++++++++---------------- norm/timegraph-norm-time.lisp | 226 +++++++++++++++++++++++++++++++++ 2 files changed, 347 insertions(+), 107 deletions(-) create mode 100644 norm/timegraph-norm-time.lisp diff --git a/norm/norm-time.lisp b/norm/norm-time.lisp index bf0ba57..3706e45 100644 --- a/norm/norm-time.lisp +++ b/norm/norm-time.lisp @@ -1,7 +1,12 @@ +; Include guard for load-mats.lisp, which isn't nicely +; reloadable due to constant symbol redefinitions. +(if (not (boundp 'AIA-MATS-LOADED)) + (progn (load "load-mats.lisp") (setf AIA-MATS-LOADED t))) + (load "real_util.lisp") (load "norm-el.lisp") -(load "timegraph.lisp") +(initialize-allen-arrays) ; A "time model" is a list of infix relation triples ; where the first and third elements are Lisp symbols @@ -24,22 +29,57 @@ ; (E1.SK (p m o) NOW1) ; (E2.SK (p) E3.SK) -(defparameter *TIME-PROP-RELS* +(defparameter *TIME-PROP-ALLEN-RELS* (mk-hashtable '( - (cause.v t) - (consec t) - (same-time t) - (at-about t) - (before t) - (strictly-before t) - (after t) - (during t) - (precond-of t) - (postcond-of t)))) - + ; TODO: cause-of implies (p m o), but not vice versa. + ; This should affect the certainty scores. + ( + ; prop + cause-of + ; equivalent Allen rel disjunction + (p m o) + ) + ( + consec + (m) + ) + ( + same-time + (=) + ) + ( + at-about + (d s f =) + ) + ( + before + (p m o) + ) + ( + strictly-before + (p) + ) + ( + after + (pi mi oi) + ) + ( + during + (s d f =) + ) + ( + precond-of + (p m) + ) + ( + postcond-of + (pi mi) + ) +)) +) + (setf *TIME-MODEL-HASH* nil) (setf *TIME-MODEL* nil) -(setf *TIME-GRAPH* nil) (defun is-now? (s) (and @@ -91,65 +131,39 @@ ; BELOW HERE: Ben adds timegraph model code - ; Clear Timegraph - (setf *TIME-GRAPH* (make-timegraph)) + + ; Clear the state of the AIA solver. + (clear) ; Load the relationship triples into - ; the timegraph's internal data model. - (dolist (rel *TIME-MODEL*) - (when (time-prop? rel) - (let ((pred (prop-pred rel)) - (e1 (first (prop-all-args rel))) - (e2 (second (prop-all-args rel)))) - - (cond - ((and (or (equal pred 'cause.v) - (equal pred 'before)) - (not (ep-not-before-p *TIME-GRAPH* e1 e2))) - (ep-assert-before *TIME-GRAPH* e1 e2)) - - ((and (or (equal pred 'precond-of) - (equal pred 'strictly-before)) - (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) - (ep-assert-precond-of *TIME-GRAPH* e1 e2)) - - ((and (or (equal pred 'at-about) - (equal pred 'during)) - (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) - (ep-assert-at-about *TIME-GRAPH* e1 e2)) - - ((and (equal pred 'consec) - (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) - (ep-assert-consec *TIME-GRAPH* e1 e2)) - - ((and (equal pred 'same-time) - (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) - (ep-assert-equals *TIME-GRAPH* e1 e2)) - - ((and (equal pred 'after) - (not (ep-not-before-p *TIME-GRAPH* e2 e1))) - (ep-assert-before *TIME-GRAPH* e2 e1)) - - ((and (equal pred 'postcond-of) - (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) - (ep-assert-precond-of *TIME-GRAPH* e2 e1)) - - (t - (dbg 'time "temporal proposition ~s is inconsistent with time model ~s~%" - rel tm)))))) + ; the AIA solver's internal data model. + (loop for rel in *TIME-MODEL* do (block inner + (setf allen-rel (convert-time-prop rel)) + (dbg 'time "asserting ~s~%" allen-rel) + (if (null allen-rel) + (progn + (dbg 'time "invalid temporal proposition ~s~%" rel) + (return-from outer nil) + ) + ) + (allen-assert (car allen-rel) (second allen-rel) (third allen-rel)) + )) + ; Reduce the AIA solver's model to obtain + ; the strictest possible pairwise relations. + (allen-reduce) ) ) (defun time-pred? (p) - (not (null (gethash p *TIME-PROP-RELS*))) + (not (null (gethash p *TIME-PROP-ALLEN-RELS*))) ) - -; check if temporal proposition is valid -(defun time-prop? (prop) -(block outer +; convert-time-prop takes a temporal proposition +; and returns its equivalent Allen relation form. +(defun convert-time-prop (prop) +(block outer (setf pred (prop-pred prop)) (if (not (time-pred? pred)) @@ -157,7 +171,6 @@ (dbg 'time "~s isn't a valid temporal predicate~%" pred) (return-from outer nil) ) - ) (setf args (prop-all-args prop)) @@ -169,58 +182,59 @@ ) ) - (return-from outer t) -)) + (setf allen-rels (gethash pred *TIME-PROP-ALLEN-RELS*)) -(defun eval-time-prop (prop) - (when (not (time-prop? prop)) - (dbg 'time "invalid temporal proposition ~s~%" prop) - nil) - - (let ((pred (prop-pred prop)) - (e1 (first (prop-all-args prop))) - (e2 (second (prop-all-args prop)))) - - (cond - ((and (or (equal pred 'cause.v) - (equal pred 'before)) - (not (ep-not-before-p *TIME-GRAPH* e1 e2))) - (ep-before-p *TIME-GRAPH* e1 e2)) - - ((and (or (equal pred 'precond-of) - (equal pred 'strictly-before)) - (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) - (ep-precond-of-p *TIME-GRAPH* e1 e2)) - - ((and (or (equal pred 'at-about) - (equal pred 'during)) - (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) - (ep-at-about-p *TIME-GRAPH* e1 e2)) - - ((and (equal pred 'consec) - (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) - (ep-consec-p *TIME-GRAPH* e1 e2)) + (return-from outer (list (car args) allen-rels (second args))) +) +) - ((and (equal pred 'same-time) - (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) - (ep-equals-p *TIME-GRAPH* e1 e2)) +(defun time-prop? (p) + (not (null (convert-time-prop p))) +) - ((and (equal pred 'after) - (not (ep-not-before-p *TIME-GRAPH* e2 e1))) - (ep-before-p *TIME-GRAPH* e2 e1)) +(defun eval-time-prop (prop) +; BELOW HERE: Ben evaluates using timegraph instead of Allen +(block outer + (setf allen-rel (convert-time-prop prop)) + (if (null allen-rel) + (progn + (dbg 'time "invalid temporal proposition ~s~%" prop) + (return-from outer nil) + ) + ) - ((and (equal pred 'postcond-of) - (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) - (ep-precond-of-p *TIME-GRAPH* e2 e1)) + ; Evaluate the relationship in the time model. + ; (dbg 'time "evaluating Allen rel ~s~%" allen-rel) - (t nil)) + (setf allen-result (second (allen-fhow (car args) (second args)))) - ;(dbg 'time "allen result: ~s~%" allen-result) - ;(dbg 'time "allen rels: ~s~%" allen-rels) + (dbg 'time "allen result: ~s~%" allen-result) + (dbg 'time "allen rels: ~s~%" allen-rels) + (if (equal allen-result 'ANY) + ; This doesn't confirm the proposition, but it doesn't + ; necessarily refute it, either. + (return-from outer nil) + ) ; TODO: handle cases (via certainty scores) where ; the relationship could be an Allen relation that ; doesn't support the predicate, but it could also ; be one that supports it. -)) + (if (not (listp allen-result)) + ; then + (if (member allen-result allen-rels :test #'equal) + ; then + (return-from outer t) + ; else + (return-from outer nil) + ) + ) + (if (subset allen-result allen-rels) + ; (if (not (null (intersection allen-result allen-rels :test #'equal))) + (return-from outer t) + ) + + (return-from outer nil) +) +) diff --git a/norm/timegraph-norm-time.lisp b/norm/timegraph-norm-time.lisp new file mode 100644 index 0000000..bf0ba57 --- /dev/null +++ b/norm/timegraph-norm-time.lisp @@ -0,0 +1,226 @@ +(load "real_util.lisp") +(load "norm-el.lisp") +(load "timegraph.lisp") + + +; A "time model" is a list of infix relation triples +; where the first and third elements are Lisp symbols +; representing episodes, and the second element is a +; list of Allen Interval Algebra relation symbols: +; = equals +; d during (proper) +; di contains (proper) +; s starts +; si started-by +; f finishes +; fi finished-by +; p precedes (before) +; pi preceded by (after) +; m meets +; mi met-by +; o overlaps +; oi overlapped-by +; Examples of entries in a time model: +; (E1.SK (p m o) NOW1) +; (E2.SK (p) E3.SK) + +(defparameter *TIME-PROP-RELS* +(mk-hashtable '( + (cause.v t) + (consec t) + (same-time t) + (at-about t) + (before t) + (strictly-before t) + (after t) + (during t) + (precond-of t) + (postcond-of t)))) + +(setf *TIME-MODEL-HASH* nil) +(setf *TIME-MODEL* nil) +(setf *TIME-GRAPH* nil) + +(defun is-now? (s) + (and + (symbolp s) + (has-prefix? (string s) "NOW") + (is-num-str? (remove-prefix (string s) "NOW")) + ) +) + +(defun now-num (s) + (if (is-now? s) + ; then + (parse-integer (remove-prefix (string s) "NOW")) + ; else + nil + ) +) + +(defun mk-now-time-props (tm) +(block outer + (setf nows (sort (remove-duplicates (get-elements-pred tm 'is-now?) :test #'equal) '< :key 'now-num)) + + (setf now-props (list)) + (loop for i from 0 to (- (length nows) 2) + do (setf now-props (append now-props (list + (list (nth i nows) 'STRICTLY-BEFORE (nth (+ i 1) nows)) + ))) + ) + + (return-from outer now-props) +) +) + +(defun load-time-model (tm) +(block outer + ; (format t "hash of time model: ~s~%" (rechash tm)) + (setf model-hash (rechash tm)) + (if (equal model-hash *TIME-MODEL-HASH*) + ; then + (return-from outer nil) + ; nil + ; else + (progn + (setf *TIME-MODEL* (append tm (mk-now-time-props tm))) + (setf *TIME-MODEL-HASH* model-hash) + ) + ) + + + ; BELOW HERE: Ben adds timegraph model code + + ; Clear Timegraph + (setf *TIME-GRAPH* (make-timegraph)) + + ; Load the relationship triples into + ; the timegraph's internal data model. + (dolist (rel *TIME-MODEL*) + (when (time-prop? rel) + (let ((pred (prop-pred rel)) + (e1 (first (prop-all-args rel))) + (e2 (second (prop-all-args rel)))) + + (cond + ((and (or (equal pred 'cause.v) + (equal pred 'before)) + (not (ep-not-before-p *TIME-GRAPH* e1 e2))) + (ep-assert-before *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred 'precond-of) + (equal pred 'strictly-before)) + (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) + (ep-assert-precond-of *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred 'at-about) + (equal pred 'during)) + (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) + (ep-assert-at-about *TIME-GRAPH* e1 e2)) + + ((and (equal pred 'consec) + (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) + (ep-assert-consec *TIME-GRAPH* e1 e2)) + + ((and (equal pred 'same-time) + (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) + (ep-assert-equals *TIME-GRAPH* e1 e2)) + + ((and (equal pred 'after) + (not (ep-not-before-p *TIME-GRAPH* e2 e1))) + (ep-assert-before *TIME-GRAPH* e2 e1)) + + ((and (equal pred 'postcond-of) + (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) + (ep-assert-precond-of *TIME-GRAPH* e2 e1)) + + (t + (dbg 'time "temporal proposition ~s is inconsistent with time model ~s~%" + rel tm)))))) + + +) +) + +(defun time-pred? (p) + (not (null (gethash p *TIME-PROP-RELS*))) +) + + +; check if temporal proposition is valid +(defun time-prop? (prop) +(block outer + (setf pred (prop-pred prop)) + + (if (not (time-pred? pred)) + (progn + (dbg 'time "~s isn't a valid temporal predicate~%" pred) + (return-from outer nil) + ) + + ) + + (setf args (prop-all-args prop)) + + (if (not (equal 2 (length args))) + (progn + (dbg 'time "~s isn't a temporal predicate; has ~s args, but want 2" prop (length args)) + (return-from outer nil) + ) + ) + + (return-from outer t) +)) + +(defun eval-time-prop (prop) + (when (not (time-prop? prop)) + (dbg 'time "invalid temporal proposition ~s~%" prop) + nil) + + (let ((pred (prop-pred prop)) + (e1 (first (prop-all-args prop))) + (e2 (second (prop-all-args prop)))) + + (cond + ((and (or (equal pred 'cause.v) + (equal pred 'before)) + (not (ep-not-before-p *TIME-GRAPH* e1 e2))) + (ep-before-p *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred 'precond-of) + (equal pred 'strictly-before)) + (not (ep-not-precond-of-p *TIME-GRAPH* e1 e2))) + (ep-precond-of-p *TIME-GRAPH* e1 e2)) + + ((and (or (equal pred 'at-about) + (equal pred 'during)) + (not (ep-not-at-about-p *TIME-GRAPH* e1 e2))) + (ep-at-about-p *TIME-GRAPH* e1 e2)) + + ((and (equal pred 'consec) + (not (ep-not-consec-p *TIME-GRAPH* e1 e2))) + (ep-consec-p *TIME-GRAPH* e1 e2)) + + ((and (equal pred 'same-time) + (not (ep-not-equals-p *TIME-GRAPH* e1 e2))) + (ep-equals-p *TIME-GRAPH* e1 e2)) + + ((and (equal pred 'after) + (not (ep-not-before-p *TIME-GRAPH* e2 e1))) + (ep-before-p *TIME-GRAPH* e2 e1)) + + ((and (equal pred 'postcond-of) + (not (ep-not-precond-of-p *TIME-GRAPH* e2 e1))) + (ep-precond-of-p *TIME-GRAPH* e2 e1)) + + (t nil)) + + ;(dbg 'time "allen result: ~s~%" allen-result) + ;(dbg 'time "allen rels: ~s~%" allen-rels) + + + ; TODO: handle cases (via certainty scores) where + ; the relationship could be an Allen relation that + ; doesn't support the predicate, but it could also + ; be one that supports it. +))