;;;-*- 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-image-content
	  make-graphic-image
	  graphic-image-base-x
	  graphic-image-base-y
	  graphic-image-gravity
	  graphic-image-tile-p
	  )
	'pictures)


(DEFMACRO compute-base-origin-if-not-set (base-x base-y)
  `(UNLESS (AND ,base-x ,base-y)
     (MULTIPLE-VALUE-BIND (x y) (compute-base-origin graphic-image view)
       (SETF ,base-x x)
       (SETF ,base-y y))))


(defclass graphic-image (extent-cache graphic)
  (
   (image-content     :type (OR null :bitmap :xy-pixmap :z-pixmap)
		      :initarg :image-content
		      :initform nil
		      :accessor graphic-image-content
		      :documentation "the numeric values for the graphic-image")
   
   (graphic-image-base-x  :type	(OR wcoord null)
			  :initarg	:base-x
			  :initform nil
			  :accessor graphic-image-base-x
			  :documentation "object x-coordinate of base point for the image")

   (graphic-image-base-y  :type	(OR wcoord null)
			  :initarg	:base-y
			  :initform nil
			  :accessor graphic-image-base-y
			  :documentation "object y-coordinate of base point for the image")

   (graphic-image-extent-x  :type	(OR wcoord null)
			    :initarg   :extent-x
			    :initform nil
			    :accessor graphic-image-extent-x
			    :documentation "object x-coordinate of the user defined extent for the image")

   (graphic-image-extent-y  :type	(OR wcoord null)
			    :initarg   :extent-y
			    :initform nil
			    :accessor graphic-image-extent-y
			    :documentation "object y-coordinate of the user defined extent for the image")

   (graphic-image-extent-width  :type	(OR wcoord null)
			    :initarg   :extent-width
			    :initform nil
			    :accessor graphic-image-extent-width
			    :documentation "object width  of the user defined extent for the image")

   (graphic-image-extent-height  :type	(OR wcoord null)
			    :initarg   :extent-height
			    :initform nil
			    :accessor graphic-image-extent-height
			    :documentation "object height  of the user defined extent for the image")

   (graphic-image-gravity  :type  symbol
			   :accessor graphic-image-gravity
			   :initarg :gravity
			   :initform :southwest
			   :documentation "the gravity of the graphic-image within a frame")

   (graphic-image-tile-p   :type boolean
			   :accessor graphic-image-tile-p
			   :initarg :tile-p
			   :initform nil
			   :documentation "a flag to signal if the graphic image is to tile when drawn")
 
   (graphic-image-scale    :type number
			   :accessor graphic-image-scale
			   :initform 1
			   :documentation "the scale factor at which the image was formed")
   )
  (:documentation "The graphic class for drawing a graphic-image in object coordinates"))


(DEFUN make-graphic-image (image &key  tile-p base-x base-y extent-x extent-y extent-width extent-height
				      (gravity :southwest) gstate transform parent (sensitivity :editable) plist)

  
  (FUNCALL #'MAKE-INSTANCE 'graphic-image
	   :allow-other-keys t
	   :base-x base-x
	   :base-y base-y
	   :image-content image
	   :extent-x extent-x
	   :extent-y extent-y
	   :extent-width extent-width
	   :extent-height extent-height
	   :gravity gravity
	   :gstate gstate
	   :parent parent
	   :transform transform
	   :sensitivity sensitivity
	   :tile-p tile-p
	   :plist plist
	   ))

(DEFMETHOD initialize-instance :after ((graphic-image graphic-image) &key extent-x extent-y )
  (DECLARE (IGNORE options))
  (with-slots (gstate graphic-image-base-x graphic-image-base-y views extent extent-valid-p) graphic-image
    (SETF (gstate-fill-style graphic-image) :tiled)
    (UNLESS (OR (AND graphic-image-base-x graphic-image-base-y) (AND extent-x extent-y))
      (SETF graphic-image-base-x 0)
      (SETF graphic-image-base-y 0))
    
    ))


(DEFMETHOD (SETF graphic-image-base-x) :before  (x (graphic-image graphic-image) )
  (with-slots (extent graphic-image-extent-x graphic-image-base-x) graphic-image
    (WHEN graphic-image-extent-x 
      
      (SETF graphic-image-extent-x (+ graphic-image-extent-x (- x graphic-image-base-x))))
    )
  (extent-changed graphic-image))

(DEFMETHOD (SETF graphic-image-base-y) :before ( y (graphic-image graphic-image))
  (with-slots (extent graphic-image-extent-y graphic-image-base-y) graphic-image
    (WHEN graphic-image-extent-y 
      
      (SETF graphic-image-extent-y (+ graphic-image-extent-y (- y graphic-image-base-y))))
    )
  (extent-changed graphic-image))

(DEFMETHOD (SETF graphic-image-extent-x) :before (x (graphic-image graphic-image))
  (DECLARE (IGNORE x))
  (extent-changed graphic-image)
  (with-slots (transform graphic-image-base-x) graphic-image
    (SETF transform nil)
    (SETF graphic-image-base-x nil)))

(DEFMETHOD (SETF graphic-image-extent-y) :before (y (graphic-image graphic-image))
  (DECLARE (IGNORE y))
  (extent-changed graphic-image)
  (with-slots (transform graphic-image-base-y) graphic-image
    (SETF transform nil)
    (SETF graphic-image-base-y nil)))



(DEFMETHOD (SETF graphic-image-gravity) :after (gravity (graphic-image graphic-image))
  (DECLARE (IGNORE gravity))
  (with-slots ( graphic-image-base-x graphic-image-base-y ) graphic-image
      (SETF graphic-image-base-x nil)
      (SETF graphic-image-base-y nil)))



(DEFMETHOD extent-compute ((graphic-image graphic-image))
  (DECLARE (VALUES (OR null extent-rect)))
  
  (LET (
	(scale-x (view-scale-x (graphic-view graphic-image)))
	(scale-y (view-scale-y (graphic-view graphic-image))))
  (with-slots (extent graphic-image-base-x graphic-image-base-y graphic-image-extent-x graphic-image-extent-y
		      graphic-image-extent-width graphic-image-extent-height image-content transform) graphic-image
    
    (IF (AND graphic-image-extent-x graphic-image-extent-y graphic-image-extent-width graphic-image-extent-height)
	(MULTIPLE-VALUE-BIND (x-min y-min) (transform-point transform graphic-image-extent-x graphic-image-extent-y)
	  (MULTIPLE-VALUE-BIND (x-max y-max) (transform-point transform
							      (+ x-min graphic-image-extent-width)
							      (+ y-min graphic-image-extent-height))
	    (make-extent-rect
	      :xmin x-min
	      :ymin y-min
	      :xmax x-max
	      :ymax y-max)))
	(MULTIPLE-VALUE-BIND (x-min y-min) (transform-point transform graphic-image-base-x graphic-image-base-y)
	  
	    (make-extent-rect
	      :xmin x-min
	      :ymin y-min
	      :xmax (+ x-min (/ (image-width image-content) scale-x))

	      :ymax (+ y-min (/ (image-height image-content) scale-y)))))
    )))


(DEFMACRO get-tile-x (x)
  ` (transform-x view ,x))

