;;; File: new-brackets.lisp
;;; Last saved in emacs: Time-stamp: <97/01/22 01:49:30 jlitchfi>

;;; This file contains a new system/chooser/inquiry set that will put
;;; brackets around restatements.  It also contains an inquiry
;;; implementation for the new inquiry, and the definition of a new
;;; upper-model concept, RESTATEMENT-BRACKETED.  This concept is
;;; exactly the same as restatement, except that it will bracket the
;;; restatement. 
;;; Susan Williams, July, 1995 (at FAW)

;;;
;;; I have added others: 
;;;
;;; RESTATEMENT-COMMAS
;;; RESTATEMENT-COMMAS-DISJUNCTIVE
;;;
;;; - Jon 28/05/96
;;;

(in-package :penman)

(SYSTEM
 :NAME                   ELABORATING-NOMINAL-GROUP-TYPE
 :INPUTS                 ELABORATING-NOMINAL-GROUP-COMPLEX
 :OUTPUTS                ((0.5 EXEMPLIFYING-NOMINAL-GROUP-COMPLEX
                               (INSERT ELABORATOR)
                               (ORDER INITIATING ELABORATOR)
                               (ORDER ELABORATOR CONTINUING))
			  (0.5 RESTATING-NOMINAL-GROUP-COMPLEX))
 :CHOOSER                ELABORATING-NOMINAL-GROUP-TYPE-CHOOSER
 :REGION                 NOMINALGROUPCOMPLEXITY
 :METAFUNCTION           LOGICAL
 )

(system
 :name restatement-type
 :inputs RESTATING-NOMINAL-GROUP-COMPLEX
 :outputs ((0.2 bracketed-elaboration
		 (ORDER INITIATING CONTINUING))
	   (0.2 comma-elaboration
		 (ORDER INITIATING CONTINUING))
	   (0.2 disjunctive-comma-elaboration
		 (INSERT ELABORATOR)
		 (ORDER INITIATING ELABORATOR)
		 (ORDER ELABORATOR CONTINUING)
		 (LEXIFY ELABORATOR OR))
	   (0.2 disjunctive-elaboration
		 (INSERT ELABORATOR)
		 (ORDER INITIATING ELABORATOR)
		 (ORDER ELABORATOR CONTINUING)
		 (LEXIFY ELABORATOR OR))
	   (0.2 no-bracket-or-comma-elaboration
		 (ORDER INITIATING CONTINUING)))
 :chooser restatement-type-chooser
 :selector CHOICE-MASTER
 :old-feature no-bracket-elaboration
 :region NOMINALGROUPCOMPLEXITY
 :metafunction logical
 )

(chooser
 :name restatement-type-chooser
 :definition ((ask (bracket-q continuing)
		   (brackets (choose bracketed-elaboration))
		   (nobrackets 
		    (ask (comma-q continuing)
			 (commas 
			  (ask (disjunctive-elaboration-q continuing)
			       (disjunctive
				(choose disjunctive-comma-elaboration))
			       (nondisjunctive
				(choose comma-elaboration))))
			 (nocommas
			  (ask (disjunctive-elaboration-q continuing)
			      (disjunctive
			       (choose disjunctive-elaboration)) 
			      (nondisjunctive
			       (choose no-bracket-or-comma-elaboration))))))))
 :editor "JLL"
 :date "28/05/96"
)

(askoperator
 :name bracket-q
 :domain KB
 :mode IMPLEMENTED
 :parameters (ACTION)
 :english ("Do you want " action " in brackets?")
 :operatorcode bracket-q-code
 :parameterassociationtypes (CONCEPT)
 :answerset (brackets nobrackets)
 :trivialdefault nobrackets
 )

