;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Changes:
;;; 7/15/92 koz,dzg: As per comment in update-window dated 15-Jul-92, changed
;;;		free-invalid-objects macro to not clear invalid-objects list
;;;		(as this is now done at the head of update-method-window).
;;; 6/23/92 ECP Due to new KR, it is now necessary to make graphical
;;;		objects valid after they are drawn.
;;; 6/15/92 DZG Prevented legal-type-p from giving a meaningless message
;;;             for numbers, strings, etc.
;;; 4/13/92 ECP Added :initial-element NIL to make-array, since in CMUCL
;;;		the default initial value is 0.
;;; 2/19/92 ECP Implemented double-clip-masks as list of length 8.
;;; 2/10/92 ECP Use #+garnet-debug to control Opal type checking.
;;; 1/24/92 DZG/ECP To get :update-slots, call get-value, not get-local-value.
;;; 1/16/92 ECP In update method for aggregate, simply call update
;;;		recursively, rather than call update-method-aggregate or
;;;		update-method-graphical-object.
;;; 3/25/91 ECP In update method for aggregates, in the dovalues loop,
;;;		added :local t so that we just draw local components.
;;; 6/12/90 BVZ Added call to clear-dirty-bits in :update method of aggregate
;;; 5/31/90 ECP Removed type-checking for :justification slot
;;; 4/12/90 ECP When updating an element of :update-slots-values, if the
;;;		new value is a list, we want to put in a copy-list of
;;;		the value.  Otherwise they'll be pointing to the same
;;;		thing, and we won't be able to tell if the value changes.
;;; 1/25/90 ECP Removed references to xlib:image-p, which is not in
;;;             the R4 release of CLX.
;;; 2/1/90  ECP Changed eq to equal.
(in-package "OPAL" :use '("LISP" "KR"))

;;; This macros demands that there be at least ONE invalid object in the
;;; window, lest it do strange things...

(defmacro free-invalid-objects(invalid-objs last-invalid-obj)
  `(progn
    (setf (cdr ,last-invalid-obj) *free-cons*)
    (setf *free-cons* ,invalid-objs)
    #+COMMENT
    ;; koz,dzg: Commented out - see comment in update-window, dated 15-Jul-92
    (setf (win-update-info-invalid-objects ,win-info)
     (setf (win-update-info-last-invalid-obj ,win-info)
      NIL))))

;;; This is a type-checking facility, called any time an object's slot has
;;; changed its value.  It's only invoked if :garnet-debug is on the features
;;; list.  All boolean slots (:visible :fast-redraw-p :open-p :actual-heightp)
;;; cannot be type-checked, since any non-NIL value is True.
(defun legal-type-p (object slot value)
  (let ((expected-string
   (case slot
    ((:top :left :x1 :x2 :y1 :y2 :head-x :head-y :from-x :from-y)
	(unless (typep value 'integer)
	  "integer"))
    ((:width :height :draw-radius :length :diameter)
	(unless (and (typep value 'integer) (>= value 0))
	  "non-negative integer"))
    (:line-style
	(unless (or (null value)
		    (is-a-p value opal:line-style))
	  "NIL or opal:line-style"))
    (:filling-style
	(unless (or (null value)
		    (is-a-p value opal:filling-style))
	  "NIL or opal:filling-style"))
    (:draw-function
	(unless (assoc value *function-alist*)
	  "car-member of opal::*function-alist*"))
    (:radius
	(unless (or (and (typep value 'integer) (>= value 0))
		    (member value '(:small :medium :large)))
		"non-negative integer, or one of (:small :medium :large)"))
    ((:angle1 :angle2)
	(unless (numberp value)
	  "number"))
    (:point-list
      (unless
	(and (listp value)
	     (zerop (mod (length value) 2))		;; of even length?
	     (not (dolist (coord value)
		    (unless (typep coord 'integer) (return T)))))
	"Even-length list of integers"))
    ((:string :title :icon-title)
	(unless (or (null value) (stringp value))
	  "NIL or string"))
    (:x-substr
	(unless (stringp value)
	  "string"))
    (:font
       (unless
	(or (is-a-p value opal:font)
	    (is-a-p value opal:font-from-file))
	"opal:font or opal:font-from-file"))
    (:xfont
	(unless (xlib:font-p value)
	  "anything s.t. xlib:font-p returns T"))
    (:text-extents
	(unless (listp value)
	  "list"))
    (:cursor-index
      (unless
	(or (null value)
	    (and (typep value 'integer) (>= value 0)))
	"NIL or non-negative integer"))
    (:cut-strings
      (unless
	(and (listp value)
	     (not (dolist (cut-string-member value)
		    (unless (cut-string-p cut-string-member) (return T)))))
	"possibly empty list of opal:cut-string"))
    (:image			;; bitmap
	(unless (typep value 'xlib::image)
	  "anything of type xlib::image"))
    (:aggregate
      (unless
	(or (null value)
	    (is-a-p value opal:aggregate))
	"NIL or opal:aggregate"))
    (:parent			;; window's can only have window's!
      (unless
	(or (null value)
	    (if (is-a-p object opal:window)
		(is-a-p value opal:window)
		T))
	(if (is-a-p object opal:window)
		"NIL or opal:window"
		"NIL or any opal schema")))
    (:cursor
      (unless
	(and (listp value)
	     (is-a-p (car value) opal:bitmap)
	     (is-a-p (cdr value) opal:bitmap))
	"(opal:bitmap  .  opal:bitmap)"))
    (:display
	(unless (stringp value)
	  "string"))
    (otherwise
	NIL)
   )))
   (if expected-string
    (progn
     (format t "~%*** Warning, Illegal value! --  Object  ~A~%" object)
     (format t   "                                Slot    :~A~%" slot)
     (format t   "                                Value   ")
     (format t "~S~%" value)
     (if (and value (atom value) (symbolp value) (not (keywordp value)))
       (format
	t
	"*** This is an atom, perhaps it is quoted where it shouldn't be?~%"))
     (format t "*** Expected type -- ~A~%~%" expected-string)
     NIL
    )
    T)
  )
)


;;; This can no longer be set since type-checking is controlled
;;; by the compile-time switch #+garnet-debug
#|
;; This is the EXPORTED function which turns on and off the type-checking.
;; If you call it with no arguments, then it tells the status of type-checking.
(defun type-check (&rest t-or-nil)
  (cond	((null t-or-nil)
		(format t "Opal's Type-Checking is ~A~%"
			(if *opal-type-check* "ON" "OFF"))
		*opal-type-check*)
	((cdr t-or-nil)
		(format t "*** opal:type-check takes no more than 1 arg!~%"))
	(t
		(setq *opal-type-check* (car t-or-nil)))))
|#

(defun type-check (&rest t-or-nil)
  (if t-or-nil
      (progn
        (format t "*** opal:type-check can no longer take an argument~%")
	(format t "as of release 2.0. Type-checking is now controlled by~%")
	(format t "the compile-time switch #+garnet-debug ***~%~%"))
      #+garnet-debug T
      #-garnet-debug NIL))

;;; This updates the :update-slots-values slot, which should hold a list
;;; containing the values of the update-slots at the last update.  It also
;;; returns T iff one of them has changed (ie, we need to be updated).
;;; This also sets update-info-force-computation-p to NIL, since we definitely
;;; don't need to do this after running this macro.
(defun update-slots-values-changed (object first-changed obj-update-info)
 (let* ((update-slots-values (g-local-value object :update-slots-values))
	;; dzg - changed from GET-LOCAL-VALUE to GET-VALUE
	 (start-slot-list (get-value object :update-slots))
	 (first-p (null update-slots-values))
	  changed-p new-value)
   (if first-p
	(setq update-slots-values
	  (s-value object :update-slots-values
	    (make-array (length start-slot-list) :initial-element nil))))
   (setf (update-info-force-computation-p obj-update-info) NIL)
   (dotimes (x first-changed)
	(setq start-slot-list (cdr start-slot-list)))
   (do  ((slot-list start-slot-list (cdr slot-list))
	 (vals-indx first-changed (1+ vals-indx)))
	((null slot-list) changed-p)
	(if (equal (aref update-slots-values vals-indx)
		   (setq new-value (g-value object (car slot-list))))
	  #+garnet-debug
	  (and first-p (legal-type-p object (car slot-list) new-value))
	  #-garnet-debug NIL
	  (progn
	    #+garnet-debug (legal-type-p object (car slot-list) new-value)
	    (setf (aref update-slots-values vals-indx)
		(if (listp new-value) (copy-list new-value) new-value))
	    (setq changed-p T))))))

;;; This is the same as the previous call, but it only checks if a value has
;;; changed.  If so, it returns the index into update-slots-values of the first
;;; changed entry.  Elsewise, it returns NIL.  This does not alter anything!
;;; It is used in only one place, to check if a fastdraw object has really
;;; changed when it is invalidated.
;;; If there is no update-slots-values entry, it just returns 0.
(defun simple-update-slots-values-changed (object)
 (let ((update-slots-values (g-local-value object :update-slots-values)))
  (if update-slots-values
	;; ecp - changed from GET-LOCAL-VALUE to GET-VALUE
   (do  ((slot-list (get-value object :update-slots) (cdr slot-list))
	 (vals-indx 0 (1+ vals-indx)))
	((null slot-list) NIL)
	(unless (equal (aref update-slots-values vals-indx)
		       (g-value object (car slot-list)))
	  (return vals-indx)))
   0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Now makes the aggregate's :old-bbox valid at all times!!!
;;; DO NOT CALL THIS UNLESS THE AGGREGATE IS DEFINITELY VISIBLE!!!
(define-method :update opal:aggregate (agg update-info
				       line-style-gc filling-style-gc
				       drawable root-window
				       clip-mask bbox-1 bbox-2
				       &optional (total-p NIL))
  (let ((dirty-p (update-info-dirty-p update-info))
	(agg-bbox (update-info-old-bbox update-info)))
      (when
	(or  dirty-p
	     total-p
	     (and (bbox-valid-p agg-bbox)
	          (bbox-intersects-either-p agg-bbox bbox-1 bbox-2)))
	(let (child-update-info child-bbox)
	  (setf (bbox-valid-p agg-bbox) NIL)		;; clear the old one!
	  (dovalues (child agg :components :local t)
	    (if (g-value child :visible)
		(progn
		  (setq child-bbox
			(update-info-old-bbox
			 (setq child-update-info
			       (g-local-value child :update-info))))
		  (update child child-update-info
                                line-style-gc filling-style-gc
                                drawable root-window
                                clip-mask bbox-1 bbox-2
                                total-p)
		  (merge-bbox agg-bbox child-bbox))	;; and set the new one!
		; else
		;; if the child's dirty bit is set, recursively visit the child
		;; and all its children and turn off their dirty bits
		(let ((child-update-info (g-local-value child :update-info)))
		  (when (update-info-dirty-p child-update-info)
		     (clear-dirty-bits child child-update-info)))))
	  (if dirty-p (setf (update-info-dirty-p update-info) NIL))
	))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This will not be called unless the gob is already visible!!!
(define-method :update opal:graphical-object (gob update-info
				       line-style-gc filling-style-gc
				       drawable root-window
				       clip-mask bbox-1 bbox-2
				       &optional (total-p NIL))
  (let ((old-bbox (update-info-old-bbox update-info)))
    (unless (update-info-on-fastdraw-list-p update-info)
      (cond (total-p
		(update-slots-values-changed gob 0 update-info)
		(update-bbox gob old-bbox)
		(draw gob line-style-gc filling-style-gc drawable
			root-window :none) ;draw w/o mask
		(setf (update-info-dirty-p update-info) NIL))

	    ((update-info-dirty-p update-info)
		(when (update-info-force-computation-p update-info)
		   (update-slots-values-changed gob 0 update-info)
		   (update-bbox gob old-bbox))
		(draw gob line-style-gc filling-style-gc drawable
				root-window clip-mask)
		(setf (update-info-dirty-p update-info) NIL))

	    (bbox-2			; 2 valid clip-masks?
		(when (or (bbox-intersect-p old-bbox bbox-1)
			  (bbox-intersect-p old-bbox bbox-2))
		  (draw gob line-style-gc filling-style-gc drawable
				root-window clip-mask)))
	    ((bbox-intersect-p old-bbox bbox-1)
		(draw gob line-style-gc filling-style-gc drawable
				root-window clip-mask)))
      ;; New line added because of new KR 2.0.10 -- ECP 6/23/92
      ;; Without this line, the Save window in garnetdraw does not update.
      (setf (update-info-invalid-p update-info) nil)
      )))
		
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
