;;;-*- Mode:Common-Lisp; Package:PICTURES; Base:10 -*-
;;;
;;;
;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 149149
;;;			       AUSTIN, TEXAS 78714-9149
;;;
;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Authors: Delmar Hager, James Dutton, Teri Crowe
;;; Contributors: Kerry Kimbrough, Patrick Hogan, Eric Mielke

(in-package "PICTURES")


(export '(
	  graphic-events-enabled-p 
	  view
	  view-scale
	  view-scale-x
          view-scale-y
	  make-view
	  display
	  gravity-point
	  view-gravity
	  view-pan
	  view-show-world
	  view-show-region
	  view-damage
	  view-damaged-p
	  view-graphic
	  view-pixel-size
	  view-highlight-color
	  refresh-view
	  repair-view
	  view-scale-point
	  transform-point
	  transform-x
	  transform-y
	  view-transform-vector
	  view-untransform-point
	  view-untransform-x
	  view-untransform-y
	  view-zoom
	  world-extent
	  view-draw-arc
	  view-draw-filled-arc
	  view-draw-line
	  view-draw-polypoint
	  view-draw-polyline
	  view-draw-polygon
	  view-draw-filled-polygon
	  view-draw-image
	  view-draw-rectangle
	  view-draw-filled-rectangle
	  view-draw-text
	  view-draw-image-text
	  view-draw-char
	  view-draw-image-char
	  handle-event
	  graphic-pick
	  graphic-within
	  view-selection
	  view-add-selection
	  view-remove-selection
	  view-clear-selection
	  view-select-graphic
	  view-unselect-graphic
	  view-select-region
	  view-unselect-region
	  view-x-pan
	  view-y-pan
	  view-pan-left
	  view-pan-right
	  view-pan-up
	  view-pan-down
	  untransform-point
	  view-orientation
	  origin-x
	  orinin-y
	  )
	'pictures)


(DEFPARAMETER  *an-extent-rectangle* (make-extent-rect))

;Private Macro: valid-xcoord
;  Determine whether the given VAR is a valid coordinate for the X window system



;Function: make-view
;  Return a new view object.

