;;; xlib-xwin.el --- Core X structures.

;; Copyright (C) 2003 by Free Software Foundation, Inc.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 18 October 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id: xlib-xwin.el,v 1.5 2004/07/14 08:38:53 youngs Exp $
;; X-URL: http://lgarc.narod.ru/xwem/index.html

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; 

;;; Code:

(eval-when-compile
  (require 'cl))

(defsubst X-Generate-simple-message (type struct)
  "Same as `X-Generate-message', but does not put value_mask."
  (X-Generate-message type struct 0))

(defsubst X-Generate-message-for-list (structs-list genfun)
  "For given list of structures STRUCTS-LIST, generate message using function GENFUNC.
Each element in STRUCTS-LIST is of STRUCT-TYPE."
  (mapconcat genfun structs-list ""))

;; Point is either a cons cell in form (x . y) or X-Point structure
(defstruct (X-Point (:predicate X-Point-ispoint-p))
  xx yy)

(defsubst X-Point-p (xpnt &optional sig)
  "Return non-nil if XPNT is point."
  (let ((ispnt (or (consp xpnt) (X-Point-ispoint-p xpnt))))
    (if (and sig (not ispnt))
	(signal 'wrong-type-argument (list sig 'X-Point-p xpnt))
      ispnt)))

;;;###autoload
(defmacro X-Point-x (xpnt)
  `(if (consp ,xpnt)
       (car ,xpnt)
     (X-Point-xx ,xpnt)))

;;;###autoload
(defmacro X-Point-y (xpnt)
  `(if (consp ,xpnt)
       (cdr ,xpnt)
     (X-Point-yy ,xpnt)))

(defsetf X-Point-x (xpnt) (val)
  `(if (consp ,xpnt)
       (setcar ,xpnt ,val)
     (setf (X-Point-xx ,xpnt) ,val)))

(defsetf X-Point-y (xpnt) (val)
  `(if (consp ,xpnt)
       (setcdr ,xpnt ,val)
     (setf (X-Point-yy ,xpnt) ,val)))

;;;###autoload
(defun X-Point-message (xpnt)
  "Return string representing x point XPNT."
  (concat (int->string2 (X-Point-x xpnt))
	  (int->string2 (X-Point-y xpnt))))

;; Segment is a pair of points
;;;###autoload
(defun X-Segment-message (xseg)
  "Return string representing x segment XSEG."
  (concat (X-Point-message (car xseg))
	  (X-Point-message (cdr xseg))))

;; Rectangle
;;;###autoload
(defstruct (X-Rect (:predicate X-Rect-isrect-p))
  x y width height)

(defsubst X-Rect-p (xrect &optional sig)
  "Return non-nil if XRECT is X-Rect structure."
  (X-Generic-p 'X-Rect 'X-Rect-isrect-p xrect sig))

;;;###autoload
(defun X-Rect-internal-intersect-p (xrect1 xrect2)
  "Return non-nil if two rectangles XRECT1 and XRECT2 have common part."
  (let ((minx (min (X-Rect-x xrect1) (X-Rect-x xrect2)))
	(maxx (max (+ (X-Rect-x xrect1) (X-Rect-width xrect1))
		   (+ (X-Rect-x xrect2) (X-Rect-width xrect2))))
	(miny (min (X-Rect-y xrect1) (X-Rect-y xrect2)))
	(maxy (max (+ (X-Rect-y xrect1) (X-Rect-height xrect1))
		   (+ (X-Rect-y xrect2) (X-Rect-height xrect2)))))
    
  (and (> (+ (X-Rect-width xrect1) (X-Rect-width xrect2))
	  (- maxx minx))
       
       (> (+ (X-Rect-height xrect1) (X-Rect-height xrect2))
	  (- maxy miny)))))

;;;###autoload
(defun X-Rect-intersect-p (&rest xrects)
  "Return non-nil if rectangles in XRECTS are intersects."
  (while (and xrects
	      (not (member t (mapcar (lambda (r)
				       (X-Rect-internal-intersect-p (car xrects) r))
				     (cdr xrects)))))
    (setq xrects (cdr xrects)))

  xrects)

;;;###autoload
(defun X-Rect-message (xrect)
  "Return string representing X-Rect XRECT."
  (concat (int->string2 (X-Rect-x xrect))
	  (int->string2 (X-Rect-y xrect))
	  (int->string2 (X-Rect-width xrect))
	  (int->string2 (X-Rect-height xrect))))

;; Geometry
;;;###autoload
(defstruct (X-Geom (:include X-Rect)
		   (:predicate X-Geom-isgeom-p))
  (border-width 0))

;;;###autoload
(defun X-Geom-p (geom &optional sig)
  "Return non-nil if GEOM is X-Geom structure.
If SIG is gived and GEOM is not X-Geom structure, SIG will be signaled."
  (X-Generic-p 'X-Geom 'X-Geom-isgeom-p geom sig))
  
;;;###autoload
(defun X-Geom-apply (fn geom1 geom2)
  "Apply function FN to each element of GEOM1 and GEOM2.
Return new geom."
  (X-Geom-p geom1 'X-Geom-apply)
  (X-Geom-p geom2 'X-Geom-apply)

  (make-X-Geom :x (funcall fn (X-Geom-x geom1) (X-Geom-x geom2))
	       :y (funcall fn (X-Geom-y geom1) (X-Geom-y geom2))
	       :width (funcall fn (X-Geom-width geom1) (X-Geom-width geom2))
	       :height (funcall fn (X-Geom-height geom1) (X-Geom-height geom2))
	       :border-width (funcall fn (X-Geom-border-width geom1) (X-Geom-border-width geom2))))

;;;###autoload
(defun X-Geom-sum (geom1 geom2)
  "Create new geometry which elements is sum of corresponded elements of GEOM1 and GEOM2."
  (X-Geom-apply '+ geom1 geom2))

;;;###autoload
(defun X-Geom-sub (geom1 geom2)
  (X-Geom-apply '- geom1 geom2))

;;; X-Geom <--> X-Rect conversation
;;;###autoload
(defun X-Geom-to-X-Rect (xgeom)
  "Convert XGEOM to X-Rect."
  (make-X-Rect :x (X-Geom-x xgeom)
	       :y (X-Geom-y xgeom)
	       :width (X-Geom-width xgeom)
	       :height (X-Geom-height xgeom)))

;;;###autoload
(defun X-Rect-to-X-Geom (xrect)
  "Convert XRECT to X-Geom."
  (make-X-Geom :x (X-Rect-x xrect)
	       :y (X-Rect-y xrect)
	       :width (X-Rect-width xrect)
	       :height (X-Rect-height xrect)))
  
;; Arc
;;;###autoload
(defstruct (X-Arc (:include X-Rect)
		  (:predicate X-Arc-isarc-p))
  angle1 angle2)

(defsubst X-Arc-p (xarc &optional sig)
  "Return non-nil xf XARC is X-Arc structure."
  (X-Generic-p 'X-Arc 'X-Arc-isarc-p xarc sig))

;;;###autoload
(defun X-Arc-message (xarc)
  "Return string representing XARC."
  (concat (int->string2 (X-Arc-x xarc))
	  (int->string2 (X-Arc-y xarc))
	  (int->string2 (X-Arc-width xarc))
	  (int->string2 (X-Arc-height xarc))
	  (int->string2 (* 64 (X-Arc-angle1 xarc)))
	  (int->string2 (* 64 (X-Arc-angle2 xarc)))))

;; Atoms operations
;;;###autoload
(defstruct (X-Atom (:predicate X-Atom-isatom-p))
  dpy id name)

(defsubst X-Atom-p (atom &optional sig)
  "Return non-nil if ATOM is atom structure.
If SIG is given and ATOM is not atom structure, SIG will be signaled."
  (X-Generic-p 'X-Atom 'X-Atom-isatom-p atom sig))

(defsubst X-Atom-insert (xdpy atom)
  "Insert ATOM in XDPY's atoms list, if not already there."
  (pushnew atom (X-Dpy-atoms xdpy)
	   :test (lambda (a1 a2)
		   (= (X-Atom-id a1) (X-Atom-id a2)))))

(defsubst X-Atom-find (xdpy aid)
  "Find atom with id AID on X display XDPY."
  (X-Dpy-p xdpy 'X-Atom-find)

  (let ((al (X-Dpy-atoms xdpy)))
    (while (and al (not (= (X-Atom-id (car al)) aid)))
      (setq al (cdr al)))

    (car al)))

(defsubst X-Atom-find-or-make (xdpy aid)
  "On XDPY find atom with id AID, if no such atom, create new one."
  (X-Dpy-p xdpy 'X-Atom-find-or-make)

  (or (X-Atom-find xdpy aid)
      (car (X-Atom-insert xdpy (make-X-Atom :dpy xdpy :id aid)))))

(defsubst X-Atom-find-by-name (xdpy aname)
  "Find atom with name ANAME on X display XDPY."
  (let ((al (X-Dpy-atoms xdpy)))
    (while (and al (not (string= (X-Atom-name (car al)) aname)))
      (setq al (cdr al)))
    (car al)))

(defsubst X-Atom-equal (a1 a2)
  "Return non-nil if two atoms A1 and A2 are equal."
  (eq (and (X-Atom-p a1) (X-Atom-id a1))
      (and (X-Atom-p a2) (X-Atom-id a2))))

;; Attributes operations
;;;###autoload
(defstruct (X-Attr (:predicate X-Attr-isattr-p))
  ;; any *-pixel is X-Color structure
  dpy id
  background-pixmap background-pixel
  border-pixmap border-pixel
  bit-gravity win-gravity
  backing-store backing-planes backing-pixel
  override-redirect
  save-under
  event-mask
  do-not-propagate-mask
  colormap				; X-Colormap
  cursor				; X-Cursor
  visualid
  mapstate
  ;; List of extractors
  (list '(((lambda (attr)
	     (if (X-Pixmap-p (X-Attr-background-pixmap attr))
		 (X-Pixmap-id (X-Attr-background-pixmap attr))
	       (X-Attr-background-pixmap attr))) . 4)
	  ((lambda (attr)
	     (if (X-Color-p (X-Attr-background-pixel attr))
		 (X-Color-id (X-Attr-background-pixel attr))
	       (X-Attr-background-pixel attr))) . 4)
	  ((lambda (attr)
	     (if (X-Pixmap-p (X-Attr-border-pixmap attr))
		 (X-Pixmap-id (X-Attr-border-pixmap attr))
	       (X-Attr-border-pixmap attr))) . 4)
	  ((lambda (attr)
	     (if (X-Color-p (X-Attr-border-pixel attr))
		 (X-Color-id (X-Attr-border-pixel attr))
	       (X-Attr-border-pixel attr))) . 4)
	  (X-Attr-bit-gravity . 1)
	  (X-Attr-win-gravity . 1)
	  (X-Attr-backing-store . 1)
	  (X-Attr-backing-planes . 4)
	  ((lambda (attr)
	     (if (X-Color-p (X-Attr-backing-pixel attr))
		 (X-Color-id (X-Attr-backing-pixel attr))
	       (X-Attr-backing-pixel attr))) . 4)
	  (X-Attr-override-redirect . 1)
	  (X-Attr-save-under . 1)
	  (X-Attr-event-mask . 4)
	  (X-Attr-do-not-propagate-mask . 4)
	  ((lambda (attr)
	     (if (X-Colormap-p (X-Attr-colormap attr))
		 (X-Colormap-id (X-Attr-colormap attr))
	       (X-Attr-colormap attr))) . 4)
	  ((lambda (attr)
	     (if (X-Cursor-p (X-Attr-cursor attr))
		 (X-Cursor-id (X-Attr-cursor attr))
	       (X-Attr-cursor attr))) . 4)
	  )))

;;;###autoload
(defun X-Attr-p (attr &optional sig)
  "Return non-nil if ATTR is attributes structure.
If SIG is given and ATTR is not attributes structure, SIG will be signaled."
  (let ((isattr (X-Attr-isattr-p attr)))
    (if (and (not isattr) sig)
	(signal 'wrong-type-argument (list sig 'X-Attr-p attr))
      isattr)))

;;;###autoload
(defun X-Attr-message (attr)
  "Return a string representing the attributes ATTR."
  (X-Generate-message 'X-Attr attr))


;;;Configure window structure
;;
;;;###autoload
(defstruct (X-Conf (:predicate X-Conf-isconf-p))
  dpy id
  x y width height
  border-width
  sibling
  stackmode
  (list '((X-Conf-x . 2)
	  (X-Conf-y . 2)
	  (X-Conf-width . 2)
	  (X-Conf-height . 2)
	  (X-Conf-border-width . 2)
	  ((lambda (conf)
	     (if (X-Win-p (X-Conf-sibling conf))
		 (X-Win-id (X-Conf-sibling conf))
	       (X-Conf-sibling conf))) . 4)
	  (X-Conf-stackmode . 1))))

(defsubst X-Conf-p (conf &optional sig)
  "Return non-nil if CONF is X-Conf structure.
If SIG is given and CONF is not X-Conf structure, SIG will be signaled."
  (X-Generic-p 'X-Conf 'X-Conf-isconf-p conf sig))

;;;###autoload
(defun X-Conf-message (conf)
  "Return a string representing the configuration CONF."
  (X-Generate-message 'X-Conf conf 2))

;;; Window allocation/testing/setting routines.
;;;###autoload
(defstruct (X-Win (:predicate X-Win-iswin-p))
  dpy id

  event-handlers			; list of X-EventHandler

  plist)				; user defined plist

;;;###autoload
(defun X-Win-invalidate (win)
  "Remove WIN from dpy list and invalidate cl struct."
  (let* ((xdpy (X-Win-dpy win))
	 (wins (X-Dpy-windows xdpy)))
    (while wins
      (when (= (X-Win-id (car wins))
	       (X-Win-id win))
	(setf (X-Dpy-windows xdpy) (delete (car wins) (X-Dpy-windows xdpy)))
	(X-invalidate-cl-struct (car wins))
	(setq wins nil)))))

;; Properties list operations
(defsubst X-Win-put-prop (win prop val)
  (setf (X-Win-plist win) (plist-put (X-Win-plist win) prop val)))

(defsubst X-Win-get-prop (win prop)
  (plist-get (X-Win-plist win) prop))

(defsubst X-Win-rem-prop (win prop)
  (setf (X-Win-plist win) (plist-remprop (X-Win-plist win) prop)))

(defsubst X-Win-equal (win1 win2)
  "Return non-nil if id's of WIN1 and WIN2 are equal."
  (equal (X-Win-id win1) (X-Win-id win2)))

(defsubst X-Win-EventHandler-add (win handler &optional priority evtypes-list)
  "To X-Win add events HANDLER.

HANDLER is function which should accept three arguments - xdpy(X-Dpy),
xwin(X-Win) and xev(X-Event).  Only events with type that in
EVTYPES-LIST are passed to HANDLER. By default all events passed.
PRIORITY is place in events handler list, i.e. when HANDLER will be
called. Higher priorities runs first."
  (setf (X-Win-event-handlers win)
	(X-EventHandler-add (X-Win-event-handlers win) handler priority evtypes-list)))

(defsubst X-Win-EventHandler-isset (win handler &optional priority evtypes-list)
  "For WIN's event handlers return X-EventHandler with HANDLER, PRIORITY and EVTYPES-LIST.
If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs.
If event handler not found - nil will be returned."
  (X-EventHandler-isset (X-Win-event-handlers win) handler priority evtypes-list))

(defsubst X-Win-EventHandler-add-new (win handler &optional priority evtypes-list)
  "To X-Win add events HANDLER, only if no such handler already installed.

HANDLER is function which should accept three arguments - xdpy(X-Dpy),
xwin(X-Win) and xev(X-Event).  Only events with type that in
EVTYPES-LIST are passed to HANDLER. By default all events passed.
PRIORITY is place in events handler list, i.e. when HANDLER will be
called. Higher priorities runs first."
  (unless (X-Win-EventHandler-isset win handler priority evtypes-list)
    (setf (X-Win-event-handlers win)
	  (X-EventHandler-add (X-Win-event-handlers win) handler priority evtypes-list))
    ))

(defsubst X-Win-EventHandler-rem (win handler &optional priority evtypes-list)
  "From WIN's events handlers remove event HANDLER with PRIORITY and EVTYPES-LIST.
If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs."
  (setf (X-Win-event-handlers win)
	(X-EventHandler-rem (X-Win-event-handlers win) handler priority evtypes-list)))

(defsubst X-Win-EventHandler-enable (win handler &optional priority evtypes-list)
  "In WIN's event handlers list mark HANDLER with PRIORITY and EVTYPES-LIST as active."
  (X-EventHandler-enable (X-Win-event-handlers win) handler priority evtypes-list))

(defsubst X-Win-EventHandler-disable (win handler &optional priority evtypes-list)
  "In WIN's event handlers list mark HANDLER with PRIORITY and EVTYPES-LIST as inactive."
  (X-EventHandler-disable (X-Win-event-handlers win) handler priority evtypes-list))

(defsubst X-Win-EventHandler-runall (win xev)
  "Run all WIN's event handlers on XEV.
Signal `X-Events-stop' to stop events processing."
  (X-EventHandler-runall (X-Win-event-handlers win) xev))

(defsubst X-Win-p (win &optional sig)
  "Return non-nil if WIN is X-Win structure.
If SIG is given and WIN is not X-Win structure, SIG will
be signaled."
  (X-Generic-p 'X-Win 'X-Win-iswin-p win sig))

;;;###autoload
(defun X-Win-find (xdpy wid)
  "Find X-Win with id WID on XDPY."
  (X-Dpy-p xdpy 'X-Win-find)

  (let ((wl (X-Dpy-windows xdpy)))
    (while (and wl (not (= (X-Win-id (car wl)) wid)))
      (setq wl (cdr wl)))
    (car wl)))

;;;###autoload
(defun X-Win-find-or-make (xdpy wid)
  "Find X-Win with id WID on display XDPY, or make new one if not found."
  (X-Dpy-p xdpy 'X-Win-find-or-make)

  (or (X-Win-find xdpy wid)
      (car (pushnew (make-X-Win :dpy xdpy :id wid) (X-Dpy-windows xdpy)))))

;;;
;;;###autoload
(defstruct (X-Pixmap (:predicate X-Pixmap-ispixmap-p))
  dpy id
  
  plist)				; User defined plist

(defsubst X-Pixmap-p (pixmap &optional sig)
  "Return non-nil if PIXMAP is X-Pixmap structure.
If SIG is given and PIXMAP is not X-Pixmap structure, SIG will be signaled."
  (X-Generic-p 'X-Pixmap 'X-Pixmap-ispixmap-p pixmap sig))

;; Properties list operations
(defsubst X-Pixmap-put-prop (pixmap prop val)
  (setf (X-Pixmap-plist pixmap) (plist-put (X-Pixmap-plist pixmap) prop val)))

(defsubst X-Pixmap-get-prop (pixmap prop)
  (plist-get (X-Pixmap-plist pixmap) prop))

(defsubst X-Pixmap-rem-prop (pixmap prop)
  (setf (X-Pixmap-plist pixmap) (plist-remprop (X-Pixmap-plist pixmap) prop)))

;;;
;; DRAWABLE stuff.  A drawable is something you can draw to,
;; therefore, the only fn we need, is a drawable-p function.
;;
;; Each time we make a new drawable surface, add that to the list
;; of checks here!
;;
;;;###autoload
(defun X-Drawable-p (d &optional sig)
  "Return non-nil if D is drawable.
If SIG, then signal on error."
  (let ((isdp (or (X-Win-p d) (X-Pixmap-p d))))
    (if (and sig (not isdp))
	(signal 'wrong-type-argument (list sig 'X-Drawable-p d))
      isdp)))

;;;###autoload
(defun X-Drawable-id (d)
  "Return id of drawable D."
  (X-Drawable-p d 'X-Drawable-id)
  
  (if (X-Win-p d)
      (X-Win-id d)
    (X-Pixmap-id d)))

;;;###autoload
(defun X-Drawable-dpy (d)
  "Return dpy of drawable D."
  (X-Drawable-p d 'X-Drawable-dpy)

  (if (X-Win-p d)
      (X-Win-dpy d)
    (X-Pixmap-dpy d)))

;;; Colormaps
;;;###autoload
(defstruct (X-Colormap (:predicate X-Colormap-iscmap-p))
  dpy id
  colors)				; list of X-Color [unused]

(defsubst X-Colormap-p (cmap &optional sig)
  "Return non-nil if CMAP is X-Colormap structure.
If SIG is given and CMAP is not X-Colormap structure, SIG will be signaled."
  (X-Generic-p 'X-Colormap 'X-Colormap-iscmap-p cmap sig))

;;;###autoload
(defun X-Colormap-lookup-by-rgb (cmap col)
  "Lookup color in colormap CMAP by R G B values of X-Color COL."
  (let ((cols (X-Colormap-colors cmap)))
    (while (and cols
		(not (and (= (X-Color-red col)
                             (X-Color-red (car cols)))
                          (= (X-Color-green col)
                             (X-Color-green (car cols)))
                          (= (X-Color-blue col)
                             (X-Color-blue (car cols))))))
      (setq cols (cdr cols)))
    
    (car cols)))

;;;###autoload
(defun X-Colormap-lookup-by-name (cmap color-name)
  "Lookup in CMAP color cache color named by COLOR-NAME."
  (let ((cols (X-Colormap-colors cmap)))
    (while (and cols
                (not (and (stringp (X-Color-name (car cols)))
                          (string= (X-Color-name (car cols)) color-name))))
      (setq cols (cdr cols)))
    (car cols)))

;;;###autoload
(defun X-Colormap-lookup-by-id (cmap id)
  "Lookup color in colormap CMAP by ID."
  (let ((cols (X-Colormap-colors cmap)))
    (while (and cols (not (= id (X-Color-id (car cols)))))
      (setq cols (cdr cols)))
    (car cols)))

;;; Color structure
;;;###autoload
(defstruct (X-Color (:predicate X-Color-iscolor-p))
  dpy id
  cmap					; back reference to X-Colormap
  red green blue                        ; RGB values
  name                                  ; non-nil if allocated using `XAllocNamedColor'
  flags)

;;;###autoload
(defun X-Color-p (col &optional sig)
  (X-Generic-p 'X-Color 'X-Color-iscolor-p col sig))

;;;###autoload
(defun X-Color-message (col)
  "Convert COL into X request message."
  (X-Create-message (list [4 (X-Color-id col)]
			  [2 (X-Color-red col)] ; red
			  [2 (X-Color-green col)] ; green
			  [2 (X-Color-blue col)] ; blue
			  [1 (or (X-Color-flags col) X-DoRedGreenBlue)]
			  [1 nil])))

;;; Graphical context structure
;;
;;;###autoload
(defstruct (X-Gc (:predicate X-Gc-isgc-p))
  dpy id
  style
  function
  plane-mask
  foreground				; X-Color
  background				; X-Color
  line-width
  line-style cap-style join-style fill-style
  fill-rule tile stipple
  tile-stipple-x-origin tile-stipple-y-origin
  font					; X-Font
  subwindow-mode
  graphics-exposures
  clip-x-origin
  clip-y-origin
  clip-mask
  dash-offset dashes
  arc-mode
  (list '((X-Gc-function . 1)
	  (X-Gc-plane-mask . 4)
	  ((lambda (gc)
	     (if (X-Color-p (X-Gc-foreground gc))
		 (X-Color-id (X-Gc-foreground gc))
	       (X-Gc-foreground gc))) . 4)
	  ((lambda (gc)
	     (if (X-Color-p (X-Gc-background gc))
		 (X-Color-id (X-Gc-background gc))
	       (X-Gc-background gc))) . 4)
	  (X-Gc-line-width . 2)
	  (X-Gc-line-style . 1)
	  (X-Gc-cap-style . 1)
	  (X-Gc-join-style . 1)
	  (X-Gc-fill-style . 1)
	  (X-Gc-fill-rule . 1)
	  (X-Gc-tile . 4)
	  (X-Gc-stipple . 4)
	  (X-Gc-tile-stipple-x-origin . 2)
	  (X-Gc-tile-stipple-y-origin . 2)
	  ((lambda (gc)
	     (if (X-Font-p (X-Gc-font gc))
		 (X-Font-id (X-Gc-font gc))
	       (X-Gc-font gc))) . 4)
	  (X-Gc-subwindow-mode . 1)
	  (X-Gc-graphics-exposures . 1)
	  (X-Gc-clip-x-origin . 2)
	  (X-Gc-clip-y-origin . 2)
	  ((lambda (gc)
	     (if (X-Pixmap-p (X-Gc-clip-mask gc))
		 (X-Pixmap-id (X-Gc-clip-mask gc))
	       (X-Gc-clip-mask gc))) . 4)
	  (X-Gc-dash-offset . 2)
	  (X-Gc-dashes . 1)
	  (X-Gc-arc-mode . 1))))

;;;###autoload
(defun X-Gc-p (gc &optional sig)
  (X-Generic-p 'X-Gc 'X-Gc-isgc-p gc sig))

;;;###autoload
(defun X-Gc-message (gc)
  "Convert GC into message string."
  (X-Generate-message 'X-Gc gc))

;;; Font structure
;;;###autoload
(defstruct (X-CharInfo (:predicate X-CharInfo-ischarinfo-p))
  )

;;;###autoload
(defstruct (X-Font (:predicate X-Font-isfont-p))
  dpy id
  name
  minb maxb
  micob macob
  defchar
  nprops
  dd
  minbyte maxbyte
  allce
  fontascent fontdescent
  ncinfo props chinfo)

;;;###autoload
(defun X-Font-p (font &optional sig)
  (X-Generic-p 'X-Font 'X-Font-isfont-p font sig))

;;;###autoload
(defun X-Font-find (xdpy fid)
  "Find font with id FID on X display XDPY."
  (X-Dpy-p xdpy 'X-Font-find)

  (let ((fl (X-Dpy-fonts xdpy)))
    (while (and fl (not (= (X-Font-id (car fl)) fid)))
      (setq fl (cdr fl)))
    (car fl)))

(defcustom X-use-queryfont t "*Non-nil mean use QueryFont.")

;;;###autoload
(defun X-Font-get (xdpy fname)
  "Get font by its name FNAME on display XDPY."
  (X-Dpy-p xdpy 'X-Font-get)

  (let ((fl (X-Dpy-fonts xdpy))
	rfn)

    (while (and fl (not (string= (X-Font-name (car fl)) fname)))
      (setq fl (cdr fl)))

    (setq rfn (car fl))
    (if (X-Font-p rfn)
	rfn
      
      ;; Else query X server for font
      (setq rfn (make-X-Font :dpy xdpy :id (X-Dpy-get-id xdpy) :name fname))
      (XOpenFont xdpy rfn)
      (when X-use-queryfont
	(unless (XQueryFont xdpy rfn)
	  (setq rfn nil)))

      (when rfn
	(pushnew rfn (X-Dpy-fonts xdpy)))
      rfn)))

;; TODO: X-Font-height, X-Font-width, etc
;;;###autoload
(defun X-Font-heigth (font)
  "Return FONT height."
  (+ (X-Font-fontascent font)
     (X-Font-fontdescent font)))

;;;###autoload
(defun X-Font-char-width (chr font)
  "Return CHR width for FONT."
  (let* ((idx (- (Xforcenum chr) (X-Font-micob font)))
	 (wi (aref
	      (if (> (length (X-Font-chinfo font)) idx)
		  (aref (X-Font-chinfo font) idx)
		(X-Font-maxb font)) 2)))
    wi))

;;;###autoload
(defun X-Text-ascent (dpy font text &optional font-asc)
  "Return overall TEXT's ascent.
If FONT-ASC is non-nil, return FONT's ascent."
  (if (not X-use-queryfont)
      (let ((qtex (XQueryTextExtents dpy font text)))
	(nth (if font-asc 3 5) qtex))
    (X-Font-fontascent font)))

;;;###autoload
(defun X-Text-descent (dpy font text &optional font-desc)
  "Return overall TEXT's descent.
If FONT-DESC is non-nil, return FONT's descent."
  (if (not X-use-queryfont)
      (let ((qtex (XQueryTextExtents dpy font text)))
	(nth (if font-desc 4 6) qtex))
    (X-Font-fontdescent font)))

;;;###autoload
(defun X-Text-height (dpy font text)
  "Return TEXT height for FONT."
  (if (not X-use-queryfont)
      (let ((qtex (XQueryTextExtents dpy font text)))
	(+ (nth 3 qtex) (nth 4 qtex)))
    (X-Font-heigth font)))

;;;###autoload
(defun X-Text-width (dpy font text)
  "Return width of TEXT when it will be displayed in FONT."
;  (X-Dpy-log dpy "X-Text-width issued with font=%S\n" 'font)
  (if (not X-use-queryfont)
      (nth 7 (XQueryTextExtents dpy font text))

;    (let ((chl (string-to-list text))
;	  (defchr (X-Font-defchar font)))

      (apply '+ (mapcar (lambda (chr)
			  (X-Font-char-width chr font))
			text))))
;)

;;; Cursors structure
;;;###autoload
(defstruct (X-Cursor (:predicate X-Cursor-iscursor-p))
  dpy id
  source
  mask
  src-char msk-char
  fgred fggreen fgblue
  bgred bggreen bgblue

  (list '(((lambda (curs)
	     (if (X-Font-p (X-Cursor-source curs))
		 (X-Font-id (X-Cursor-source curs))
	       (X-Cursor-source curs))) . 4)
	  ((lambda (curs)
	     (if (X-Font-p (X-Cursor-mask curs))
		 (X-Font-id (X-Cursor-mask curs))
	       (X-Cursor-mask curs))) . 4)
	  (X-Cursor-src-char . 2)
	  (X-Cursor-msk-char . 2)
	  (X-Cursor-fgred . 2)
	  (X-Cursor-fggreen . 2)
	  (X-Cursor-fgblue . 2)
	  (X-Cursor-bgred . 2)
	  (X-Cursor-bggreen . 2)
	  (X-Cursor-bgblue . 2))))

(defsubst X-Cursor-p (cursor &optional sig)
  (X-Generic-p 'X-Cursor 'X-Cursor-iscursor-p cursor sig))

(defsubst X-Cursor-message (cursor)
  "Turn CURSOR into the text of a message."
  (X-Generate-simple-message 'X-Cursor cursor))

;; Hints
;;;###autoload
(defstruct (X-WMSize (:predicate X-WMSize-issize-p))
  flags
  x y width height
  min-width min-height
  max-width max-height
  width-inc height-inc
  min-aspect-x min-aspect-y
  max-aspect-x max-aspect-y
  base-width base-height		; added by ICCCM v1
  gravity)

;;;###autoload
(defun X-WMSize-p (wms &optional sig)
  (X-Generic-p 'X-WMSize 'X-WMSize-issize-p wms sig))

(defsubst X-WMSize-uspos-p (wms)
  "Return non-nil if WMS have user specified x, y."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 0)))))

(defsubst X-WMSize-ussize-p (wms)
  "Return non-nil if WMS have user specified width, height."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 1)))))

(defsubst X-WMSize-ppos-p (wms)
  "Return non-nil if WMS have program specified position."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 2)))))

