;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Opal:Macros.Lisp
;;;
;;; This file contains all the defmacros which are used by Opal.
;;;
;;; Change Log:
;;;     date     who    what
;;;     ----     ---    ----
;;;    5-Oct-92 koz/amickish  Added get-old-thickness
;;;   27-May-92  dzg    In with-line-style and with-filling-style, exit
;;;			immediately if draw-function is boole-2 = :no-op.
;;;   19-Feb-92  ecp    Implemented double-clip-masks as list of length 8
;;;   24-Jan-92  ecp    Changed with-filling-style and with-line-style
;;;			to draw xor objects correctly when *black* = 0.
;;;    9-Dec-91  ecp    Rewrote :clip-mask branch of set-gc to only
;;;                     copy clip-mask if it has changed.
;;;   25-Nov-91  koz    changed get-bbox-vals to set-frr-bbox
;;;   25-Nov-91  koz    eliminated fix-properties-and-validate (yeah!)
;;;    6-Nov-91  ecp    Made move-component a method.
;;;    4-Oct-91  amick  Added set-styles and get-bbox-vals macros
;;;    1-Mar-91  ecp    If a white xor-ed object is drawn on a color
;;;			screen for which *black* is 0, then it must
;;;			be drawn black instead.
;;;   13-Mar-91  ecp    Same as 3-Aug-90 change, but also don't do a total
;;;                     update if only :cursor is changed.
;;;    7-Mar-91  ecp    If a black xor-ed object is drawn on a color
;;;			screen for which *black* is 0, then it must
;;;			be drawn white instead.
;;;    3-Aug-90  ecp    In fix-properties-and-validate, do not return t if
;;;			only :top or :left has been changed (since then we
;;;			do not want a total update).
;;;   11-Jul-90  ecp    new :destroy-me method
;;;    9-Apr-90  cook   Indented format statement in get-stipple-pixmap-schema
;;;   19-Mar-90  ecp    Changed tile to stipple
;;;   12-Mar-90  ecp    Fixed bug so gray lines are possible.
;;;   13-Feb-90  ecp	Implemented color.
;;;   13-Feb-90  dzg    Certain macros, such as gv-bottom, have been
;;;			converted to defuns for efficiency.  They are
;;;			now declared in basics.lisp.
;;;   25-Jan-90  ecp    Image-p is not in the R4 release of CLX.
;;;   14-Jun-89  koz    Created.  Simply extracted all defmacros from all the
;;;			Opal files.  No modifications were made to them.

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

;;;;;;;;;;;;;;;;;;;;;;;;;; General Use ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro add-component (schema &rest args)
  `(kr-send ,schema :add-component ,schema ,@args))

(defmacro remove-component (schema &rest args)
  `(kr-send ,schema :remove-component ,schema ,@args))

(defmacro move-component (schema &rest args)
  `(kr-send ,schema :move-component ,schema ,@args))

(defmacro do-all-components (schema &rest args)
  `(kr-send ,schema :do-all-components ,schema ,@args))

(defmacro do-components (schema &rest args)
  `(kr-send ,schema :do-components ,schema ,@args))

(defmacro point-to-component (schema &rest args)
  `(kr-send ,schema :point-to-component ,schema ,@args))

(defmacro point-to-leaf (schema &rest args)
  `(kr-send ,schema :point-to-leaf ,schema ,@args))

(defmacro fix-properties (schema &rest args)
  `(kr-send ,schema :fix-properties ,schema ,@args))

(defmacro initialize (schema &rest args)
  `(kr-send ,schema :initialize ,schema ,@args))

(defmacro destroy-me (schema &rest args)
  `(kr-send ,schema :destroy-me ,schema ,@args))

(defmacro destroy (schema &rest args)
  `(kr-send ,schema :destroy ,schema ,@args))

(defmacro rotate (schema &rest args)
  `(kr-send ,schema :rotate ,schema ,@args))

(defmacro update (schema &rest args)
  `(kr-send ,schema :update ,schema ,@args))

(defmacro draw (schema &rest args)
  `(kr-send ,schema :draw ,schema ,@args))

(defmacro point-in-gob (schema &rest args)
  `(kr-send ,schema :point-in-gob ,schema ,@args))

(defmacro set-styles (schema &rest args)
  `(kr-send ,schema :set-styles ,schema ,@args))