(defun bracket-q-code (continuing)
  (if (term-type-p (term-graph-parent (symbol-value continuing))
		   'restatement-bracketed)
      'brackets
      'nobrackets))

(askoperator
 :name comma-q
 :domain KB
 :mode IMPLEMENTED
 :parameters (ACTION)
 :english ("Do you want " action " between commas?")
 :operatorcode comma-q-code
 :parameterassociationtypes (CONCEPT)
 :answerset (commas nocommas)
 :trivialdefault nocommas
 )

(defun comma-q-code (continuing)
  (if (or (term-type-p (term-graph-parent (symbol-value continuing))
		       'restatement-commas)
	  (term-type-p (term-graph-parent (symbol-value continuing))
		       'restatement-commas-disjunctive))
      'commas
    'nocommas))

(askoperator
 :name disjunctive-elaboration-q
 :domain KB
 :mode IMPLEMENTED
 :parameters (ACTION)
 :english ("Is " action " to be presented disjunctively?")
 :operatorcode disjunctive-elaboration-q-code
 :parameterassociationtypes (CONCEPT)
 :answerset (disjunctive nondisjunctive)
 :trivialdefault nondisjunctive
 )

(defun disjunctive-elaboration-q-code (continuing)
  (if (or (term-type-p (term-graph-parent (symbol-value continuing))
		       'restatement-commas-disjunctive)
	  (term-type-p (term-graph-parent (symbol-value continuing))
		   'restatement-disjunctive))
      'disjunctive
    'nondisjunctive))

;;;
;;; Now, define the new upper-model concept RESTATEMENT-BRACKETED, the
;;; same way as RESTATEMENT is defined.
;;;

(penman-kb::defreified-relation Restatement-bracketed
  :is (:and penman-kb::Elaboration :primitive))

(penman::annotate-concept RESTATEMENT-bracketed
  :doc-strings
  ("A type of elaboration that provides further information by restating in different terms.")
  )

;;;
;;; Same for other types:
;;;

(penman-kb::defreified-relation Restatement-commas
  :is (:and penman-kb::Elaboration :primitive))

(penman::annotate-concept RESTATEMENT-commas
  :doc-strings
  ("A type of elaboration that provides further information by restating in different terms.")
  )

(penman-kb::defreified-relation Restatement-commas-disjunctive
  :is (:and penman-kb::Elaboration :primitive))

(penman::annotate-concept RESTATEMENT-commas-disjunctive
  :doc-strings
  ("A type of elaboration that provides further information by restating in different terms.")
  )

(penman-kb::defreified-relation Restatement-disjunctive
  :is (:and penman-kb::Elaboration :primitive))

(penman::annotate-concept RESTATEMENT-commas-disjunctive
  :doc-strings
  ("A type of elaboration that provides further information by restating in different terms.")
  )

;;;
;;; We actually get the brackets in the punctuate section of
;;; generation: 
;;;

(setf (second (second *pre-punctuation*))
  (append (second (second *pre-punctuation*))
	  '((bracketed-elaboration continuing "(")
	    (comma-elaboration continuing ",")
	    (disjunctive-comma-elaboration elaborator ","))))

(setf (second (second *post-punctuation*))
  (append (second (second *post-punctuation*))
	  '((bracketed-elaboration continuing ")")
	    (comma-elaboration continuing ",")
	    (disjunctive-comma-elaboration continuing ","))))
#|
(setq *pre-punctuation*
      (cons '(bracketed-elaboration continuing "(")
	    *pre-punctuation*))

(setq *post-punctuation*
      (cons '(bracketed-elaboration continuing ")")
	    *post-punctuation*))

(setq *pre-punctuation*
      (cons '(comma-elaboration continuing ",")
	    *pre-punctuation*))

(setq *post-punctuation*
      (cons '(comma-elaboration continuing ",")
	    *post-punctuation*))

(setq *pre-punctuation*
      (cons '(disjunctive-comma-elaboration elaborator ",")
	    *pre-punctuation*))

(setq *post-punctuation*
      (cons '(disjunctive-comma-elaboration continuing ",")
	    *post-punctuation*))
|#
;;; We have to redefine this to allow for our new upper-model concept.
(defun Restatement-Elaboration-Q-Code (one two)
  "If the parent is an EXEMPLIFICATION...."
  (declare (ignore two))
  (if (or (term-type-p (term-graph-parent (symbol-value one))
		       'restatement) 
	  ;; Susan's (and Jon's) addition for other restatements:
	  (term-type-p (term-graph-parent (symbol-value one))
		       'restatement-bracketed)
	  (term-type-p (term-graph-parent (symbol-value one))
		       'restatement-commas)
	  (term-type-p (term-graph-parent (symbol-value one))
		       'restatement-commas-disjunctive)
	  (term-type-p (term-graph-parent (symbol-value one))
		       'restatement-disjunctive)
	  )
      'restatement 
      'notrestatement))

;;; Sample SPL:
(defvar sample-bracket-SPL
  '(fit / nondirected-action
       :lex fit
       :actor (el2 / restatement-bracketed
		    :domain (ball / object
				  :lex ball
				  :determiner the 
				  :part-of (skull / object
						  :lex skull
						  :determiner the))
		    :range (ceph / object
				 :lex cephabulum
				 :determiner the))
       :destination (elab / (restatement-bracketed three-d-location)  :event-q object
			  :domain (part / three-d-locaation
					:lex part
					:typical-participant-q typicalclass
					:property-ascription (socket / object
								     :lex socket)
					:part-of (pelvis / object
							 :lex neck
							 :determiner the))
			  :range (acet / object
				       :lex acetabulum
				       :determiner the))))
;;; Produces:
;;; "The ball of the skull (the CEPHABULUM) fits into the socket part
;;; of the neck (the acetabulum)."



;;; These 2 inquiry implementations also make reference to
;;; restatement.  They haven't been redefined yet.  It may not be
;;; necessary.

#|
(defun ReExpression-Q-Code (conjunctive)
  "Depends on type of conjunctive."
  (if (term-type-p conjunctive 'restatement) 'reexpression
    'notreexpression))

(defun Taxis-Prominence-Q-Code (part1 part2)
  "Probably depends on the type of conjunctive relation.
   For the time being, if they are just set elements, return NOTLESS."
  (if (or (term-type-p (term-graph-parent (symbol-value part1)) 'symmetric-rhetorical-relation)
	  (term-type-p (term-graph-parent (symbol-value part1)) 'conjunction)
	  (term-type-p (term-graph-parent (symbol-value part1)) 'disjunction)
	  (and (term-type-p (term-graph-parent (symbol-value part1)) 'rhetorical-relation)
	       (term-type-p (term-graph-parent (symbol-value part1)) 'restatement))
	  (and (or (term-type-p (term-graph-parent (symbol-value part1)) 'rhetorical-relation)
		   (term-type-p (term-graph-parent (symbol-value part1)) 'temporal-ordering)  ;;; PRIMER-49
		   (term-type-p (term-graph-parent (symbol-value part1)) 'static-spatial))
	       (eq part1 
		   (fetch-subc-feature 'domain (term-graph-parent (symbol-value part1)))))
	  (and (fetch-subc-feature 'temporal-ordering part1)                                  ;;; PRIMER-49
	       (or (term-type-p (fetch-subc-feature 'temporal-ordering part1) 'process)
		   (eq 'multiple (multiple-process-q-code (fetch-subc-feature 'temporal-ordering part1)))))
	  (and (fetch-subc-feature 'static-spatial part1)                                     ;;; EX-SET-13
	       (or (term-type-p (fetch-subc-feature 'static-spatial part1) 'process)
		   (eq 'multiple (multiple-process-q-code (fetch-subc-feature 'static-spatial part1)))))
	  (and (fetch-subc-feature 'condition part1)
	       (or (term-type-p (fetch-subc-feature 'condition part1) 'process)
		   (eq 'multiple (multiple-process-q-code (fetch-subc-feature 'condition part1)))))
	  (dolist (graph *plan-graphs*)
	    (and (or (and (term-type-p graph 'set)
			  (not (term-type-p graph 'ordered-set)))
		     (term-type-p graph 'disjunctive-set))
		 (or (member part1 (term-graph-symbol (symbol-value graph)))
		     (term-eq-p part1 graph))
		 (or (member part2 (term-graph-symbol (symbol-value graph)))
		     (term-eq-p part2 graph))
		 (return 't))))
      'notless
      'less))
|#
