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

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


;;; VIEWS.LISP (ABOX)

;;; Contains code for the view mechanism.

(in-package "LOOM")

(export '( get-views create-view
	  ))


;;; WE NEED THIS ONLY IF WE NEED TYPE DISPATCHING
;;;    TO DETECT VIEWS
(defclass LOOM-VIEW-INSTANCE (DB-INSTANCE)
   ((view-concept :range UNARY-CONCEPT)
    view-table
    (parent-view :range INSTANCE-WITH-VIEWS)
    ))

(defclass INSTANCE-WITH-VIEWS ()
   ((view-concept :range UNARY-CONCEPT)
    view-table					; assoc list
    (parent-view :range INSTANCE-WITH-VIEWS)
    ))



;; WAIT AND SEE WHO CALLS THIS; THEN REWRITE:

(defmethod get-views ((self DB-INSTANCE) viewConcept)
  "Return the list of view instances of `self' for the view
   concept `viewConcept'."
  (cdr (assoc viewConcept (view-table self))) )

(defmethod get-views ((self INSTANCE-WITH-VIEWS) viewConcept)
  ;; Return the list of view instances of "self" that match the view
  ;;    concept "viewConcept";
  (cdr (assoc viewConcept (view-table self))) )

(defmethod get-views ((self CLOS-INSTANCE) viewConcept)
  ;; Generate an error, since "self" cannot have views;
  (error "Cannot ask for views on the CLOS instance ~S because it does not
          inherit the mixin class INSTANCE-WITH-VIEWS" self))

(defun view-concept-p (concept)
  ;; Return t iff "concept" is a view of another concept;
  (view-of concept) )


  ;;
;;;;;; create-view
  ;;

(defun create-view-instance (self viewConcept)
  "Create and return a new view of the instance `self' for the view concept
   `viewConcept'."
  ;; Find the root view for "self";
  ;; If the root view does not yet have a view table, create one for it;
  ;; Create a new view instance;
  ;; If there exist view concepts above `viewConcept' in the hierarchy
  ;;    then create intermediate view instances;
  ;; Create "parent-view" links and new view table entries;
  (when (not (view-concept-p viewConcept))
    (warning "Cannot define a view for the concept ~S because ~S is not
                declared to be a view of any other concept"
	     viewConcept viewConcept)
    (return nil))
  (validate-viewable-instance self)
  (let* ((viewTable (view-table self))
	 rootInstance rootConcept)
    (flet ((create-chain-of-view-instances
	     (childViewConcept)
	     (if (eq childViewConcept rootConcept)
		 rootInstance 
		 (let* ((parentViewInstance
			  (create-chain-of-view-instances (view-of childViewConcept)))
			(childViewInstance (make-view-instance self)))
		   (setf (view-table childViewInstance) viewTable)
		   ;; add view table entry, but don't disturb the first entry:
		   (push (cons childViewConcept childViewInstance)
			 (rest viewTable))
		   (setf (parent-view childViewInstance) parentViewInstance)
		   childViewInstance))))
      (setq rootInstance
	(if viewTable
	    (second (first viewTable))
	  ;; else "self" is a root instance without a view table:
	  (progn
	    (push (cons *Thing* self) (view-table self))
	    self)))
      ;; compute the root concept:
      (loop
	(setq rootConcept (view-of viewConcept))
	(when (not (view-concept-p rootConcept))
	  (return nil)))
      (assert-conjunct rootInstance rootConcept :domain/range)
      (create-chain-of-view-instances viewConcept) )))

(defmethod make-view-instance ((self DB-INSTANCE))
  ;; Return a view instance appropriate to the type of "self";
  (make-instance 'DB-INSTANCE) )

(defmethod make-view-instance ((self CLOS-INSTANCE))
  ;; Return a view instance appropriate to the type of "self";
  (make-object (CLOS::class-of self)) )



(defmethod validate-viewable-instance ((self DB-INSTANCE))
  ;;
  t )

(defmethod validate-viewable-instance ((self INSTANCE-WITH-VIEWS))
  ;;
  t )

(defmethod validate-viewable-instance (self)
  ;;
  (error "System expects ~S to be an instance that can have
          attached views." self) )

(defmethod validate-viewable-instance ((self CLOS-INSTANCE))
  ;;
  (error "System expects ~S to be an instance that can have
          attached views, but it does not inherit the mixin
          class INSTANCE-WITH-VIEWS" self self) )


  ;;
;;;;;; View functions for evaluating domain arguments to predicates
  ;;


#|
The retrieval code distinguishes between relations that are attached
view concepts and those that aren't.  For the former, explicit coersion
code is generated, via a call to "get-relative-views".  That code
coerces whatever argument it is given into an appropriate (set of)
view instances.  For the latter, the dispatching for "db-slot-value'
is sensitive to the case when a non-view relation is applied to a
view instance.
|#

;;; WE MAY OR MAY NOT WITH TO DO THIS:
(defmethod db-slot-value ((self INSTANCE-WITH-VIEWS) extendedSlotName)
  ;;
  (if (null (parent-view self))
      (CLOS::call-next-method)
      (CLOS::call-next-method
	(second (first (view-table self)))
	extendedSlotName)) )

(defmethod get-relative-views (self targetConcept)
  ;; Return view instances related to `self' that match `targetConcept'.
  ;;    First consider instances above or below `self' in the view instance;
  ;;    Next, check for sibling instances if `targetConcept' is not
  ;;       above or below the view concept for `self';
  ;; `targetConcept' must be a view concept;
  (flet ((proper-descendant-p
	   (view)
	   (loop
	     (setq view (parent-view view))
	     (cond
	       ((null view) (return nil))
	       ((eq view self) (return t))))))	   
    (let ((selfConcept (view-concept self)))
      (cond
	((eq selfConcept targetConcept)
	 (list self))
	((subconcept-p selfConcept targetConcept)
	 ;; run up the parent links from "self" looking for a view
	 ;;    instance that matches "viewConcept" (it is
	 ;;    guaranteed that one exists):
	 (loop
	   (setq self (parent-view self))
	   (when (eq (view-concept self) targetConcept)
	     ;; exit loop:
	     (return (list self)))
	   ;; continue loop:
	   ))
	((subconcept-p targetConcept selfConcept)
	 (for v in (cdr (assoc targetConcept (view-table self)))
	      when (proper-descendant-p v)
	      collect v))
	(t
	 (cdr (assoc targetConcept (view-table self))))) )))



