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

;; Copyright (C) 2003-2005 by XWEM Org.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 18 October 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id: xlib-xwin.el,v 1.9 2005-04-04 19:55:31 lg 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)

  (mapc (lambda (el)
          (autoload el "xlib-xlib"))
        '(X-invalidate-cl-struct XOpenFont XQueryFont XQueryTextExtents))
  )

(require 'xlib-xc)

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

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

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

(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
(defun X-Segment-message (xseg)
  "Return string representing x segment XSEG."
  (concat (X-Point-message (car xseg))
	  (X-Point-message (cdr xseg))))

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

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

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

(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
(defstruct (X-Geom (:include X-Rect)
		   (:predicate X-Geom-isgeom-p))
  (border-width 0))

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

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

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

(defun X-Geom-sub (geom1 geom2)
  (X-Geom-apply '- geom1 geom2))

(defun X-Geom-width-with-borders (geom)
  "Return GEOM width including border's width."
  (+ (X-Geom-width geom)
     (* 2 (X-Geom-border-width geom))))

(defun X-Geom-height-with-borders (geom)
  "Return GEOM height including border's width."
  (+ (X-Geom-height geom)
     (* 2 (X-Geom-border-width geom))))

;;; X-Geom <--> X-Rect conversation
(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)))

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

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

;;; Predefined Atoms
(defconst XA-AnyPropertyType (make-X-Atom :id 0.0 :name "") "Any atom.")
(defconst XA-primary (make-X-Atom :id 1.0 :name "PRIMARY") "Atom primary encoding.")
(defconst XA-secondary (make-X-Atom :id 2.0 :name "SECONDARY") "Atom secondary encoding.")
(defconst XA-arc (make-X-Atom :id 3.0 :name "ARC") "Atom arc encoding.")
(defconst XA-atom (make-X-Atom :id 4.0 :name "ATOM") "Atom atom encoding.")
(defconst XA-bitmap (make-X-Atom :id 5.0 :name "BITMAP") "Atom bitmap encoding.")
(defconst XA-cardinal (make-X-Atom :id 6.0 :name "CARDINAL") "Atom cardinal encoding.")
(defconst XA-colormap (make-X-Atom :id 7.0 :name "COLORMAP") "Atom colormap encoding.")
(defconst XA-cursor (make-X-Atom :id 8.0 :name "CURSOR") "Atom cursor encoding.")
(defconst XA-cut-buffer0 (make-X-Atom :id 9.0 :name "XA_CUT_BUFFER0") "Atom cut-buffer0 encoding.")
(defconst XA-cut-buffer1 (make-X-Atom :id 10.0 :name "CUT_BUFFER1") "Atom cut-buffer1 eoncoding.")
(defconst XA-cut-buffer2 (make-X-Atom :id 11.0 :name "CUT_BUFFER2") "Atom cut-buffer2 eoncoding.")
(defconst XA-cut-buffer3 (make-X-Atom :id 12.0 :name "CUT_BUFFER3") "Atom cut-buffer3 eoncoding.")
(defconst XA-cut-buffer4 (make-X-Atom :id 13.0 :name "CUT_BUFFER4") "Atom cut-buffer4 eoncoding.")
(defconst XA-cut-buffer5 (make-X-Atom :id 14.0 :name "CUT_BUFFER5") "Atom cut-buffer5 eoncoding.")
(defconst XA-cut-buffer6 (make-X-Atom :id 15.0 :name "CUT_BUFFER6") "Atom cut-buffer6 eoncoding.")
(defconst XA-cut-buffer7 (make-X-Atom :id 16.0 :name "CUT_BUFFER7") "Atom cut-buffer7 eoncoding.")
(defconst XA-drawable (make-X-Atom :id 17.0 :name "XA_DRAWABLE") "Atom drawable eoncoding.")
(defconst XA-font (make-X-Atom :id 18.0 :name "FONT") "Atom font eoncoding.")
(defconst XA-integer (make-X-Atom :id 19.0 :name "INTEGER") "Atom integer eoncoding.")
(defconst XA-pixmap (make-X-Atom :id 20.0 :name "PIXMAP") "Atom pixmap eoncoding.")
(defconst XA-point (make-X-Atom :id 21.0 :name "POINT") "Atom point eoncoding.")
(defconst XA-rectangle (make-X-Atom :id 22.0 :name "RECTANGLE") "Atom rectangle eoncoding.")
(defconst XA-resource-manager (make-X-Atom :id 23.0 :name "RESOURCE_MANAGER") "Atom resource-manager eoncoding.")
(defconst XA-rgb-color-map (make-X-Atom :id 24.0 :name "RGB_COLOR_MAP") "Atom rgb-color-map eoncoding.")
(defconst XA-rgb-best-map (make-X-Atom :id 25.0 :name "RGB_BEST_MAP") "Atom rgb-best-map eoncoding.")
(defconst XA-rgb-blue-map (make-X-Atom :id 26.0 :name "RGB_BLUE_MAP") "Atom rgb-blue-map eoncoding.")
(defconst XA-rgb-default-map (make-X-Atom :id 27.0 :name "RGB_DEFAULT_MAP") "Atom rgb-default-map eoncoding.")
(defconst XA-rgb-gray-map (make-X-Atom :id 28.0 :name "RGB_GRAY_MAP") "Atom rgb-gray-map eoncoding.")
(defconst XA-rgb-green-map (make-X-Atom :id 29.0 :name "RGB_GREEN_MAP") "Atom rgb-green-map eoncoding.")
(defconst XA-rgb-red-map (make-X-Atom :id 30.0 :name "RGB_RED_MAP") "Atom rgb-red-map eoncoding.")
(defconst XA-string (make-X-Atom :id 31.0 :name "STRING") "Atom string eoncoding.")
(defconst XA-visualid (make-X-Atom :id 32.0 :name "VISUALID") "Atom visualid eoncoding.")
(defconst XA-window (make-X-Atom :id 33.0 :name "WINDOW") "Atom window eoncoding.")
(defconst XA-wm-command (make-X-Atom :id 34.0 :name "WM_COMMAND") "Atom wm-command eoncoding.")
(defconst XA-wm-hints (make-X-Atom :id 35.0 :name "WM_HINTS") "Atom wm-hints eoncoding.")
(defconst XA-wm-client-machine (make-X-Atom :id 36.0 :name "WM_CLIENT_MACHINE") "Atom wm-client-machine eoncoding.")
(defconst XA-wm-icon-name (make-X-Atom :id 37.0 :name "WM_ICON_NAME") "Atom wm-icon-name eoncoding.")
(defconst XA-wm-icon-size (make-X-Atom :id 38.0 :name "WM_ICON_SIZE") "Atom wm-icon-size eoncoding.")
(defconst XA-wm-name (make-X-Atom :id 39.0 :name "WM_NAME") "Atom wm-name eoncoding.")
(defconst XA-wm-normal-hints (make-X-Atom :id 40.0 :name "WM_NORMAL_HINTS") "Atom wm-normal-hints eoncoding.")
(defconst XA-wm-size-hints (make-X-Atom :id 41.0 :name "WM_SIZE_HINTS") "Atom wm-size-hints eoncoding.")
(defconst XA-wm-zoom-hints (make-X-Atom :id 42.0 :name "WM_ZOOM_HINTS") "Atom wm-zoom-hints eoncoding.")
(defconst XA-min-space (make-X-Atom :id 43.0 :name "MIN_SPACE") "Atom min-space eoncoding.")
(defconst XA-norm-space (make-X-Atom :id 44.0 :name "NORM_SPACE") "Atom norm-space eoncoding.")
(defconst XA-max-space (make-X-Atom :id 45.0 :name "MAX_SPACE") "Atom max-space eoncoding.")
(defconst XA-end-space (make-X-Atom :id 46.0 :name "END_SPACE") "Atom end-space eoncoding.")
(defconst XA-superscript-x (make-X-Atom :id 47.0 :name "SUPERSCRIPT_X") "Atom superscript-x eoncoding.")
(defconst XA-superscript-y (make-X-Atom :id 48.0 :name "SUPERSCRIPT_Y") "Atom superscript-y eoncoding.")
(defconst XA-subscript-x (make-X-Atom :id 49.0 :name "SUBSCRIPT_X") "Atom subscript-x eoncoding.")
(defconst XA-subscript-y (make-X-Atom :id 50.0 :name "SUBSCRIPT_Y") "Atom subscript-y eoncoding.")
(defconst XA-underline-position (make-X-Atom :id 51.0 :name "UNDERLINE_POSITION") "Atom underline-position eoncoding.")
(defconst XA-underline-thickness (make-X-Atom :id 52.0 :name "UNDERLINE_THICKNESS") "Atom underline-thickness eoncoding.")
(defconst XA-strikeout-ascent (make-X-Atom :id 53.0 :name "STRIKEOUT_ASCENT") "Atom strikeout-ascent eoncoding.")
(defconst XA-strikeout-descent (make-X-Atom :id 54.0 :name "STRIKEOUT_DESCENT") "Atom strikeout-descent eoncoding.")
(defconst XA-italic-angle (make-X-Atom :id 55.0 :name "ITALIC_ANGLE") "Atom italic-angle eoncoding.")
(defconst XA-x-height (make-X-Atom :id 56.0 :name "X_HEIGHT") "Atom x-height eoncoding.")
(defconst XA-quad-width (make-X-Atom :id 57.0 :name "QUAD_WIDTH") "Atom quad-width eoncoding.")
(defconst XA-weight (make-X-Atom :id 58.0 :name "WEIGHT") "Atom weight eoncoding.")
(defconst XA-point-size (make-X-Atom :id 59.0 :name "POINT_SIZE") "Atom point-size eoncoding.")
(defconst XA-resolution (make-X-Atom :id 60.0 :name "RESOLUTION") "Atom resolution eoncoding.")
(defconst XA-copyright (make-X-Atom :id 61.0 :name "COPYRIGHT") "Atom copyright eoncoding.")
(defconst XA-notice (make-X-Atom :id 62.0 :name "NOTICE") "Atom notice eoncoding.")
(defconst XA-font-name (make-X-Atom :id 63.0 :name "FONT_NAME") "Atom font-name eoncoding.")
(defconst XA-family-name (make-X-Atom :id 64.0 :name "FAMILY_NAME") "Atom family-name eoncoding.")
(defconst XA-full-name (make-X-Atom :id 65.0 :name "FULL_NAME") "Atom full-name eoncoding.")
(defconst XA-cap-height (make-X-Atom :id 66.0 :name "CAP_HEIGHT") "Atom cap-height eoncoding.")
(defconst XA-wm-class (make-X-Atom :id 67.0 :name "WM_CLASS") "Atom wm-class eoncoding.")
(defconst XA-wm-transient-for (make-X-Atom :id 68.0 :name "WM_TRANSIENT_FOR") "Atom wm-transient-for eoncoding.")


;;; Common predicates
(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))

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

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

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


;;; Attributes operations
(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 (list
         (cons #'(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)
         (cons #'(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)
         (cons #'(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)
         (cons #'(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)
         (cons 'X-Attr-bit-gravity 1)
         (cons 'X-Attr-win-gravity 1)
         (cons 'X-Attr-backing-store 1)
         (cons 'X-Attr-backing-planes 4)
         (cons #'(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)
         (cons 'X-Attr-override-redirect 1)
         (cons 'X-Attr-save-under 1)
         (cons 'X-Attr-event-mask 4)
         (cons 'X-Attr-do-not-propagate-mask 4)
         (cons #'(lambda (attr)
                   (if (X-Colormap-p (X-Attr-colormap attr))
                       (X-Colormap-id (X-Attr-colormap attr))
                     (X-Attr-colormap attr)))
               4)
         (cons #'(lambda (attr)
                   (if (X-Cursor-p (X-Attr-cursor attr))
                       (X-Cursor-id (X-Attr-cursor attr))
                     (X-Attr-cursor attr)))
               4))))

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

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

;;;Configure window structure
;;
(defstruct (X-Conf (:predicate X-Conf-isconf-p))
  dpy id
  x y width height
  border-width
  sibling
  stackmode
  (list (list
         (cons 'X-Conf-x 2)
         (cons 'X-Conf-y 2)
         (cons 'X-Conf-width 2)
         (cons 'X-Conf-height 2)
         (cons 'X-Conf-border-width 2)
         (cons #'(lambda (conf)
                   (if (X-Win-p (X-Conf-sibling conf))
                       (X-Win-id (X-Conf-sibling conf))
                     (X-Conf-sibling conf)))
               4)
         (cons '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))

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

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

  event-handlers			; list of X-EventHandler

  plist)				; user defined plist

(defun X-Win-invalidate (xdpy win)
  "Remove WIN from dpy list and invalidate cl struct."
  (add-timeout X-default-timeout
               #'(lambda (xdpy-win)
                   (setf (X-Dpy-windows (car xdpy-win))
                         (delq (cdr xdpy-win) (X-Dpy-windows (car xdpy-win))))
                   (X-invalidate-cl-struct (cdr xdpy-win)))
               (cons xdpy win)))

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

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

(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)
      (let ((xwin (make-X-Win :dpy xdpy :id wid)))
        (X-Dpy-log xdpy 'x-event "XDPY Adding new window: %S" 'wid)
        (push xwin (X-Dpy-windows xdpy))
        xwin)))

;;;
(defstruct (X-Pixmap (:predicate X-Pixmap-ispixmap-p))
  dpy id d

  plist)				; User defined plist

(defun X-Pixmap-find-or-make (dpy id)
  (make-X-Pixmap :dpy dpy :id id))

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

(defsubst X-Pixmap-width (pixmap)
  "Return PIXMAP's width."
  (X-Pixmap-get-prop pixmap 'width))
(defsetf X-Pixmap-width (pixmap) (nw)
  `(X-Pixmap-put-prop ,pixmap 'width ,nw))

(defsubst X-Pixmap-height (pixmap)
  "Return PIXMAP's height."
  (X-Pixmap-get-prop pixmap 'height))
(defsetf X-Pixmap-height (pixmap) (nh)
  `(X-Pixmap-put-prop ,pixmap 'height ,nh))

(defsubst X-Pixmap-depth (pixmap)
  "Return PIXMAP's depth."
  (X-Pixmap-get-prop pixmap 'depth))
(defsetf X-Pixmap-depth (pixmap) (nd)
  `(X-Pixmap-put-prop ,pixmap 'depth ,nd))

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

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

(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
(defstruct (X-Colormap (:predicate X-Colormap-iscmap-p))
  dpy id
  colors)				; list of X-Color [unused]

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

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

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

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

(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
;;
(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 (list 
         (cons 'X-Gc-function 1)
         (cons 'X-Gc-plane-mask 4)
         (cons #'(lambda (gc)
                   (if (X-Color-p (X-Gc-foreground gc))
                       (X-Color-id (X-Gc-foreground gc))
                     (X-Gc-foreground gc)))
               4)
         (cons #'(lambda (gc)
                   (if (X-Color-p (X-Gc-background gc))
                       (X-Color-id (X-Gc-background gc))
                     (X-Gc-background gc)))
               4)
         (cons 'X-Gc-line-width 2)
         (cons 'X-Gc-line-style 1)
         (cons 'X-Gc-cap-style 1)
         (cons 'X-Gc-join-style 1)
         (cons 'X-Gc-fill-style 1)
         (cons 'X-Gc-fill-rule 1)
         (cons 'X-Gc-tile 4)
         (cons 'X-Gc-stipple 4)
         (cons 'X-Gc-tile-stipple-x-origin 2)
         (cons 'X-Gc-tile-stipple-y-origin 2)
         (cons #'(lambda (gc)
                   (if (X-Font-p (X-Gc-font gc))
                       (X-Font-id (X-Gc-font gc))
                     (X-Gc-font gc)))
               4)
         (cons 'X-Gc-subwindow-mode 1)
         (cons 'X-Gc-graphics-exposures 1)
         (cons 'X-Gc-clip-x-origin 2)
         (cons 'X-Gc-clip-y-origin 2)
         (cons #'(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)
         (cons 'X-Gc-dash-offset 2)
         (cons 'X-Gc-dashes 1)
         (cons 'X-Gc-arc-mode 1))))

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

(defun X-Gc-real-line-width (gc)
  "Return real GC's line width.
The thing is that 0 line width is actually 1, but uses hardware
assistance to draw such lines."
  (let ((lw (X-Gc-line-width gc)))
    (if (zerop lw) 1 lw)))

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

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

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

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

(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.")

(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
(defun X-Font-heigth (font)
  "Return FONT height."
  (+ (X-Font-fontascent font)
     (X-Font-fontdescent font)))

;; NOTE: what if chr is '\n', '\t' or such?
(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))

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

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

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

(defun X-Text-width (dpy font text)
  "Return width of TEXT when it will be displayed in FONT."
  (if (not X-use-queryfont)
      (nth 7 (XQueryTextExtents dpy font text))

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

;;; Fontable stuff
(defun X-Fontable-p (fa &optional sig)
  "Return non-nil if FA is fontable object.
If SIG, then signal on error."
  (let ((isdp (or (X-Font-p fa) (X-Gc-p fa))))
    (if (and sig (not isdp))
	(signal 'wrong-type-argument (list sig 'X-Fontable-p fa))
      isdp)))

(defun X-Fontable-id (fa)
  "Return id of fontable object FA."
  (X-Fontable-p fa 'X-Fontable-p)

  (if (X-Font-p fa)
      (X-Font-id fa)
    (X-Gc-id fa)))

(defun X-Fontable-dpy (fa)
  "Return dpy of fontable object FA."
  (X-Fontable-p fa 'X-Fontable-dpy)

  (if (X-Font-p fa)
      (X-Font-dpy fa)
    (X-Gc-dpy fa)))

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

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

(defun X-Cursor-find-or-make (dpy id)
  (make-X-Cursor :dpy dpy :id id))

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

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

(defsubst 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."
  (Xtest (X-WMSize-flags wms) 1))

(defsubst X-WMSize-ussize-p (wms)
  "Return non-nil if WMS have user specified width, height."
  (Xtest (X-WMSize-flags wms) 2))

(defsubst X-WMSize-ppos-p (wms)
  "Return non-nil if WMS have program specified position."
  (Xtest (X-WMSize-flags wms) 4))

(defsubst X-WMSize-psize-p (wms)
  "Return non-nil if WMS have program specified size."
  (Xtest (X-WMSize-flags wms) 8))

(defsubst X-WMSize-pminsize-p (wms)
  "Return non-nil if WMS have program specified minimum size."
  (Xtest (X-WMSize-flags wms) 16))

(defsubst X-WMSize-pmaxsize-p (wms)
  "Return non-nil if WMS have program specified maximum size."
  (Xtest (X-WMSize-flags wms) 32))

(defsubst X-WMSize-presizeinc-p (wms)
  "Return non-nil if WMS have program specified resize increments."
  (Xtest (X-WMSize-flags wms) 64))

(defsubst X-WMSize-paspect-p (wms)
  "Return non-nil if WMS have program specified min and max aspect ratios."
  (Xtest (X-WMSize-flags wms) 128))

(defsubst X-WMSize-pbasesize-p (wms)
  "Return non-nil if WMS have program specified base for incrementing."
  (Xtest (X-WMSize-flags wms) 256))

(defsubst X-WMSize-pgravity-p (wms)
  "Return non-nil if WMS have program specified window graivty."
  (Xtest (X-WMSize-flags wms) 512))

(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."
  (Xtest (X-WMHints-flags wmh) 1))

(defsubst X-WMHints-state-p (wmh)
  "Return non-nil if WMH have StateHint."
  (Xtest (X-WMHints-flags wmh) 2))

(defsubst X-WMHints-iconpixmap-p (wmh)
  "Return non-nil if WMH have IconPixmapHint."
  (Xtest (X-WMHints-flags wmh) 4))

(defsubst X-WMHints-iconwindow-p (wmh)
  "Return non-nil if WMH have IconWindowHint."
  (Xtest (X-WMHints-flags wmh) 8))

(defsubst X-WMHints-iconpos-p (wmh)
  "Return non-nil if WMH have IconPositionHint."
  (Xtest (X-WMHints-flags wmh) 16))

(defsubst X-WMHints-iconmask-p (wmh)
  "Return non-nil if WMH have IconMaskHint."
  (Xtest (X-WMHints-flags wmh) 32))

(defsubst X-WMHints-wingroup-p (wmh)
  "Return non-nil if WMH have WindowGroupHint."
  (Xtest (X-WMHints-flags wmh) 64))

(defsubst X-WMHints-urgency-p (wmh)
  "Return non-nil if WMH have UrgencyHint."
  (Xtest (X-WMHints-flags wmh) 256))

;; Generic functions
(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"))))

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

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

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

(defun 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 ""))


(provide 'xlib-xwin)

;;; xlib-xwin.el ends here