(DEFMACRO get-tile-y (y)
  `(transform-y view ,y))

(DEFMETHOD draw-graphic ((graphic-image graphic-image) (view view)
                           &optional min-x min-y width height) 
  (DECLARE (type (OR null wcoord) min-x min-y width height))
  (with-slots (gstate extent  graphic-image-scale gstate transform graphic-image-base-x graphic-image-base-y
			    image-content (tile-p graphic-image-tile-p) extent) graphic-image
    (WHEN (visible-p graphic-image)
	  (compute-base-origin-if-not-set graphic-image-base-x graphic-image-base-y)
	  (LET ((world-extent (extent-transform (graphic-world-transform graphic-image) extent))
		(scale-x (view-scale-x view))
		(scale-y (view-scale-y view)))
	    (WHEN (NOT (= (view-scale view) graphic-image-scale))
	      (SETF graphic-image-scale (view-scale view)) 
	      (extent-changed graphic-image)
	      (graphic-extent graphic-image))
	    (IF tile-p
		(PROGN
		  (MULTIPLE-VALUE-BIND (tx ty) (compute-base-origin graphic-image view)
		    (MULTIPLE-VALUE-SETQ (tx ty) (transform-point (graphic-world-transform graphic-image) tx ty))
		    (SETF (gstate-value gstate :ts-x) (get-tile-x tx))
		    (SETF (gstate-value gstate :ts-y) (get-tile-y ty)))
		  (view-draw-image view
				   (extent-rect-xmin world-extent) (extent-rect-ymin world-extent)
				   (extent-rect-xmax world-extent) (extent-rect-ymax world-extent) 
				   image-content  gstate))
		
		(MULTIPLE-VALUE-BIND (x y) (transform-point (graphic-world-transform  graphic-image)
							    graphic-image-base-x
							    graphic-image-base-y)
		  (MULTIPLE-VALUE-BIND (x-max y-max) (transform-point (graphic-world-transform graphic-image)
								      (+ graphic-image-base-x
									 (/ (image-width image-content) scale-x))
								      (+ graphic-image-base-y
									 (/ (image-height image-content) scale-y)))
		    (SETF (gstate-value gstate :ts-x) (get-tile-x x))
		    (SETF (gstate-value gstate :ts-y) (get-tile-y y))
		    (view-draw-image view
				     x  y
				     x-max  y-max
				     image-content  gstate))))))))


(DEFMETHOD normalize-graphic :before ((graphic-image graphic-image))
  (with-slots (extent graphic-image-base-x graphic-image-base-y graphic-image-extent-x graphic-image-extent-y
		      graphic-image-extent-width graphic-image-extent-height image-content transform) graphic-image
    
    (IF (AND graphic-image-extent-x graphic-image-extent-y graphic-image-extent-width graphic-image-extent-height)
	(MULTIPLE-VALUE-BIND (x-min y-min) (transform-point transform graphic-image-extent-x graphic-image-extent-y)
	  (MULTIPLE-VALUE-BIND (x-max y-max) (transform-point transform
							      (+ x-min graphic-image-extent-width)
							      (+ y-min graphic-image-extent-height))
	    (SETF graphic-image-extent-x x-min
		  graphic-image-extent-y y-min
		  graphic-image-extent-width (ABS (- x-max x-min))
		  graphic-image-extent-height (ABS (- y-max y-min)))))
	(MULTIPLE-VALUE-BIND (x y) (transform-point transform graphic-image-base-x graphic-image-base-y)
	  (SETF (graphic-image-base-x graphic-image) x
		(graphic-image-base-y graphic-image) y)))
    ))


(DEFUN compute-base-origin (graphic-image view)
  "Return the  baseline coordinate of the graphic-image"
  (DECLARE (VALUES (type ocoord x y)))
  (with-slots (graphic-image-gravity transform image-content extent graphic) graphic-image
    (LET ((world-extent (IF (valid-extent-p extent) extent (graphic-extent graphic-image))))
      (with-extent-values world-extent extent-xmin extent-ymin extent-xmax extent-ymax extent-width extent-height
			  (LET*  (
				  (scale-x (view-scale-x view))
				  (scale-y (view-scale-y view))
				  (width (/ (image-width image-content) scale-x))
				  (height (/ (image-height image-content) scale-y)))

			    (CASE graphic-image-gravity
			      
			      (:southwest  (VALUES  extent-xmin
						    extent-ymin  ))
			      (:northwest  (VALUES  extent-xmin
						    (- extent-ymax  height)))
			      (:south      (VALUES  (+ (- extent-xmin (/ width 2.0))
						      (/ extent-width 2.0) ) extent-ymin))
			      (:north      (VALUES  (+ (- extent-xmin (/ width 2.0))(/ extent-width 2.0) )
						    (- extent-ymax  height)))
			      (:west       (VALUES  extent-xmin
						    (+ extent-ymin (- (/ extent-height 2.0) (/ height 2.0)))))
			      (:center     (VALUES  (+ (- extent-xmin (/ width 2.0)) (/ extent-width 2.0) )
						    (+  extent-ymin (- (/ extent-height 2.0 ) (/ height 2.0)))))
			      (:southeast  (VALUES  (- extent-xmax  width)
						    extent-ymin))
			      (:northeast  (VALUES  (- extent-xmax  width)
						    (- extent-ymax  height)))
			      (:east       (VALUES  (- extent-xmax  width)
						    (+ (- extent-ymin (/ height 2.0)) (/ extent-height 2.0 ))))
			      (t           (VALUES   extent-xmin
						     extent-ymin))))))))