(defmacro set-frr-bbox (schema &rest args)
  `(kr-send ,schema :set-frr-bbox ,schema ,@args))

;;;;;;;;;;;;;;;;;;;;;;;;;; For "Objects.Lisp" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; With-styles works like xlib:with-gcontext except it takes a gob and
;;; extracts all the relevant things for you. This is a win for the simple
;;; draw methods, it will be a lose for performance. See below.
;;;
;;; This is a quick hack to get around the caching of various gcontext
;;; values, it will work until we understand how CLX and the RT X11 server
;;; cache gcontexts better.

(defmacro set-gc (opal-gcontext xlib-gcontext slot value)
  (case slot
    (:foreground
     `(let ((v ,value))
        (unless (eq v (opal-gc-foreground ,opal-gcontext))
          (setf (opal-gc-foreground ,opal-gcontext)
          	(setf (xlib:gcontext-foreground ,xlib-gcontext) v)))))
    (:background
     `(let ((v ,value))
        (unless (eq v (opal-gc-background ,opal-gcontext))
          (setf (opal-gc-background ,opal-gcontext)
          	(setf (xlib:gcontext-background ,xlib-gcontext) v)))))
    (:function
     `(let ((v ,value))
        (unless (eq v (opal-gc-function ,opal-gcontext))
          (setf (opal-gc-function ,opal-gcontext)
          	(setf (xlib:gcontext-function ,xlib-gcontext) v)))))
    (:line-width
     `(let ((v ,value))
        (unless (eq v (opal-gc-line-width ,opal-gcontext))
          (setf (opal-gc-line-width ,opal-gcontext)
          	(setf (xlib:gcontext-line-width ,xlib-gcontext) v)))))
    (:line-style
     `(let ((v ,value))
        (unless (eq v (opal-gc-line-style ,opal-gcontext))
          (setf (opal-gc-line-style ,opal-gcontext)
          	(setf (xlib:gcontext-line-style ,xlib-gcontext) v)))))
    (:cap-style
     `(let ((v ,value))
        (unless (eq v (opal-gc-cap-style ,opal-gcontext))
          (setf (opal-gc-cap-style ,opal-gcontext)
          	(setf (xlib:gcontext-cap-style ,xlib-gcontext) v)))))
    (:join-style
     `(let ((v ,value))
        (unless (eq v (opal-gc-join-style ,opal-gcontext))
          (setf (opal-gc-join-style ,opal-gcontext)
          	(setf (xlib:gcontext-join-style ,xlib-gcontext) v)))))
    (:dashes
     `(let ((v ,value))
        (unless (eq v (opal-gc-dashes ,opal-gcontext))
          (setf (opal-gc-dashes ,opal-gcontext)
	     (if v					;; do not set to NIL
          	(setf (xlib:gcontext-dashes ,xlib-gcontext) v))))))
    (:font
     `(let ((v ,value))
        (unless (eq v (opal-gc-font ,opal-gcontext))
          (setf (opal-gc-font ,opal-gcontext)
	     (if v					;; do not set to NIL
          	(setf (xlib:gcontext-font ,xlib-gcontext) v))))))
    (:fill-style
     `(let ((v ,value))
        (unless (eq v (opal-gc-fill-style ,opal-gcontext))
          (setf (opal-gc-fill-style ,opal-gcontext)
          	(setf (xlib:gcontext-fill-style ,xlib-gcontext) v)))))
    (:fill-rule
     `(let ((v ,value))
        (unless (eq v (opal-gc-fill-rule ,opal-gcontext))
          (setf (opal-gc-fill-rule ,opal-gcontext)
          	(setf (xlib:gcontext-fill-rule ,xlib-gcontext) v)))))
    (:stipple
     `(let ((v ,value))
        (unless (eq v (opal-gc-stipple ,opal-gcontext))
          (setf (opal-gc-stipple ,opal-gcontext)
	     (if v					;; do not set to NIL
          	(setf (xlib:gcontext-stipple ,xlib-gcontext) v))))))
    (:clip-mask
     `(let ((v ,value)
	    (s (opal-gc-stored-clip-mask ,opal-gcontext)))
	(setf (opal-gc-clip-mask ,opal-gcontext) v)
	(if (eq v :none)
	    (when (fifth s)  ;; To minimize cons-ing,
			     ;; represent :none as (x x x x nil x x x)
	      (setf (xlib:gcontext-clip-mask ,xlib-gcontext) :none)
	      (setf (fifth s) nil))
	    (progn
	      ;; if v is short (single clip-mask), make s short also.
	      (unless (nthcdr 4 v) (setq s (nthcdr 4 s)))
	      (unless (equal v s)
	        (setf (xlib:gcontext-clip-mask ,xlib-gcontext) v)
		;; copy v into s.
		(do nil
		    ((null v))
                  (setf (car s) (car v))
		  (setq s (cdr s))
		  (setq v (cdr v))))))))
  ))

