;;; -*- Mode: LISP; Syntax: Common-lisp; Package: LOOM; Base: 10. -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                             ;
;  Copyright (c) 1988, 1995, 1999 by the University of Southern California    ;
;  All rights reserved.                                                       ;
;                                                                             ;
;  Permission to use, copy, modify, and distribute this software and its      ;
;  documentation in source and binary forms for non-commercial purposes       ;
;  and without fee is hereby granted, provided that this notice               ;
;  be reproduced in any copy or modification thereof, and that                ;
;  any documentation, advertising materials, and other materials related      ;
;  to such distribution and use acknowledge that the software was             ;
;  developed by the University of Southern California, Information            ;
;  Sciences Institute.  The name of the University may not be used to         ;
;  endorse or promote products derived from this software without             ;
;  specific prior written permission.                                         ;
;                                                                             ;
;  THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT THE   ;
;  SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS PROVIDED   ;
;  "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,          ;
;  WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND          ;
;  FITNESS FOR A PARTICULAR PURPOSE.                                          ;
;                                                                             ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; REIFY.LISP (TBOX)

;;; This file contains code for parsing defreified-relation, etc.

(in-package "LOOM")

(export '(defreified-relation))


(defmacro defreified-relation (name &rest definition)
  (if name
      (progn
	;; (form-reified-relation `,name `,definition))
	(form-reified-concept-definition `,name `,definition)) 
      `(complain "~%Syntax Error: Unnamed Reified Relation: ~S~%" ',definition)) )

(defun form-reified-concept-definition (name definition)
  (let* ((documentationString   ; DGB 2/4/93
	  (when (stringp (first definition))
	    (list (pop definition))))
	 (keyword
	  (or (find :is-primitive definition) 
	      :is))
	 (isDef
	  (or (get&remf definition keyword)
	      :primitive)))
    `(defconcept
      ,name
      ,@documentationString
      ,keyword (:reification ,isDef)
      ,@definition) ))

