;;; -*- 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
;;;     ----     ---    ----
;;;   21-May-93 amickish Restored old definition of Black-XOR-Hack (known
;;;                      previously as hack-for-black-xor-on-color-screen)
;;;                      and renamed to HP-XOR-Hack
;;;   17-Apr-93 amickish Moved aggrelist macros here from virtual-aggs
;;;   12-Apr-93 koz     Moved set-*-style fns to new-defs.lisp, since they
;;;                     use macros defined there.
;;;    6-Apr-93 koz     Changed with-*-styles macros to set-*-style FUNCTIONS.
;;;                     Also REMOVED clip-mask handling from set-*-style!
;;;                     Also changed black-xor-hack from fn to macro.
;;;                     And nixed unused macros "old", "old-value", "old-valid"
;;;    5-Apr-93 koz     Fixed "dothings" to handle case when one of the
;;;                     'things' is NIL (old version aborted at that point).
;;;   27-Mar-93 koz     Added "dothings" macro (to avoid using "flet"
;;;			in "update-window" because of Allegro space leak)
;;;   13-Jan-93 amickish  Removed Fix-Properties (obsolete)
;;;    5-Jan-93 amickish  Rewrote hack-for-black-xor-on-color-screen
;;;   31-Dec-92 koz     Fixed :clip-mask branch of set-gc
;;;   20-Nov-92 amickish  Bound THE-SCHEMA in each macro so that SCHEMA is not
;;;                     evaluated twice
;;;    6-Oct-92 koz     Added fix-update-slots
;;;    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)
  `(let ((the-schema ,schema))
    (kr-send the-schema :add-component the-schema ,@args)))

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

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

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

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

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

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

(defmacro fix-update-slots (schema &rest args)
  `(let ((the-schema ,schema))
    (kr-send the-schema :fix-update-slots the-schema ,@args)))

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

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

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

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

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

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

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

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

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

(defmacro dothings ((varname &rest things) &body body)
 "Same as 'dolist', except 'things' are not a list.  Does not cons."
 (let ((count (length things))
       (tagname   (gensym "TOP-TAG"))
       (countname (gensym "COUNT"))
       case-entries)
  (dolist (thing things)
    (push (list (decf count) thing) case-entries))
  (setq case-entries (nreverse case-entries))
  `(let ((,countname ,(length things))
         ,varname)
    (tagbody
      ,tagname
      (unless (zerop ,countname)
	(setq ,varname (case (decf ,countname) ,@case-entries))
        ,@body
        (go ,tagname))))))


;;;;;;;;;;;;;;;;;;;;;;;;;; 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))
	     do-copy?)
       (setf (opal-gc-clip-mask ,opal-gcontext) v)
       (if (eq v :none)
	   (unless (eq (first s) :none)
	     (setf (xlib:gcontext-clip-mask ,xlib-gcontext) :none)
	     (setf (first s) :none))
	   (progn
	     (unless (nthcdr 4 v)
	       ;; special cases if v has only one clip-mask
	       (unless (eq (first s) :short)
		 (setq do-copy? T)
		 (setf (first s) :short))
	       (setq s (nthcdr 4 s)))
	     (when (or do-copy? (not (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 HP has a non-traditional assignment of black=0 and white=1, but to
;;; get XOR to work correctly, we have to draw black objects as 1 and white
;;; objects as 0.  This macro checks whether the display is an HP, and then
;;; flips the black and white indices for XOR.
;;;
(defmacro HP-XOR-hack (x-draw-function index)
 `(if *HP-display-type?*
      (if (eq ,x-draw-function ,boole-xor)
	  (if (eql ,*black* ,index)
	      ,*white*
	      (if (eql ,*white* ,index)
		  ,*black*
		  ,index))
	  ,index)
      ,index))
#|
;;; Unfortunately, you cannot assume that the display is on an HP just
;;; because lisp is running on an HP.  Therefore, the #+pa switches are
;;; insufficient.
(defmacro HP-XOR-hack (x-draw-function index)
  #-pa (declare (ignore x-draw-function))
  #-pa index
  #+pa
 `(let ((.index. ,index))
    (if (eq ,x-draw-function ,boole-xor)
	(case .index.
	    (,*black* ,*white*)
	    (,*white* ,*black*)
	    (t .index.))
        .index.)))
|#
	   
(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))

;;;;;;;;;;;;;;;;;;;;;;; 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))


;;;;;;;;;;;;;;;;;;;;;;; For aggregadgets, aggrelists, etc. ;;;;;;;;;;;;;;;;;;

(defmacro add-item (schema &rest args)
 `(let ((the-schema ,schema))
   (kr-send the-schema :add-item the-schema ,@args)))

(defmacro change-item (schema &rest args)
  "
Change-Item puts the specified item in the :items list, replacing the
item that was previously in the specified position.
    agg  - the aggrelist or gadget to be changed
    item - the new item to put in the :items list
    n    - the position of the old item to be replaced"
  `(let ((the-schema ,schema))
    (kr-send the-schema :change-item the-schema ,@args)))

(defmacro remove-item (schema &rest args)
 `(let ((the-schema ,schema))
   (kr-send the-schema :remove-item the-schema ,@args)))