;; This is called by with-*-styles, and it replaces the old :x-tiles slot.
;; It gets the *-style's :stipple, and checks its :root-pixmap-plist slot for an
;; entry for this Root.  If so, it returns it.  Else, it creates the
;; entry and places it at the head of the plist.
;; These were split into two macros because the draw method for opal:bitmap
;; also needs to use the first macro now...
(defmacro get-stipple-schema-pixmap (stipple-schema root-window bitmap-p)
   `(let ((root-plist   (g-value ,stipple-schema :root-pixmap-plist)))
     (or (getf root-plist ,root-window)
	 (let ((image (g-value ,stipple-schema :image))
	       roots-entry)
	  (if image
	     (if (typep image 'xlib::image)
		(progn
		  (setq roots-entry (build-pixmap ,root-window image
						  (xlib:image-width image)
						  (xlib:image-height image)
						  ,bitmap-p))
	  	  (s-value ,stipple-schema :root-pixmap-plist
			   (cons ,root-window (cons roots-entry root-plist)))
	   	  roots-entry)
                (format t "WARNING -- :image entry in schema ~A is not of type xlib:image!~%"
					,stipple-schema))
	(format t "WARNING -- no :image slot in schema ~A~%" ,stipple-schema))))))

(defmacro get-x-stipple (style-schema root-window)
 `(let ((stipple-schema  (g-value ,style-schema :stipple)))
   (if stipple-schema
	(get-stipple-schema-pixmap stipple-schema ,root-window nil))))

;;; The deal here is, if you're working in a color screen, and black-pixel = 0,
;;; and the draw-function is :xor, then draw black objects white, and
;;; white objects black.
(defun hack-for-black-xor-on-color-screen (x-draw-function index)
  (if (and *is-this-a-color-screen-and-is-black-zero?*
           (eq x-draw-function boole-xor))
      (cond ((zerop index) *white*)  ;; black --> white
	    ((eq index *white*) 0)   ;; white --> black
	    (t index))
      index))

(defmacro with-line-styles ((the-line-style opal-gc xlib-gc root-window
			     x-draw-function clip-mask) &body body)
    `(let ((line-style ,the-line-style))	     ;; boole-2 = :no-op
       (when (and line-style (not (eq ,x-draw-function ,boole-2)))
         (let ((x-stipple (get-x-stipple line-style ,root-window))
	        x-dash-pattern)

	   ;; If the draw-function is :xor and *black* = 0 (for instance
	   ;; on HP machines), then we must draw black as white and white
	   ;; as black.  But we must check the draw-function first.
	                ;; Set-gc returns non-NIL if draw-function changed.
	   (when (or (and (set-gc ,opal-gc ,xlib-gc :function ,x-draw-function)
			  *is-this-a-color-screen-and-is-black-zero?*)
		     (not (eq line-style (opal-gc-opal-style ,opal-gc))))
              (set-gc ,opal-gc ,xlib-gc :foreground
                 (hack-for-black-xor-on-color-screen
                    ,x-draw-function
                    (g-value line-style :foreground-color :colormap-index)))
              (set-gc ,opal-gc ,xlib-gc :background
                 (hack-for-black-xor-on-color-screen
                    ,x-draw-function
                    (g-value line-style :background-color :colormap-index))))

	   (unless (eq line-style (opal-gc-opal-style ,opal-gc))
		(setf (opal-gc-opal-style ,opal-gc) line-style)
                (set-gc ,opal-gc ,xlib-gc :line-width
			(g-value line-style :line-thickness))
                (set-gc ,opal-gc ,xlib-gc :line-style
			(g-value line-style :line-style))
                (set-gc ,opal-gc ,xlib-gc :cap-style
			(g-value line-style :cap-style))
                (set-gc ,opal-gc ,xlib-gc :join-style
			(g-value line-style :join-style))
                (if (setq x-dash-pattern (g-value line-style :dash-pattern))
		     (set-gc ,opal-gc ,xlib-gc :dashes x-dash-pattern)))

				;; This can't be in the "unless" since the same
				;; line-style can have different x-stipples
	   (if x-stipple
		     (progn
			(set-gc ,opal-gc ,xlib-gc :fill-style :opaque-stippled)
			(set-gc ,opal-gc ,xlib-gc :stipple x-stipple))
		     (set-gc ,opal-gc ,xlib-gc :fill-style :solid))

           (set-gc ,opal-gc ,xlib-gc :clip-mask ,clip-mask))
           ,@body)))

(defmacro with-filling-styles ((the-filling-style opal-gc xlib-gc root-window
				x-draw-function clip-mask) &body body)
    `(let ((filling-style ,the-filling-style))	        ;; boole-2 = :no-op
       (when (and filling-style (not (eq ,x-draw-function ,boole-2)))
         (let ((x-stipple (get-x-stipple filling-style ,root-window)))

	                ;; Set-gc returns non-NIL if draw-function changed.
	   (when (or (and (set-gc ,opal-gc ,xlib-gc :function ,x-draw-function)
			  *is-this-a-color-screen-and-is-black-zero?*)
		     (not (eq filling-style (opal-gc-opal-style ,opal-gc))))
              (set-gc ,opal-gc ,xlib-gc :foreground
                 (hack-for-black-xor-on-color-screen
                    ,x-draw-function
                    (g-value filling-style :foreground-color :colormap-index)))
              (set-gc ,opal-gc ,xlib-gc :background
                 (hack-for-black-xor-on-color-screen
                    ,x-draw-function
                    (g-value filling-style :background-color :colormap-index))))

	   (unless (eq filling-style (opal-gc-opal-style ,opal-gc))
		(setf (opal-gc-opal-style ,opal-gc) filling-style)
                (set-gc ,opal-gc ,xlib-gc :fill-style
			(g-value filling-style :fill-style))
                (set-gc ,opal-gc ,xlib-gc :fill-rule
			(g-value filling-style :fill-rule)))
           (if x-stipple (set-gc ,opal-gc ,xlib-gc :stipple x-stipple))
           (set-gc ,opal-gc ,xlib-gc :function ,x-draw-function)
           (set-gc ,opal-gc ,xlib-gc :clip-mask ,clip-mask))
         ,@body)))

