(in-package "PENMAN")

;;; File: speedy.lisp
;;; =================

;;; This file contains the speedup patches by John Wilkinson, 
;;; jgwilkin@palestrina.uwaterloo.ca (Summer 1995) as adapted
;;; for use in KPML (John Bateman:IPSI:Oct95).
;;;
;;; Most of the patches have been moved into main KPML 0.9 code,
;;; this file contains those that are not compatible with usual
;;; usage and so can be loaded separately on demand.
;;;
;;; This file combines the speedups for Loom 2.0 and Loom 2.1.
;;; John, note April 1999. Then this seems to be untested for Loom 3.0,
;;;       conditionalizations added here assuming that Loom 3.0 usage
;;;       follows 2.1 for the cases concerned. This might not be true.
;;;
;;; WARNING: this file when loaded moves symbols into the Penman
;;; package and also redefines the following inquiries:
;;;   penman::Member-Set-Q-Code
;;;
;;; The changes in this file are activated (destructively) by
;;; the file being loaded. 

#|| First trial timings for KPML...

curlan - '(:english)
(each for 10 generations of reuters1)

                               Running on           Running on
                            Sparcbook 3 (Tadpole)    Sparc 10
                             (32 Mb RAM)           (48 Mb RAM)

*rigidly-monolingual* nil       : 188.4 s            : 79.3 s
*rigidly-monolingual*: T        : 167.3 s            : 68.7 s
*rigidly-monolingual* nil
john W. patches                 : 131.7 s            : 55.8 s

*rigidly-monolingual* T
john W. patches                 : 110.3 s            : 45.1 s

*rigidly-monolingual* T
john W. patches
compiled inquiries              : 63.9 s             : 27.5 s


||#

;;; ----------------------------------------------------------------------
; here's a hack:
; to speed kb-superp, copy all the concept names in the penman-kb package so
; they are accessible in the penman package--no intern calls should now
; be needed.
; also make them accessible via keyword names (eg, :actee)
; This function needs to be run whenever new concepts are added to a package
; other than 'penman'.

; This ugliness could be avoided altogether by keeping all the concepts in the
; penman package to begin with.

;;; (Following combines John Wilkinson's versions of find-concept-hack
;;; for Loom2.0 and Loom2.1. Only differences were the name access
;;; functions. JAB)
;;; 2.1 added version ranging so that versions of Loom after 2.1 follow
;;;     the names used in 2.1. Also, since the only difference is a
;;;     single change in function names and all else stays the same,
;;;     this is all factored out into one place of conditionalization.