(defsubst X-WMSize-psize-p (wms)
  "Return non-nil if WMS have program specified size."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 3)))))

(defsubst X-WMSize-pminsize-p (wms)
  "Return non-nil if WMS have program specified minimum size."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 4)))))

(defsubst X-WMSize-pmaxsize-p (wms)
  "Return non-nil if WMS have program specified maximum size."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 5)))))

(defsubst X-WMSize-presizeinc-p (wms)
  "Return non-nil if WMS have program specified resize increments."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 6)))))

(defsubst X-WMSize-paspect-p (wms)
  "Return non-nil if WMS have program specified min and max aspect ratios."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 7)))))

(defsubst X-WMSize-pbasesize-p (wms)
  "Return non-nil if WMS have program specified base for incrementing."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 8)))))

(defsubst X-WMSize-pgravity-p (wms)
  "Return non-nil if WMS have program specified window graivty."
  (not (= 0 (logand (X-WMSize-flags wms) (lsh 1 9)))))


;;;###autoload
(defstruct (X-WMHints (:predicate X-WMHints-ishints-p))
  flags
  input					;does this app rely on the window manager to get keyboard input?
  initial-state
  icon-pixmap				; X-Pixmap
  icon-window				; X-Win
  icon-x icon-y
  icon-mask				; X-Pixmap
  window-group				; X-Win id
  )

