;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: LAPIDARY; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; -*- Mode: Lisp; Package: LAPIDARY -*-
;;;
;;; This file provides support for creating formulas in lapidary. It 
;;; contains a set of functions that construct formulas which traverse
;;; an aggregate hierarchy to find an object.

(in-package "LAPIDARY" :use '("LISP" "KR"))
#|
========================================================================
Change log:
         8/24/92 Martin Sjolin - Fixed check for 'if in Install-Formulas-
             In-Links.
         7/13/92 Brad Vander Zanden - expanded install-formulas-in-links
             so that it installs formulas in user-defined links as well
             as lapidary-defined links
========================================================================
|#

(defvar *non-link-slots* (list :parent :visible :obj-over :selected))
(defvar *link-slots* (list :left-over :top-over :width-over :height-over
			   :x1-over :x2-over :y1-over :y2-over))

;;; =================================================================
;;; return a list of all components in an aggregate, including the
;;; aggregate itself
;;; =================================================================
(defun transitive-closure (agg)
  (let (components)
    (dovalues (obj agg :components)
	      (setf components (append components (transitive-closure obj))))
    (push agg components)
    components))

;;; =================================================================
;;; return a list of all components in the passed objects, including 
;;; the objects themselves
;;; =================================================================
(defun get-all-objects (objs)
  (let (components)
    (dolist (obj objs)
	    (if (is-a-p obj opal:aggregate)
		(setf components (append components (transitive-closure obj)))
	        (push obj components)))
    components))

;;; =================================================================
;;; determine if a slot is potentially a link slot. A slot can be a
;;; link slot if it is not on a list of slots that cannot
;;; be links (e.g., :parent, :visible, :obj-over), it contains a 
;;; kr schema which is not an opal graphic quality, and the slot's
;;; value is not computed by a formula; slots computed by formulas
;;; could be link slots, but are not considered link slots for the
;;; purposes of this function
;;; =================================================================
(defun link-p (schema slot)
  (let ((value (get-value schema slot)))
    (when (and (not (formula-p value))
	       (schema-p value)
	       (not (is-a-p value opal:graphic-quality))
	       (not (member slot *non-link-slots*))))))

;;; =================================================================
;;; Examine the link slots in each of the passed objects. If a link
;;; slot references another of the passed objects, place a formula
;;; in the slot that traverses the aggregate hierarchy in order to 
;;; reach the object it references
;;; =================================================================

(defun install-formulas-in-links (objs)
  (declare (special save-time-do-not-dump-slots))
  (dolist (obj objs)
    ;; find all link slots and establish a formula so that they still
    ;; refer to the object they currently point at. A link slot is a
    ;; slot that contains a view object, is not on the 
    ;; save-time-do-not-dump-slots list, and is not a :parent slot
    ;; or a link slot for an aggregadget
    
    (let ((aggregadget-links '(:parent :prev :next)))
      (dolist (child (g-value obj :components))
	      (push (g-value child :known-as) aggregadget-links))
      (doslots (slot obj)
       (let ((value (get-value obj slot)))
	 ;; determine if value is atomic or a formula. if it's a
	 ;; formula, it could be a by-demo formula. if the formula
	 ;; contains an object that has to be converted, the object
	 ;; will be found in either the true or false branches of
	 ;; the if statement. 
	 (when (and (is-a-p value opal:view-object)
		    (not (member slot save-time-do-not-dump-slots))
		    (not (member slot (g-value obj :do-not-dump-slots)))
		    (not (member slot aggregadget-links)))
	       (if (formula-p value)
		   (progn
		     (let ((form (extract-formula value)))
		       (when (eq (first form) 'if)
			     (let ((true-expr (third form))
				   (false-expr (fourth form))
				   changed-p)
			       (when (member true-expr objs)
				     (setf (third form)
					   `(gvl ,@(make-path obj true-expr)))
				     (setf changed-p t))
			       (when (member false-expr objs)
				     (setf (fourth form)
					   `(gvl ,@(make-path obj false-expr)))
				     (setf changed-p t))
					   (when changed-p
						 (change-formula obj slot form))))))
		 (when (member value objs)
		       (s-value obj slot 
				(formula `(gvl ,@(make-path obj value))))))))))))

  
(defun generate-link-name (obj)
  (let ((counter 0)
	link)
    (setf link (read-from-string
		(concatenate 'simple-string ":link-" 
			     (princ-to-string counter))))
    (loop
     (when (not (has-slot-p obj link))
	   (return))
     (incf counter)
     (setf link (read-from-string
		 (concatenate 'simple-string ":link-" 
			      (princ-to-string counter)))))
    link))
  
;;; =================================================================
;;; constructs a path that gvl can use to get from the source object
;;; to the destination object. this is done in three stages. first
;;; all objects on the path from the source object to the top-level 
;;; aggregate are marked. second all objects on the path from the 
;;; destination object to the common ancestor of the source and 
;;; destination objects (this will be the first marked object) are 
;;; visited and their links are pushed onto the path. third, all objects
;;; on the path from the source object to the common ancestor are visited
;;; and :parent links are pushed onto the path. this third pass continues
;;; up to the top-level aggregate and unmarks all objects on the way up
;;; =================================================================

(defun make-path (src dest)
  (let (parent path parent-path)
    ;; check if the src and dest are the same
    (when (eq src dest)
      (return-from make-path nil))
    ;; optimize for the case where the source and destination objects
    ;; are siblings (i.e., have the same parent)
    (if (eq (g-value src :parent) (g-value dest :parent))
	(setf path (list :parent (g-value dest :known-as)))
	(progn
	  ;; first pass--mark all objects between source object and top
	  ;; level aggregate
	  (setf parent src)
	  (loop 
	    (set-marked-bit parent t)
	    (setf parent (or (g-value parent :parent) 
			     (g-value parent :operates-on)))
	    (when (null parent)
	      (return)))

	  ;; second pass--push the names of all objects between the destination
	  ;; object and the source and destination objects' common ancestor
	  ;; onto the path
	  (setf parent dest)
	  (loop
	    ;; common ancestor is first marked object
	    (when (marked-p parent)
	      ;; common ancestor is made unmarked
	      (set-marked-bit parent nil)
	      (return))
	    ;; if parent is an aggrelist, the aggrelist will not have
	    ;; a pointer to this object. Create a link that will point
	    ;; to this object and push the generated link name onto the path
	    (if (is-a-p (g-value parent :parent) opal:aggrelist)
		(let* ((true-parent (g-value parent :parent)) 
		       link
		       (index (position parent 
					(g-value true-parent :components))))
		  ;; try to find a link in parent's parent that points to
		  ;; it. if none do, generate a new link
		  (setf link (dolist (l (g-value true-parent :links))
				     (when (eq (g-value true-parent l) parent)
					   (return l))))
		  (when (null link)
			(setf link (generate-link-name true-parent)))
		  (push link path)
		  (push link (g-value true-parent :links))
		  (s-value true-parent link 
			   (eval `(o-formula (nth ,index (gvl :components))))))
	        (push (g-value parent :known-as) path))
	    (setf parent (g-value parent :parent)))

	  ;; third pass--push :parent links onto the path for all objects
	  ;; between the source object and the common ancestor. then
	  ;; continue to the top-level aggregate and unmark all objects
	  ;; on the way
	  (setf parent src)
	  (loop
	    ;; common ancestor is first unmarked object
	    (when (not (marked-p parent)) 
	      (loop
		(setf parent (or (g-value parent :parent)
				 (g-value parent :operates-on)))
		(when (null parent)
		  (return))
		(set-marked-bit parent nil))
	      (return))
	    (if (g-value parent :parent)
		(push :parent parent-path)
	        (push :operates-on parent-path))
	    (set-marked-bit parent nil)
	    (setf parent (or (g-value parent :parent)
			     (g-value parent :operates-on))))
	  (append (reverse parent-path) path)))))
