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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                             ;
;  Copyright (c) 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.                                          ;
;                                                                             ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; NEW-REIFY.LISP (TBOX)

;;; This file contains code for the :reifies option and links
;;; This is a different reification method than that used for defreified-relation


(in-package "LOOM")

(defun store-link (relation source sink link)
  (declare (ignore relation))
  (fadd-value source 'link-object link)
  (when (or (typep sink 'loom::BASIC-INSTANCE)
	    (typep sink 'loom::INSTANCE-WITH-DYNAMIC-SLOTS))  ; CLOS-INSTANCE?
    (fadd-value sink 'link-object link)) )

;;

(defun filter-new-reified-expression (expr inverseP)
  ;; Returns the appropriate definition items for a new-style reified relation;
  (flet ((find-reification-relation (concept)
           (if (eq concept :primitive)
             nil
             (let ((reifiesClause (getf (rest (first (source-definitions concept)))
                                       :reifies))
                   inverseClause)
               (if inverseP
                 (progn 
                   (setq inverseClause (and (consp reifiesClause)
                                            (getf (rest reifiesClause) :inverse)))
                   (if (atom inverseClause)
                     inverseClause    ; NIL or a name
                     (first inverseClause)))                     
                 (if (atom reifiesClause)
                   reifiesClause
                   (first reifiesClause)))) )))
    (if (atom expr)
      (find-reification-relation 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-new-reified-expression subExpr inverseP)))))
	     (when newCdr
	       (cons (car expr) newCdr))))
          (:all
           (cond ((eq (second expr) (loom-constant DOMAIN))
                  `(,(if inverseP :range :domain) ,(name (third expr))))
                 ((eq (second expr) (loom-constant RANGE))
                  `(,(if inverseP :domain :range) ,(name (third expr))))))
	  ((:lambda :function :satisfies :predicate)
           :primitive)) )) ))

(defun create-reified-relation-definition (reificationConcept inverseP)
  ;; Situation:  "reificationConcept" is defined to reify a relation;
  ;; Returns:  An appropriate definition for the relation that
  ;;    "reificationConcept" reifies;
  ;; TO DO:  FIGURE OUT WHETHER THE RETURNED DEFINITION NEEDS TO BE
  ;;    PRIMITIVE OR NOT!   HOW CAN THIS BE DONE?
  (let ((parsedDefinition (getf (parsed-expressions reificationConcept) :definition)))
    (if (eq parsedDefinition :primitive)
      parsedDefinition
      (filter-new-reified-expression parsedDefinition inverseP)) ))

(defun generate-reified-concept-constraints (reificationConcept)
  ;; Situation:  "reificationConcept" is defined to reify a relation;
  ;; Returns:  Appropriate constraints for the "reificationConcept" that
  ;;    are generated from :domain and :range options in :reifies.;
  ;; TO DO:  FIGURE OUT WHETHER THE RETURNED DEFINITION NEEDS TO BE
  ;;    PRIMITIVE OR NOT!   HOW CAN THIS BE DONE?
  (let* ((reifiesClause (getf (rest (first (source-definitions reificationConcept)))
                              :reifies))
         (inverseClause (and (consp reifiesClause) 
                             (getf (rest reifiesClause) :inverse))))
    (declare (ignore inverseClause))
    (warn "NOT IMPLEMENTED YET")
    (return-from generate-reified-concept-constraints nil)
;    (if (eq parsedDefinition :primitive)
;      parsedDefinition
;      (filter-new-reified-expression parsedDefinition nil))
    ))

(defun generate-concept-reification-annotations (reificationConcept)
  (let* ((reifiesClause (getf (rest (first (source-definitions reificationConcept)))
                              :reifies))
         (inverseClause (and (consp reifiesClause) 
                             (getf (rest reifiesClause) :inverse))))
    (cond ((atom reifiesClause)
           `((reifies (the-relation ,reifiesClause 2))))
          ((null inverseClause)
           `((reifies (the-relation ,(car reifiesClause) 2))))
          ((atom inverseClause)
           `((reifies (the-relation ,(car reifiesClause) 2) 
                      (the-relation ,inverseClause 2))))
          (t
           `((reifies (the-relation ,(car reifiesClause) 2) 
                      (the-relation ,(car inverseClause) 2))))) ))

(defun generate-relation-reification-annotations (reificationConcept)
  ;; Returns: (1) Annotations for the relation clause
  ;;          (2) Annotations for the inverse relation clause
  ;; TO DO:  SHOULD CASE-ROLE NAMES INHERIT FROM SUPERS?
  (let* ((reifiesClause (getf (rest (first (source-definitions reificationConcept)))
                              :reifies))
         (caseRoles (or (and (consp reifiesClause)
                             (getf (rest reifiesClause) :case-roles))
                        '(source-case target-case)))
         (inverseClause (and (consp reifiesClause) 
                             (getf (rest reifiesClause) :inverse)))
         (inverseCaseRoles (and inverseClause
                                (or (and (consp inverseClause)
                                         (getf (rest inverseClause) :case-roles))
                                    '(target-case source-case))))
         (*conceptBeingParsed* reificationConcept))
    (declare (special *conceptBeingParsed*))

    (when (and inverseClause
               (or (neq (first caseRoles) (second inverseCaseRoles))
                   (neq (second caseRoles) (first inverseCaseRoles))))
      (parsing-error   ;; ZZZ IS THIS A DIFFERENT KIND OF ERROR?
       "Inverse :CASE-ROLES must be the opposite of forward relation :CASE-ROLES"))
    (values `((reified-by (the-relation ,(name reificationConcept) 1))
              (source-role (the-relation ,(first caseRoles) 2))
              (target-role (the-relation ,(second caseRoles) 2)))
            (and inverseClause
                 `((reified-by (the-relation ,(name reificationConcept) 1))
                   (source-role (the-relation ,(first inverseCaseRoles) 2))
                   (target-role (the-relation ,(second inverseCaseRoles) 2))))
            ) ))



;;;
;;;  Linking in new definition:
;;;

(defun concept-is-new-style-reification-p (concept)
  ;; TO DO:  USE A BETTER MARKER THAN THIS:
  (getf (rest (first (source-definitions concept))) :reifies) )

(defun define-associated-reified-relations (concept)
  ;; TO DO: HANDLE ANNOTATIONS THAT ARE IN THE :REIFIES CLAUSE AS WELL!
  (let* ((reifiesClause (getf (rest (first (source-definitions concept)))
                             :reifies))
        (inverseClause (and (consp reifiesClause) 
                            (getf (rest reifiesClause) :inverse)))
        relation)
    (multiple-value-bind (annotations inverseAnnotations)
                         (generate-relation-reification-annotations concept)
      (setq relation 
            (apply #'define-relation (if (consp reifiesClause)
                                       (first reifiesClause)
                                       reifiesClause)
                   :is (create-reified-relation-definition concept nil)
                   :annotations annotations
                   (and (consp reifiesClause) (rest reifiesClause))))
      (pushnew :reified (attributes relation))
      (when inverseClause
        (setq relation 
              (apply #'define-relation (if (consp inverseClause)
                                         (first inverseClause)
                                         inverseClause)
                     :is (create-reified-relation-definition concept t)
                     :annotations inverseAnnotations
                     (and (consp inverseClause) (rest inverseClause))))
        (pushnew :reified (attributes relation))) )))