(defun FIND-CONCEPT-HACK nil
  (let* ((loom-name-space-function 
	  (:version-case 
	   (":LOOM")
	   ((- "2.1") #'loom::get-name-space-in-knowledge-base)
	   (t         #'loom::get-name-space-in-context)))
	 (kb-hash
	  (funcall loom-name-space-function 
		   ':relations 
		   (:version-case
		    (":LOOM")
		    ((- "2.1")
		     (loom::get-knowledge-base 'loom::upper-structure-kb))
		    (t 
		     (loom::get-context 'loom::built-in-theory))))))
    (maphash 
     #'(lambda (name concept)
	 (setf 
	     (gethash 
	      (intern (symbol-name name))
	      (funcall loom-name-space-function ':concepts nil))
	   concept)
	 (setf (gethash (intern (symbol-name name) "KEYWORD")
			(funcall loom-name-space-function ':concepts nil))
	   concept))
     (funcall loom-name-space-function ':concepts nil))
  
  (maphash 
   #'(lambda (name concept)
       (setf (gethash (intern (symbol-name name))
		      (funcall loom-name-space-function ':relations nil))
	 concept)
       (setf (gethash 
	      (intern (symbol-name name) "KEYWORD")
	      (funcall loom-name-space-function ':relations nil))
	 concept))
   (funcall loom-name-space-function ':relations nil))

  (maphash 
   #'(lambda (name concept)
       (setf (gethash (intern (symbol-name name)) kb-hash) concept))
   kb-hash)))


;;; ----------------------------------------------------------------------

(defun KB-superp (c1 c2)
; first, check to see if the first concept is an inquiry name, and ignore it
; if it is
  (unless (gethash c1 quiry-operators)
; using evaluate-identifier instead of find-concept or find-relation.  This
; saves considerable time by not checking for Loom extended identifiers
; (identifiers which contain the context name and concept name, separated by
; a `^').  Some users may desire to use this feature, so perhaps a
; parameter should be included which is checked initially to determine if
; find-concept should be used instead.
   (let ((loom-c1 (loom::evaluate-identifier c1 ':concepts nil))
       	 (loom-c2 (loom::evaluate-identifier c2 ':concepts nil)) ) 
; only bother to check for relations if the concept check fails; also, only
; find the second relation if the first exists
	(if (and loom-c1 loom-c2)
		(loom::subconcept-p loom-c1 loom-c2)
   	    (let ((loom-r1 (loom::evaluate-identifier c1 ':relations nil)))
	      (and loom-r1
       	  	(let ((loom-r2 (loom::evaluate-identifier c2 ':relations nil)))
		    (and loom-r1 loom-r2 (loom::subconcept-p loom-r1 loom-r2)) 
	)))))))


;;; ----------------------------------------------------------------------
;;; 0.9 COMMENT. following doesn't change the functionality of the macro
;;;  at all. I wonder how much time this really saves though? (John:IPSI)

; make-term-graph-id macro fix
; doesn't intern the ids it makes; this may be ugly for debugging, but seems
; to work
(defmacro make-term-graph-id (&key symbol id type features parent)
  "Returns a symbol which evaluates to a term-graph structure after entering tha
t symbol
   as the term-graph-id."
  `(let ((term-graph-id
           (if ,id
              (gensym
                 (concatenate 'string (string-upcase (symbol-name ,id)) "-"))
               (gensym "ID"))))
     (set term-graph-id
          (make-term-graph
            :symbol ,symbol
            :id term-graph-id
            :type ,type
            :features ,features
            :parent ,parent))
     term-graph-id))

;;; ----------------------------------------------------------------------

; Same-as-q-code: put here in case it is not defined anywhere else...

(defun Same-As-Q-Code (first second)
  "Either first and second should be EQ, or their symbols should be."
  (or (if (and (boundp first)
	   (not (symbolp (symbol-value first))))
      (if (and (boundp second)
	       (not (symbolp (symbol-value second))))
	  (if (eq (term-graph-symbol (symbol-value first))
		  (term-graph-symbol (symbol-value second))) 'same)
	  (if (eq (term-graph-symbol (symbol-value first)) second) 'same))
      (if (and (boundp second)
	       (not (symbolp (symbol-value second))))
	  (if (eq first (term-graph-symbol (symbol-value second))) 'same)
	  (if (eq first second) 'same)))
      (if (and (boundp first)
	       (boundp second)
	       (typep (symbol-value first) 'term-graph)
	       (typep (symbol-value second) 'term-graph)
	       (eq (term-graph-type (symbol-value first)) 'um-set)
	       (eq (term-graph-type (symbol-value second)) 'um-set)
	       (not (set-difference 
		      (term-graph-symbol (symbol-value first)) 
		      (term-graph-symbol (symbol-value second)) 
		      :test 'term-eq-p)))
	  'same)))



; Member-Set-Q-Code: the second case (using term-role-p) was taking almost all
; the time, but is never used in the excercise set.  It seems to be covered
; by the fourth case, so I have commented it out.  If errors occur with SPLs
; involving part-whole type relations, it will need to be put back in, or,
; preferably, worked around by making a list of part-whole relations while
; parsing the SPL.

(defun Member-Set-Q-Code (thing1 thing2)
  "The first test is EQ of term-symbol or term-id.  (Use Same-As-Q-Code)
   Also, we look for a part/whole (thing1/thing2) relation."
  (if (or (eq (Same-As-Q-Code thing1 thing2) 'same) 
          ;(term-role-p thing1 thing2 'part-whole t)
          (if (and (symbolp thing1)
                   (boundp thing1)
                   (typep (symbol-value thing1) 'term-graph))
              (term-eq-p thing2 (fetch-subc-feature 'part thing1)))
          (if (and (symbolp thing2)
                   (boundp thing2)
                   (typep (symbol-value thing2) 'term-graph)
                   (or (fetch-reified-relation 'part-whole thing2)
                       (fetch-reified-relation 'generalized-role-relation thing2)))
              (term-eq-p
                thing1
                (fetch-subc-feature
                  'domain
                  (or (fetch-reified-relation 'part-whole thing2)
                      (fetch-reified-relation 'generalized-role-relation thing2)))))
          (if (and (symbolp thing1)                                            ;
;;  EX-SET-4, EX-SET-13
                   (boundp thing1)
                   (typep (symbol-value thing1) 'term-graph)
                   (eq (term-graph-type (symbol-value thing1)) 'set))
              (dolist (elt (term-graph-symbol (symbol-value thing1)))
                (if (member-set-q-code elt thing2) (return t))))
          (if (and (symbolp thing2)                                            ;
;;  EX-SET-4, EX-SET-13
                   (boundp thing2)
                   (typep (symbol-value thing2) 'term-graph)
                   (eq (term-graph-type (symbol-value thing2)) 'set))
              (dolist (elt (term-graph-symbol (symbol-value thing2)))
                (if (member-set-q-code elt thing1) (return t))))
;         (dolist (plan *plan-graphs*)
;            A set of cases to minimaze global search....
;           (if (term-graph-features (symbol-value plan))
;               (if (and (term-role-p thing1 plan 'generalized-possession t)
;                        (term-role-p plan thing2 'generalized-possession t))
;                   (return t))))
          )
      'included
	 ))

; Feature-Pack
; who knows what this was for--it used to make a symbol out of the list it is
; passed, but just returning NIL is faster
;;; John:feb97. Used to make printable representations of function bundles.
;;;   (One of several variants that grew in Penman/KPML prior to KPML 1.1)
(defun feature-pack (&optional junk)
	nil
)

;;; ----------------------------------------------------------------------
;;; The following can be used with Allegro for further finetuning if
;;; ever anyone wants to... Disabled for present. Simple profiling 
;;; compatible with CLtL2 is elsewhere.
;;; ----------------------------------------------------------------------

#+ignore
(defun PROFILE (eg filename)
  (prof:with-profiling nil
   (dotimes (x 10)(say eg)))
  (with-open-file (stream filename :direction :output)
	(prof:show-call-graph :stream stream)))

#+ignore
(defun SAY-PROFILE (eg)
  (prof:with-profiling nil
   (dotimes (x 10)(say eg)))
  (prof:show-flat-profile))

;;; ----------------------------------------------------------------------
;;; Following function needs to be run whenever new KB-concepts/relations
;;; are defined in a non-Penman package.

(defun UPDATE-KB-PACKAGE-REDUCTION nil (find-concept-hack))

;;; ----------------------------------------------------------------------
;;; Do this now....

(update-kb-package-reduction)