(defun distribute-reified-relation (concept)
  ;; Extract relation and concept definitions from the definition of concept
  ;; Create the resulting relation
  ;; Return the definition to be used for concept.
  (let ((name (caar (source-definitions concept)))
	conceptDef relationDef)
    ;; extract concept and relation definitions
    (multiple-value-setq (conceptDef relationDef)
      (filter-reified-source-clauses concept (cdar (source-definitions concept))))
    ;; Define relation, then return concept definition
    (let ((relation (eval-relation-id name))
	  (classifierEnabledP (not (member :disable-classifier *loom-features*))))
      ;; only redefine "relation" if "concept" is being redefined
      ;; i.e. if we are not parsing as a result of revision
      (when (not (member :being-revised (system-attributes concept)))
	(unwind-protect				; RMM 5/18/92
	    (progn
	      (pushnew :disable-classifier *loom-features*)
	      (setq relation (redefine-concept `(,name ,@relationDef) :relation)))
	  (when classifierEnabledP
	    (delf *loom-features* :disable-classifier))))
      (when relation                    ; RMM 3/29/95
        ;; during revision, the relation may disappear:
        (add-link depend-ons concept relation)
        (change-class concept 'REIFIED-RELATION)
        (setf (relation-of concept) relation))
      conceptDef) ))

(defun filter-reified-source-clauses (self options&arguments &key skip-tbox-definition)
  ;; Extract relation and concept clauses from "options&arguments"
  ;; "options&arguments" contains a list of alternating keyword options
  ;;     and values;
  ;; If "skip-tbox-definition" then extract only the non-tbox concept components
  ;;    of the source definition;
  ;; REWRITE THIS ENTIRE FUNCTION -- THIS IS HORRIBLE CODE!!!:
  (let (option argument
	conceptDef relationDef filteredDef attributesProcessedP)
    (when (and (name self)
	       (not (evenp (length options&arguments))))
      (parsing-error "Missing keyword or keyword argument"))
    (loop for tail on options&arguments by #'cddr
	 when (setq argument (cadr tail))
	 do
	 (setq option (validate-keyword (car tail)))
	 (case option
	   ((:is :is-primitive)     ; DGB 2/4/93
	    (unless skip-tbox-definition
	      (when (eq (first argument) :reification)
		(setq argument (second argument)))
	      (setq filteredDef (filter-reified-expression argument :concept-is))
	      (setq conceptDef (nconc
				 `(,option ,(add-expression 'a-reified-relation filteredDef))
				 conceptDef))
	      (setq filteredDef (filter-reified-expression argument :relation))
	      (when filteredDef
		(setq relationDef (nconc `(,option ,filteredDef) relationDef)))))
	   (:implies 
	    (setq filteredDef (filter-reified-expression argument :concept))
	    (when filteredDef
	      (setq conceptDef (nconc `(:implies ,filteredDef) conceptDef)))
	    (setq filteredDef (filter-reified-expression argument :relation))
	    (when filteredDef
	      (setq relationDef (nconc `(:implies ,filteredDef) relationDef))))
	   (:defaults 
	    (setq filteredDef (filter-reified-expression argument :concept))
	    (when filteredDef
	      (setq conceptDef (nconc `(:defaults ,filteredDef) conceptDef))))
	   (:characteristics
	    (unless skip-tbox-definition
	      (setq attributesProcessedP t)
	      ;; add :reified attribute to both relation and concept
	      (setq argument (list-of argument))
	      (pushnew :reified argument)
	      (setq conceptDef (nconc `(:characteristics ,argument) conceptDef))
	      (setq relationDef (nconc `(:characteristics ,argument) relationDef))))
	   ((:domain :range)
	    (setq conceptDef (nconc `(:implies (:all ,(if (eq option :domain)
							      'domain
							      'range)
							 ,argument)) conceptDef))
	    (setq relationDef (nconc `(,option ,argument) relationDef)))
	   (:domains
	    (setq relationDef (nconc `(,option ,argument) relationDef)))
	   (:antecedents  ;; NOTE: we assume that :antecedents is only used for relations
	    (setq relationDef (nconc `(,option ,argument) relationDef)))
	   (:disjoint-covering
	    (setq conceptDef (nconc `(,option ,argument) conceptDef)))
	   ((:partitions :exhaustive-partitions)  ; DGB 3/30/93
	    (setq conceptDef (nconc `(,option ,argument) conceptDef)))
	   (:in-partition
	    (setq conceptDef (nconc `(,option ,argument) conceptDef)))
	   (:system-characteristics
	    (setq conceptDef (nconc `(,option ,argument) conceptDef))
	    (setq relationDef (nconc `(,option ,argument) relationDef)))
	   ;; (:identifier nil)		;; leave identifier on the source defn
	   (:kb
	    (setq conceptDef (nconc `(,option ,argument) conceptDef))
	    (setq relationDef (nconc `(,option ,argument) relationDef)))
	   ((:from :to)
	    (unless skip-tbox-definition
	      ;; make domain or range alias
;; THIS IS BOGUS; THE RELATIONS "domain-alias" AND "range-alias" MUST
;;    BE DEFINED BEFORE THEY CAN BE ASSERTED:
;	      (set-db-slot self (if (eq option :from)
;				    'domain-alias
;				    'range-alias)
;			   argument)
;; THIS WILL BREAK UNTIL KASPER GETS AROUND TO FIXING IT:       RMM 7/2/90
	      (assert-role-filler self nil argument :assertion)))
	   (otherwise
	    (parsing-error "Illegal keyword: ~S" option))))
    (unless (or skip-tbox-definition attributesProcessedP)
      ;; add :reified attribute to both relation and concept
      (setq conceptDef (nconc (list :characteristics :reified) conceptDef))
      (setq relationDef (nconc (list :characteristics :reified) relationDef)))
    (values conceptDef relationDef)) )


(defun add-expression (addExpr oldExpr)
  (cond
    ((null oldExpr)
     addExpr)
    ((and (consp oldExpr)
	  (eq (car oldExpr) :and))
     `(:and ,addExpr ,@(cdr oldExpr)))
    (t
     `(:and ,addExpr ,oldExpr))) )

(defun filter-reified-expression (expr type)
  ;; type may be one of: :RELATION, :CONCEPT, :CONCEPT-IS
  (if (atom expr)
      expr
      (let ((keyword (if (keywordp (car expr))
			 (validate-keyword (car expr))
			 (car expr))))
	(case keyword
	  ((:and :or :not)
	   (let ((newCdr (delete nil
			       (loop for subExpr in (cdr expr)
				    collect (filter-reified-expression subExpr type)))))
	     (when newCdr
	       (cons (car expr) newCdr))))
	  ((:at-least :at-most :exactly :all :some :the :same-as :subset)
	   (when (eq type :concept)
	     expr))
	  (:domain
	   (cond
	     ((eq type :relation) expr)
	     (t `(:all domain ,(second expr)))))
	  (:range
	   (cond
	     ((eq type :relation) expr)
	     (t `(:all range ,(second expr)))))
	  (:inverse
	   (cond
	     ((eq type :relation) expr)
	     ;; inverse for concept definitions handled indirectly
	     ;; by using the subsumption test for the corresponding relations.
	     (t nil)))
	  (:composition
	   (cond
	     ((eq type :relation) expr)
	     ;; INCOMPLETE: composition for concept definitions currently handled indirectly
	     ;; by using the subsumption test for the corresponding relations.
	     (t nil)))
	  (:concept
	   (when (member type '(:concept :concept-is))
	     (if (cddr expr)
		 `(:and ,@(cdr expr))
		 (second expr))))
	  (:relation
	   (when (eq type :relation)
	     (if (cddr expr)
		 `(:and ,@(cdr expr))
		 (second expr))))
	  ((:lambda :function)
	   (cond
	     ((eq type :relation) expr)
	     (t :primitive)))
	  ((:satisfies :predicate)
	   (case type
	     (:relation
	      (if (and (consp (second expr))
		       (cdr (second expr)))
		  expr
		  :primitive))
	     (t
	      (if (or (atom (second expr))
		      (null (cdr (second expr))))
		  expr
		  :primitive))))
	  (otherwise  ;; expr is a relation/operator
	   (when (eq type :concept)
	     expr))))) )


(defmethod specializes-classified-concept-p
	   ((concept1 REIFIED-RELATION) concept2 checkForEqualityFlag dontCheckPrimsFlag)
  ;;
  (cond
    ((typep concept2 'REIFIED-RELATION)
     (let ((relation1 (relation-of concept1))
	   (relation2 (relation-of concept2)))
       (and relation1 relation2
	    (specializes-classified-concept-p relation1 relation2
					      checkForEqualityFlag dontCheckPrimsFlag)
	    (call-next-method))))
    (t
     (call-next-method))) )

(defun find-named-relation (name concepts)
  (find-if #'(lambda (concept)
	       (and (typep concept 'TBOX-RELATION)
		    (eql name (name concept))))
	   concepts))


(defmethod parent-is-identical-p ((self REIFIED-RELATION) parent dontExpandP)
  ;; Helping function for "classify-below";
  ;; Return "parent" iff "self", which is known to specialize "parent", is
  ;;    identical to it;
  ;; For reified-relations, this can't happen;
  (declare (ignore parent dontExpandP))
  nil )