(defun make-view (&rest options &key &allow-other-keys)
  "Make a new view.
The following keyword OPTIONS are allowed: GRAVITY RESIZE-EXTENT-P SCALE ORIGIN-X ORIGIN-Y GRAPHIC"

  (declare (values view))
  (apply #'make-contact 'view options))

;Basic contact methods:

	

(DEFUN get-contact-background (view)
  (IF view
       (LET ((background (contact-background view)))
	 (COND
	   ((NUMBERP background) background)
	   ((pixmap-p background) 0)
	   ((EQL background :none) 0)
	   ((EQL background :parent-relative) (get-contact-background (contact-parent view)))))
       0))

(DEFMETHOD initialize-instance :after ((view view) &key)
  (with-slots (grabber-rect-transform) view
    (SETF grabber-rect-transform (make-transform))))

(DEFMETHOD realize :after ((view view))

  (with-slots (default-gcontext selection highlight-color) view
    (setf default-gcontext (create-gcontext :drawable view ))
    (LET ((black (screen-black-pixel (contact-screen view)))
	    (white (screen-white-pixel (contact-screen view)))
	    (background (get-contact-background view)))
	
	(IF 
	  (EQL  background black)
	    (PROGN 
	      (SETF (gcontext-foreground default-gcontext) white )
	      (SETF (gcontext-background default-gcontext) black ))
	    (PROGN 
	      (SETF (gcontext-foreground default-gcontext) black )
	      (SETF (gcontext-background default-gcontext) white )))
	(SETF highlight-color (LOGXOR (gcontext-foreground default-gcontext)(gcontext-background default-gcontext)))
       
      
      )
    
    (LET ((selection-scene (make-selection-scene)))
      (SETF (graphic-view selection-scene)  view)	;attach the view-selection to a view
      (SETF (view-selection-scene view) selection-scene)
      (DOTIMES (place 10)
	(scene-insert selection-scene (make-grabber-rect view :parent selection-scene
							 :highlight (view-highlight-color view)))
	)
      (with-slots (elements parent) selection-scene
	(SETF (FILL-POINTER elements) 0)
	(SETF parent nil))
      
      (with-slots (view-graphic) view
	(UNLESS view-graphic
	  (SETF view-graphic (make-scene :sensitivity :subselectable))
	  (SETF (graphic-view view-graphic) view))))))



(DEFMETHOD resize :around ((view view) width height border-width)
  (with-slots (origin-x origin-y gravity ) view
     (MULTIPLE-VALUE-BIND (gravity-x gravity-y) (gravity-point view gravity)
	(call-next-method)
	(MULTIPLE-VALUE-BIND (new-gravity-x new-gravity-y)(gravity-point view gravity)
	  (SETF origin-x (- origin-x (- new-gravity-x gravity-x)))
	  (SETF origin-y (- origin-y (- new-gravity-y gravity-y)))))))
	  
;Method: display
;  Display the view contact after an exposure, etc.

(defmethod display ((view view) &optional (x 0) (y 0) (width (contact-width view))
		     (height (contact-height view)) &key)

  (with-slots (view-graphic damage-count origin-x origin-y  (contact-height height) default-gcontext gcontext) view
    (LET ((scale-x (view-scale-x view))
	  (scale-y (view-scale-y view))
	  (scale (view-scale view))
	  (pixel (view-pixel-size view)))
    
    (when view-graphic
      (IF (AND (= x 0) (= y 0) (= width (contact-width view)) (= height (contact-height view)))
	  (PROGN
	    (SETF damage-count 0)
	    (refresh-view view))
	  (progn
	    (view-damage view	; Notify damage control
			 (+ origin-x (- pixel) (/ x scale-x))
			 (+ origin-y (- pixel) (/ (- contact-height y height) scale-y))
			 (float (+ (/ width scale)  pixel))
			 (float (+ (/ height scale) pixel)))
	    (repair-view view)))))))	; Go repair the damage

;View Attribute Methods:
(defmethod gravity-point ((view view) gravity)
  (declare (type (member :northwest :north  :northeast
                         :west      :center :east
                         :southwest :south  :southeast)
                 gravity))
    (let* ((extent (world-extent view))			; Get the extent
           (xmin (extent-rect-xmin extent))
           (xmax (extent-rect-xmax extent))
           (ymin (extent-rect-ymin extent))
           (ymax (extent-rect-ymax extent))
           (xmid (/ (+ xmin xmax) 2.0))			; Compute mid points
           (ymid (/ (+ ymin ymax) 2.0)))
      (case gravity					; Return the appropriate coord
        (:northwest	(values xmin ymax))
        (:north		(values xmid ymax))
        (:northeast	(values xmax ymax))
        (:west		(values xmin ymid))
        (:center	(values xmid ymid))
        (:east		(values xmax ymid))
        (:southwest	(values xmin ymin))
        (:south		(values xmid ymin))
        (:southeast	(values xmax ymin)))))


(DEFMETHOD view-orientation ((view view) &key (x 1) (y 1))
  (SETF (view-scale-x  view) (* (SIGNUM x) (view-scale-x view))
	(view-scale-y  view) (* (SIGNUM y) (view-scale-y view))
	(slot-value (grabber-rect-transform view) 't11) (* (SIGNUM x) (slot-value (grabber-rect-transform view) 't11) )
	(slot-value (grabber-rect-transform view) 't22) (* (SIGNUM x) (slot-value (grabber-rect-transform view) 't22) )))

;Method: view-gravity
;  Returns or changes the current VIEW-GRAVITY.  The view-gravity is the
;  alignment point of the graphic's bounding rectangle that remains fixed (in
;  world coordinates) after the view window is resized.

(defmethod view-gravity ((view view))
  (declare (values (member :northwest :north  :northeast
                           :west      :center :east
                           :southwest :south  :southeast)))

  (with-slots (gravity) view
    gravity))

