;;; File: over-and-under.lisp (needs a better name)
;;; Last saved in emacs: Time-stamp: <95/07/18 11:29:57 williams>

;;; This file contains a new upper-model concept, OVER, which is
;;; almost exactly the same as ABOVE.  It also contains inquiry
;;; implementations for the inquiries that need to be asked to get to
;;; the right gate.

;;; This file now also contains another new upper-model concept,
;;; UNDER, which is similar to OVER.

(in-package :penman)

(penman-kb::defreified-relation Over
  :is (:and penman-kb::Vertical :primitive))

(penman::annotate-concept OVER
  :doc-strings
  ("A type of spatial relation that shows orientation with respect to a horizontal plane.")
  :lex-items
  (OVER))

(penman-kb::defreified-relation Under
  :is (:and penman-kb::Vertical :primitive))

(penman::annotate-concept UNDER
  :doc-strings
  ("A type of spatial relation that shows orientation with respect to a horizontal plane.")
  :lex-items
  (UNDER))


(defun Vertical-Orientation-Q-Code (reln range)
  "Use the type of RELN."
  (declare (ignore range))
  (if (or (term-type-p reln 'above)
	  (term-type-p reln 'over)) 'above
      (if (or (term-type-p reln 'below)
	      (term-type-p reln 'under)) 'below)))

(askoperator 
   :name AREA-OF-COVERAGE-Q
   :domain KB
   :mode IMPLEMENTED
   :parameters (RELATION RANGE)
   :english ()
   :operatorcode area-of-coverage-q-code
   :parameterassociationtypes (CONCEPT CONCEPT)
   :answerset (TOTAL PARTIAL)
)

(defun area-of-coverage-q-code (relation range)
  (if (or (term-type-p (term-graph-parent (symbol-value range)) 'over)
	  (term-type-p (term-graph-parent (symbol-value range)) 'under))
      'partial
    'total))

(askoperator 
   :name SURFACE-CONTACT-Q
   :domain KB
   :mode IMPLEMENTED
   :parameters (RELATION RANGE)
   :english ()
   :operatorcode surface-contact-q-code
   :parameterassociationtypes (CONCEPT CONCEPT)
   :answerset (CONTACT NONCONTACT)
   :trivialdefault CONTACT)

(defun surface-contact-q-code (relation range)
  (if (or (term-type-p (term-graph-parent (symbol-value range)) 'over)
	  (term-type-p (term-graph-parent (symbol-value range)) 'under))
      'noncontact
    'contact))

;;; Sample SPL:
(defvar sample-over-spl
  '(over / over
	 :domain (speaker / person :circumstance-q notcircumstance) 
	 :range (hearer / person)))
;;; Produces: "I am over you."
