;;; -*- Mode: Lisp; Package: LAPIDARY -*-
;;;
;;; This file contains definitions of lapidary objects and variables
;;; that production programs must use

(in-package "LAPIDARY" :use '("LISP" "KR"))

(export '(lapidary-agg editor-menu load-instances))

(defvar *CREATED-INSTANCES* NIL
  "list of objects created by loading a lapidary-generated file")

;;; controls visibility slot of feedback objects. In production programs,
;;; feedback objects are always in "test" mode

(defvar editor-menu nil)
(defvar *custom-constraint* nil)

(defun dependency-any-slot-p (schema obj slot)
  (let ((formula (get-value schema slot)))
    (when (formula-p formula)
      (dolist (dependencies (get-values obj :depended-slots))
	(when (member formula (cdr dependencies))
	  (return-from dependency-any-slot-p t))))
    nil))

(defun depends-on-p (p-selection slot s-selection link)

  ;; determine if the formula depends on the secondary selection
  (if (is-a-p (get-value p-selection slot) *custom-constraint*)
      ;; if this is a custom formula, determine whether the
      ;; slot in the primary selection depends on any of the
      ;; slots in the secondary selection
      (dependency-any-slot-p p-selection s-selection slot)
      
      ;; if this is a lapidary formula, determine whether the
      ;; slot in the primary selection depends on the same slot
      ;; in the secondary selection
      (eq (g-value p-selection link) s-selection)))

(defun is-a-line-p (obj) nil)

(create-schema 'editor-menu
  (:build-p nil))

(defvar lapidary-agg nil)
(create-instance 'lapidary-agg opal:aggregadget
   (:left most-positive-fixnum) ; bounding box is initially empty
   (:top most-positive-fixnum)
   (:width most-negative-fixnum)
   (:height most-negative-fixnum)
   (:update-slots '(:bb :left :top :width :height)) ; these slots must
                                                    ; be recomputed when they change
   ; :bb computes the bounding box of the aggregate. it then
   ; computes new offsets for each of the children and then
   ; places the new bounding box values in the appropriate
   ; slots in the aggregate (if they are not computed by a
   ; formula) or marks these slots as out of date (if they
   ; are computed by a formula). This ensures that if one of
   ; the aggregate's components is moved, resized, or destroyed,
   ; or if a new component is added to the aggregate, that the
   ; aggregate will still obey all its constraints.
   
   (:bb (o-formula 
	 (let ((left most-positive-fixnum)
	       (top most-positive-fixnum)
	       (right most-negative-fixnum)
	       (bottom most-negative-fixnum)
	       (agg (gv :self))
	       width height)
	   ; compute the bounding box
	   (dovalues (child agg :components)
		     (setf left (min left (gv child :left)))
	     (setf top (min top (gv child :top)))
	     (setf right (max right (opal:gv-right child)))
	     (setf bottom (max bottom (opal:gv-bottom child))))
	   
	   ; compute the width and height of the bounding box
	   (setf width (- right left))
	   (setf height (- bottom top))
	   
	   ; set the children's offsets
	   (dovalues (child agg :components :in-formula t)
	     (if (is-a-line-p child)
		 (if (eq (left-endpoint child) :x1)
		     (progn
		       (do ((slots '(:x1 :x2 :y1 :y2) (cdr slots))
			    (offsets '(:x1-offset :x2-offset :y1-offset :y2-offset)
				     (cdr offsets))
			    (links '(:x1-over :x2-over :y1-over :y2-over)
				   (cdr links))
			    (bbox (list left right top bottom) (cdr bbox)))
			   ((null slots))
			 (let* ((slot (car slots))
				(value (get-value child slot)))
			   (when (or (not (formula-p value))
				     (depends-on-p child slot 
						   agg (car links)))
			     (s-value child (car offsets)
				      (- (gv child slot) (car bbox)))))))
		     (progn
		       (do ((slots '(:x2 :x1 :y2 :y1) (cdr slots))
			    (offsets '(:x2-offset :x1-offset :y2-offset :y1-offset)
				     (cdr offsets))
			    (links '(:x2-over :x1-over :y2-over :y1-over)
				   (cdr links))
			    (bbox (list left right top bottom) (cdr bbox)))
			   ((null slots))
			 (let* ((slot (car slots))
				(value (get-value child slot)))
			   (when (or (not (formula-p value))
				     (depends-on-p child slot 
						   agg (car links)))
			     (s-value child (car offsets)
				      (- (gv child slot) (car bbox))))))))
		 (progn
		       (do ((slots '(:left :top :width :height) (cdr slots))
			    (offsets '(:left-offset :top-offset 
				       :width-difference :height-difference)
				     (cdr offsets))
			    (links '(:left-over :top-over :width-over :height-over)
				   (cdr links))
			    (bbox (list left top width height) (cdr bbox)))
			   ((null slots))
			 (let* ((slot (car slots))
				(value (get-value child slot)))
			   (when (or (not (formula-p value))
				     (depends-on-p child slot 
						   agg (car links)))
			     (s-value child (car offsets)
				      (- (gv child slot) (car bbox)))))))))
	   ; set or mark as out of date the appropriate slots
	   ; in the aggregate
	   (do ((slots '(:left :top :width :height) (cdr slots))
		(value (list left top width height) (cdr value)))
	       ((null slots))
	     (let ((slot (car slots)))
	       (s-value agg slot (car value))))))))

;;; load a file of gadgets into memory and return the list of created objects

(defun load-instances (loader-fct required-objs created-objs)
  (let (file created-instances) 
    (dolist (item required-objs) 
      (when (not (boundp item)) 
	(format t "~% please enter the name of a file that contains ~S: " 
		(symbol-name item))
	(setf file (read-line)) 
	(if (read-from-string file) ; if the user actually entered something 
	    (progn 
	      (load file) 
	      ; the user could demur in defining objects necessary for 
	      ; the definition of item so we must make sure that item 
	      ; was actually created	
	      (when (not (boundp item)) 
		(format t "~% aborting load ~%") 
		(setf *created-instances* nil)
		(return-from load-instances))
	      
	      ; add the created instances to the created-instances list
	      (setf created-instances (append created-instances 
					      *created-instances*)))
	    ; else user entered nothing so we better not create the 
	    ; aggregadgets. 
	    (progn 
	      (format t "~% aborting load ~%")
	      (setf *created-instances* nil) 
	      (return-from load-instances)))))

    ;; now create the objects
    (funcall loader-fct)
    
    ; add the created instances to the created-instances list
    (setf created-instances (append created-instances 
				    (mapcar #'eval created-objs)))

    (setf *created-instances* created-instances)
    created-instances))