(defmacro get-thickness (gob)
  `(let* ((line-style (g-value ,gob :line-style))
	  (thickness  (and line-style (g-value line-style :line-thickness))))
     (if thickness (max thickness 1)
		   0)))

;; This version of get-thickness aref's the update-vals array for the
;; line thickness, rather than g-valuing the :line-style slot.  Thus, we get
;; the "old" line thickness.
(defmacro get-old-thickness (gob line-style-index update-vals)
  (declare (ignore gob))
  `(let* ((line-style (aref ,update-vals ,line-style-index))
          (thickness  (and line-style (g-value line-style :line-thickness))))
     (if thickness (max thickness 1) 0)))

(defmacro point-in-rectangle (x y left top right bottom)
  `(and (<= ,left ,x ,right)
       (<= ,top ,y ,bottom)))

;;;  TEXT MACROS


(defmacro the-width (text-extents)
  `(first ,text-extents))

(defmacro the-actual-ascent (text-extents)
  `(second ,text-extents))

(defmacro the-actual-descent (text-extents)
  `(third ,text-extents))

(defmacro the-left-bearing (text-extents)
  `(fourth ,text-extents))

(defmacro the-right-bearing (text-extents)
  `(fifth ,text-extents))

(defmacro the-font-ascent (text-extents)
  `(sixth ,text-extents))

(defmacro the-font-descent (text-extents)
  `(seventh ,text-extents))

;;;   IMAGE MACROS

(defmacro read-image (pathname)
  `(xlib:read-bitmap-file ,pathname))

(defmacro write-image (pathname image)
  `(xlib:write-bitmap-file ,pathname ,image))

;;;;;;;;;;;;;;;;;;;;;;;;;; For "Basics.Lisp" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; The accessors for the sides of the gob adjust both the dimensions, and
;;; position of the gob based on the given value.

(defmacro left-side (gob)
  `(g-value ,gob :left))

(defmacro right-side (gob)
  `(right ,gob))

(defmacro top-side (gob)
  `(g-value ,gob :top))

(defmacro bottom-side (gob)
  `(bottom ,gob))

;;; New code
;;;
;;; This is the code for handling the cacheing of old values in the update
;;; demons, the default update-demon, and the fix-properties macros.
;;;

(defmacro old (value-list)
  `(cdr ,value-list))

(defmacro old-value (value-list)
  `(cadr ,value-list))

(defmacro old-valid (value-list)
  `(cddr ,value-list))

;;;;;;;;;;;;;;;;;;;;;;; For "Text-Fonts.Lisp" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Font-From-File

(defmacro extract-dir (font-name)
  `(subseq ,font-name 0 (1+ (position #\/ ,font-name :from-end t))))

(defmacro extract-font-name (font-name)
  `(subseq  ,font-name
            (1+ (position #\/ ,font-name :from-end t))
            (position #\. ,font-name :from-end t)))

;;;;;;;;;;;;;;;;;;;;;;; For "Windows.Lisp" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro get-parent-win (a-window display-info)
  `(let ((win-parent (g-value ,a-window :parent)))
     (if win-parent
	 (g-value win-parent :drawable)
         (display-info-root-window ,display-info))))

;;;;;;;;;;;;;;;;;;;;;;; For "Clean-Up.Lisp" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro opal-window (window-pair)
  `(cdr ,window-pair))

(defmacro clx-window (window-pair)
  `(car ,window-pair))

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