(defmethod (setf view-gravity) (gravity (view view))
  (declare (values (member :northwest :north  :northeast
                           :west      :center :east
                           :southwest :south  :southeast)))

  (with-slots ((view-gravity gravity)) view
    (setf view-gravity gravity)))


(DEFMETHOD view-scale ((view view))
  (ABS (view-scale-x view)))

(DEFMETHOD (SETF view-scale) (x (view view))
  (MULTIPLE-VALUE-BIND (pan-x pan-y) (gravity-point view (view-gravity view))
	 
    (SETF (view-scale-x view) (* (SIGNUM (view-scale-x view)) x)
	  (view-scale-y view) (* (SIGNUM (view-scale-y view)) x)
	  (slot-value (grabber-rect-transform view) 't11) (* (SIGNUM (view-scale-x view)) (/ 1 x) )
	  (slot-value (grabber-rect-transform view) 't22) (* (SIGNUM (view-scale-y view)) (/ 1 x) ))
    (view-pan view pan-x pan-y))
  x)
	   
;Method: view-pan
;  Change the VIEW so that the given point (X, Y) (in world coordinates) is located
;  according to the given ALIGN point of the view window.

(defmethod view-pan ((view view) x y &optional (gravity (view-gravity view)))
  (declare (type (member :northwest :north  :northeast
                         :west      :center :east
                         :southwest :south  :southeast)
                 gravity))

  (with-slots (width height origin-x origin-y ) view
    (let* (
	   (scale-x (view-scale-x view))
	   (scale-y (view-scale-y view))
	   (wc-width  	   (float (/ width scale-x)))
           (wc-height 	   (float (/ height scale-y)))
           (wc-half-width  (float (/ wc-width 2)))
           (wc-half-height (float (/ wc-height 2))))
      (case gravity
        (:northwest	(setf origin-x x
                              origin-y (- y wc-height)))
        (:north		(setf origin-x (- x wc-half-width)
                              origin-y (- y wc-height)))
        (:northeast	(setf origin-x (- x wc-width)
                              origin-y (- y wc-height)))
        (:west		(setf origin-x x
                              origin-y (- y wc-half-height)))
        (:center	(setf origin-x (- x wc-half-width)
                              origin-y (- y wc-half-height)))
        (:east		(setf origin-x (- x wc-width)
                              origin-y (- y wc-half-height)))
        (:southwest	(setf origin-x x
                              origin-y y))
        (:south		(setf origin-x (- x wc-half-width)
                              origin-y y))
        (:southeast	(setf origin-x (- x wc-width)
                              origin-y y))))))
                    

(DEFMETHOD view-show-world ((view view))
 
  (LET ((extent (world-extent (view-graphic view))))
    (UNLESS (= (- (extent-rect-xmax extent)(extent-rect-xmin extent))
	       (- (extent-rect-ymax extent) (extent-rect-ymin extent)) 0)
      (SETF (view-scale view) (MIN (/ (contact-width view)
				      (- (extent-rect-xmax extent)(extent-rect-xmin extent)))
				   (/ (contact-height view)
				      (- (extent-rect-ymax extent) (extent-rect-ymin extent))))))

      (view-pan view (extent-rect-xmin extent)(extent-rect-ymin extent) )
      (refresh-view view)))



(DEFMETHOD view-show-region ((view view) extent)
  (UNLESS (= (- (extent-rect-xmax extent)(extent-rect-xmin extent))
	     (- (extent-rect-ymax extent) (extent-rect-ymin extent)) 0)

    (SETF (view-scale view) (MIN (/ (contact-width view)
				  (- (extent-rect-xmax extent)(extent-rect-xmin extent)))
			       (/ (contact-height view)
				  (- (extent-rect-ymax extent) (extent-rect-ymin extent))))))
  
  (LET* 
    ((extent-xmin (extent-rect-xmin extent))
     (extent-ymin (extent-rect-ymin extent))
     (extent-width (- (extent-rect-xmax extent)(extent-rect-xmin extent)) )
     (extent-height (-  (extent-rect-ymax extent)(extent-rect-ymin extent))))
    (MULTIPLE-VALUE-BIND (x y) (CASE (view-gravity view)
				 
				 (:southwest  (VALUES  extent-xmin
						       extent-ymin  ))
				 (:northwest  (VALUES  extent-xmin
						       (+ extent-ymin  extent-height) ))
				 (:south      (VALUES  (+ extent-xmin  (/ extent-width 2.0))
						       extent-ymin))
				 (:north      (VALUES  (+ extent-xmin  (/ extent-width 2.0))
						       (+ extent-ymin  extent-height)))
				 (:west       (VALUES  extent-xmin
						       (+ extent-ymin  (/ extent-height 2.0))))
				 (:center     (VALUES  (+ extent-xmin  (/ extent-width 2.0))
						       (+ extent-ymin  (/ extent-height 2.0))))
				 (:southeast  (VALUES  (+ extent-xmin extent-width)
						       extent-ymin))
				 (:northeast  (VALUES  (+ extent-xmin extent-width)
						       (+ extent-ymin  extent-height)))
				 (:east       (VALUES  (+ extent-xmin extent-width)
						       (+ extent-ymin  (/ extent-height 2.0))))
				 (t           (VALUES   extent-xmin
							extent-ymin))) 
      (view-pan view x y))
    
    ))

;Method: view-damage
;  Records a damaged region of the VIEW for later repair. The DAMAGED-REGION
;  contains either a single graphic object (in which case the damaged region is
;  given by the object's extent) or a world coordinate list of the form
;  (min-x min-y width height).

(defmethod view-damage ((view view) &rest damaged-region)
  (with-slots (damage-count damage) view
    (let ((new-damage (make-extent-rect))	; Compute damage extent rectangle
	  (view-extent (world-extent view))
          min-union max-intersect
          min-union-area
          (max-intersect-area 0))
      (if (typep (car damaged-region) 'graphic)
	  (PROGN
	    (UNLESS (extent-valid-p (CAR damaged-region))
	      (graphic-extent (CAR damaged-region)))
	    (world-extent (car damaged-region) new-damage))
	  
          (setf (extent-rect-xmin new-damage) (first  damaged-region)
		(extent-rect-ymin new-damage) (second damaged-region)
		(extent-rect-xmax new-damage) (+ (first damaged-region)
						 (third  damaged-region))
		(extent-rect-ymax new-damage) (+ (second damaged-region)
						 (fourth damaged-region))))
      (WHEN 
	(not (or
		   (> (extent-rect-xmin new-damage) (extent-rect-xmax view-extent))
		   (> (extent-rect-ymin new-damage) (extent-rect-ymax view-extent))
		   (< (extent-rect-xmax new-damage) (extent-rect-xmin view-extent))
		   (< (extent-rect-ymax new-damage) (extent-rect-ymin view-extent))))
	
	(dotimes (i damage-count)		; Calculate min-union and max-intersect
	  (let ((union-area     (rect-union new-damage (AREF damage i)))
		(intersect-area (rect-intersect new-damage (AREF damage i))))
	    
	    (when (or (null min-union)
		      (< union-area min-union-area))
	      (setf min-union-area union-area)
	      (setf min-union i))
	    
	    (when (> intersect-area max-intersect-area)
	      (setf max-intersect-area intersect-area)
	      (setf max-intersect i))))
	
	(cond
	  ((> max-intersect-area 0)		; It intersected with something
	   (rect-merge new-damage		; Use the largest such intersection
		       (aref damage max-intersect)))
	  
	  ((< damage-count max-damage)		; No intersection, room for more?
	   (incf damage-count)			; Yes, add it to the list
	   (setf (aref damage (- damage-count 1)) new-damage))
	  
	  (t					; Otherwise, just use the smallest union
	   (rect-merge new-damage
		       (aref damage min-union))))))))


;Method: view-damaged-p
;  Returns true if there are damaged regions to repair. May be used with SETF to
;  reset the VIEW's damage. If the new value is false, then any previous damage
;  is ignored; otherwise, the new value is ignored.

(defmethod view-damaged-p ((view view))
  (declare (values boolean))

  (with-slots (damage-count) view
    (eql damage-count 0)))


(defmethod (setf view-damaged-p) (damaged (view view))
  (declare (type boolean damaged))
  (declare (values boolean))

  (with-slots (damage-count) view
    (unless damaged (setf damage-count 0))))


;Method: view-graphic 
;  Returns or changes the SCENE associated with the given VIEW.



(defmethod  (setf view-graphic)  :after (view-graphic (view view)  )
  (declare (type (or null graphic) view-graphic))
  (declare (values view-graphic))
  (with-slots ((graphic view-graphic) )  view
    (SETF graphic view-graphic)
    (with-slots (views) view-graphic
      (push view views))))


;Method: view-pixel-size
;  Return the world-coordinate size of a pixel for the given VIEW.

(defmethod view-pixel-size ((view view))
  (declare (values pixel-size))

  (LET ( (scale (view-scale view)))
    (/ 1 scale)))


;Method: refresh-view
;  Redraws the entire VIEW scene and clears any damages.

(defmethod refresh-view ((view view))

  (with-slots (view-graphic origin-x origin-y width height  damage-count) view
    (LET ((scale-x (view-scale-x view))
	  (scale-y (view-scale-y view)))
      (clear-area view)
      (display-force-output (contact-display view))
      (setf damage-count 0)
      (when view-graphic
	(draw-graphic view-graphic view origin-x origin-y
		      (float (/ width scale-x))
		      (float (/ height scale-y)))
	(display-force-output (contact-display view))
	))
    ))

(DEFMETHOD refresh-view :after ((view view))
      (draw-graphic (view-selection-scene view) view)
 )
	
;Method: repair-view
;  Redraws any damaged regions in the VIEW and clears any damages.

(defmethod repair-view ((view view))

  (with-slots (damage-count damage view-graphic default-gcontext selection) view
   (dotimes (i damage-count)				; For each damage rectangle
      (let ((xmin (extent-rect-xmin (ELT damage i)))	; Store corners locally
            (ymin (extent-rect-ymin (ELT damage i)))
            (xmax (extent-rect-xmax (ELT damage i)))
            (ymax (extent-rect-ymax (ELT damage i)))
            (pixel (view-pixel-size view)))
      (multiple-value-bind (clip-xmin clip-ymin)	; Compute clipping rectangle
          (transform-point view xmin ymin)
        (multiple-value-bind (clip-xmax clip-ymax)
            (transform-point view xmax ymax)
	  (WHEN (< clip-xmax clip-xmin)
	    (rotatef clip-xmin clip-xmax))
	  (WHEN (< clip-ymax clip-ymin)
	    (rotatef clip-ymin clip-ymax))			; View coordinates are third quadrant
	  
          (clear-area view
                      :x clip-xmin
                      :y clip-ymin
                      :width  (- clip-xmax clip-xmin -1)
                      :height (- clip-ymax clip-ymin -1))
          (draw-graphic-clipped view-graphic view		; Draw view-graphic within damaged area
                        (- xmin (* 2 pixel))		
                        (- ymin (* 2 pixel))
                        (- xmax xmin (- (* 4 pixel))) 
                        (- ymax ymin (- (* 4 pixel))))
          (display-force-output (contact-display view))
          (setf (gcontext-clip-mask default-gcontext)	; Get rid of clip-mask
                :none)))))

    (setf damage-count 0))				; Clear the damages
  (draw-graphic (view-selection-scene view) view)		; Draw the highlight objects
  ) 




;Method: view-scale-point
;  Convert the given X-DISTANCE and Y-DISTANCE to equivalent distances in the
;  VIEW coordinate system.  If GRAPHIC-WORLD-TRANSFORM is given, apply it to the
;  distances before converting to view coordinates.

(defmethod view-scale-point ((view view) x-distance y-distance
                                       &optional graphic-world-transform)
  (declare (type (or null transform) graphic-world-transform))
  (declare (values (new-x-distance new-y-distance)))

  (with-slots ( height) view
    (LET ((scale-x (view-scale-x view))
	  (scale-y (view-scale-y view)))
    (multiple-value-bind (world-x world-y)
        (scale-point graphic-world-transform x-distance y-distance)
      (values (floor (* world-x scale-x))
              (floor (* world-y scale-y)))))))
  
           
;Method: transform-point
;  Convert the given X and Y object coordinates to view coordinates for the
;  given VIEW.  If GRAPHIC-WORLD-TRANSFORM is given, apply it to the point before
;  converting to view coordinates.
(defmethod transform-point ((view view) x y )
  (declare (values new-x new-y))

  (with-slots (origin-x origin-y scale-x scale-y height) view

      (values (floor (* (- x origin-x) scale-x))
              (FLOOR (- height  (* (- y origin-y) scale-y))))))

(defmethod transform-x ((view view) x  )
  (declare (values new-x new-y))
  (with-slots (origin-x origin-y scale-x height) view
     (floor (* (- x origin-x) scale-x))))

(defmethod transform-y ((view view)  y )
  (declare (values  new-y))
  (with-slots (origin-x origin-y scale-y height) view
    (floor (- height (* (- y origin-y) scale-y)))))

(DEFMETHOD view-transform-vector ((view view) vertices &optional round)
  "this function destructively changes the value of vertices by applying the view transform to them"
  (with-slots (origin-x origin-y scale-x scale-y height) view
    (IF round
	(DO ((i 0 (+ i 2)))
	    ((>= i (LENGTH vertices)))
	  (SETF (elt vertices i) (round (* (- (ELT vertices i) origin-x) scale-x)))
	  (SETF (ELT vertices (1+ i))       (- height (round (* (- (ELT vertices (1+ i)) origin-y) scale-y)))))
	
	(DO ((i 0 (+ i 2)))
	    ((>= i (LENGTH vertices)))
	  (SETF (elt vertices i) (floor (* (- (ELT vertices i) origin-x) scale-x)))
	  (SETF (ELT vertices (1+ i)) (FLOOR (- height  (* (- (ELT vertices (1+ i)) origin-y) scale-y))))))
    (VALUES vertices)))


(defmethod view-untransform-point ((view view) window-x  window-y)
  (DECLARE (VALUES world-x world-y))
  (VALUES 
    (+ (origin-x view) (/ window-x (view-scale-x view)))		;change to world coordinates
    (- (+ (origin-y view) (/ (contact-height view) (view-scale-y view)))
       (/ window-y (view-scale-y view))))  ;change from 4th quadrant view
  )                                                                    ;coordinates to 1st quadrant world coordinate

(defmethod untransform-point ((view view) window-x  window-y)
  (DECLARE (VALUES world-x world-y))
  (VALUES 
    (+ (origin-x view) (/ window-x (view-scale-x view)))		;change to world coordinates
    (- (+ (origin-y view) (/ (contact-height view) (view-scale-y view)))
       (/ window-y (view-scale-y view))))  ;change from 4th quadrant view
  )                                                                    ;coordinates to 1st quadrant world coordinate


(defmethod view-untransform-x ((view view) window-x )
  (DECLARE (VALUES world-x ))						;change to X world coordinates
    (+ (origin-x view) (/ window-x (view-scale-x view)))			;change from 4th quadrant view coordinates
    )									;to 1st quadrant world coordinate


(defmethod view-untransform-y ((view view) window-y )
  (DECLARE (VALUES world-y ))
    (- (+ (origin-y view) (/ (contact-height view) (view-scale-y view)))	;change to Y world coordinates
       (/ window-y (view-scale-y view))))					;change from 4th quadrant view coordinates




;Method: view-zoom
;  Change the scale of the VIEW. The horizontal and vertical scale are changed
;  uniformly. If ABSOLUTE-P is true, then SCALE is an absolute scale factor;
;  otherwise, SCALE is multiplied with the current scale to form the new scale.
;  FIXED-POINT is a point in the view that will remain fixed after the scale is
;  performed.  Any of the nine possible alignment points may be specified and
;  the default is :southwest.

(defmethod view-zoom ((view view) scale &key  (absolute-p nil) (fixed-point :southwest))
  (declare (type (AND number (satisfies plusp)) scale))
  (declare (type boolean absolute-p))
  (declare (type (OR list (member :northwest :north  :northeast
                         :west      :center :east
                         :southwest :south  :southeast))
                 fixed-point))
  (LET (fixed-point-x fixed-point-y)
    (IF (LISTP fixed-point)
	(PROGN
	  (SETF fixed-point-x (FIRST fixed-point))
	  (SETF fixed-point-y (SECOND fixed-point)))
	
	(MULTIPLE-VALUE-SETQ (fixed-point-x fixed-point-y)	; Remember the fixed point
	  (gravity-point view fixed-point)))
      (if absolute-p
          (setf (view-scale view)  scale)		;   Absolutely
          (setf (view-scale view ) (* (view-scale view) scale)))	;   Relatively
;    (unless (eq fixed-point :southwest)			; Pan back to the fixed point
      (view-pan view fixed-point-x fixed-point-y	;   If we need to
                fixed-point)))


;Method: world-extent
;  Return the extent of the given VIEW in world coordinates.  A nil value means that
;  the extent is undefined.  If RESULT-EXTENT is provided, it is used to store the result
;  extent.  Otherwise, a new extent-rect is created and returned.

(defmethod world-extent ((view view) &optional result-extent)
  (declare (type (or null extent-rect) result-extent))
  (declare (values (or null extent-rect)))

  (with-slots (origin-x origin-y  width height) view
    (unless (or (zerop width) (zerop height))
      (let ((new-extent (or result-extent (make-extent-rect)))
	    (scale (view-scale view)))
        (setf (extent-rect-xmin new-extent) origin-x
              (extent-rect-ymin new-extent) origin-y
              (extent-rect-xmax new-extent) (+ origin-x (float (/ width scale)))
              (extent-rect-ymax new-extent) (+ origin-y (float (/ height scale))))
        new-extent))))

 


		 
;Private Function: rect-union
;  Return the area of the union of RECT1 and RECT2.

(defun rect-union (rect1 rect2)
  (declare (type extent-rect rect1 rect2))

  (* (- (max (extent-rect-xmax rect1)
             (extent-rect-xmax rect2))
        (min (extent-rect-xmin rect1)
             (extent-rect-xmin rect2)))
     (- (max (extent-rect-ymax rect1)
             (extent-rect-ymax rect2))
        (min (extent-rect-ymin rect1)
             (extent-rect-ymin rect2)))))

;Private Function: rect-intersect
;  Return the area of the intersection of RECT1 and RECT2.

(defun rect-intersect (rect1 rect2)
  (declare (type extent-rect rect1 rect2))

  (let ((x-length (- (min (extent-rect-xmax rect1)
                          (extent-rect-xmax rect2))
                     (max (extent-rect-xmin rect1)
                          (extent-rect-xmin rect2))))
        (y-length (- (min (extent-rect-ymax rect1)
                          (extent-rect-ymax rect2))
                     (max (extent-rect-ymin rect1)
                          (extent-rect-ymin rect2)))))
    (if (and (plusp x-length)
             (plusp y-length))
        (* x-length y-length)
        0)))

  
;Private Function: rect-merge
;  Merge (union) RECT1 and RECT2 and modify RECT2 to contain the result.

(defun rect-merge (rect1 rect2)
  (declare (type extent-rect rect1 rect2))

  (setf (extent-rect-xmax rect2)
        (max (extent-rect-xmax rect1)
             (extent-rect-xmax rect2))
        
        (extent-rect-xmin rect2)
        (min (extent-rect-xmin rect1)
             (extent-rect-xmin rect2))

        (extent-rect-ymax rect2)
        (max (extent-rect-ymax rect1)
             (extent-rect-ymax rect2))

        (extent-rect-ymin rect2)
        (min (extent-rect-ymin rect1)
             (extent-rect-ymin rect2)))
  rect2)