(defsubst X-WMHints-input-p (wmh)
  "Return non-nil if WMH have InputHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 0)))))

(defsubst X-WMHints-state-p (wmh)
  "Return non-nil if WMH have StateHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 1)))))

(defsubst X-WMHints-iconpixmap-p (wmh)
  "Return non-nil if WMH have IconPixmapHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 2)))))

(defsubst X-WMHints-iconwindow-p (wmh)
  "Return non-nil if WMH have IconWindowHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 3)))))

(defsubst X-WMHints-iconpos-p (wmh)
  "Return non-nil if WMH have IconPositionHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 4)))))

(defsubst X-WMHints-iconmask-p (wmh)
  "Return non-nil if WMH have IconMaskHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 5)))))

(defsubst X-WMHints-wingroup-p (wmh)
  "Return non-nil if WMH have WindowGroupHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 6)))))

(defsubst X-WMHints-urgency-p (wmh)
  "Return non-nil if WMH have UrgencyHint."
  (not (= 0 (logand (X-WMHints-flags wmh) (lsh 1 8)))))

;; Generic functions
;;;###autoload
(defun X-Generic-struct-p (gstruct)
  "Return non-nil if GSTRUCT is generic struct which have id field."
  ;; DO NOT USE THIS FUNCTION
  (and (vectorp gstruct) (intern (concat (substring (symbol-name (aref gstruct 0)) 10) "-id"))))

;;;###autoload
(defun X-Generic-p (type pfunc thing &optional sig)
  "Returns non-nil if THING is of TYPE, using predicate PFUNC.
If SIG is given, then signal if error."

  (let ((isit (funcall pfunc thing)))
    (if (and (not isit) sig)
	(signal 'wrong-type-argument (list sig type thing))
      isit)))

;;;###autoload
(defun X-Generate-message (type attr &optional bitmask-size)
  "Convert the attribute structure ATTR to a string.
The string is the message starting with VALUE_MASK, needed for
variable length requests, and the LISTofVALUE parts, depending if
those parts have been set.
Optional BITMASK-SIZE determines how much space is used by the bitmask
used in the message.  If it is excluded, then it defaults to 4."

  (funcall (intern (format "%s-p" type)) attr 'X-Generate-message)

  (when (null bitmask-size)
    (setq bitmask-size 4))

  (let* ((gc-cons-threshold most-positive-fixnum) ; inhibit gc'ing
	 (m (float 0))			; mask o parts
	 (l (cond ((= bitmask-size 4)	; the mask o given parts
		   (list [4 'm] ))
		  ((= bitmask-size 2)
		   (list [2 nil]		; reversed later
			 [2 'm] ))
		  ((= bitmask-size 0)
		   nil)
		  (t (error "Unsupported bitmask-size! Update the code."))))
	 (sal (funcall (intern (format "%s-list" type)) attr)) ; saved attr list
	 (xal sal)
	 (tempv nil))			;temp vector

    (flet ((getval (what)
		   (funcall what attr)))
      (while xal
	(when (or (= bitmask-size 0)
		  (getval (caar xal)))
	  ;; set the value part
	  (setq l (cons (progn
			  (setq tempv (make-vector 2 nil))
			  (aset tempv 0 (cdar xal)) ;size
			  (aset tempv 1 (getval (caar xal)))
			  tempv)
			l))

	  ;; put in padding if we need it.
	  ;; put it only if bitmask-size > 0
	  (when (and (> bitmask-size 0) (< (cdar xal) 4))
	    (setq l (cons (progn
			    (setq tempv (make-vector 2 nil))
			    (aset tempv 0 (- 4 (cdar xal)))
			    tempv)
			  l)))

	  (setq m (Xmask-or m (Xmask (- (length sal) (length  xal))))))
	(setq xal (cdr xal))))
      
    (when (<= bitmask-size 2)
      (setq m (truncate m)))

    (X-Create-message (reverse l) (= bitmask-size 0))))

(provide 'xlib-xwin)

;;; xlib-xwin.el ends here
