;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: The X Render Extension
;;;   Created: 2002-08-03
;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;;       $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $
;;; ---------------------------------------------------------------------------
;;;
;;; (c) copyright 2002, 2003 by Gilbert Baumann
;;; (c) copyright 2002 by Christian Sunesson
;;;
;;; Permission is granted to any individual or institution to use,
;;; copy, modify, and distribute this software, provided that this
;;; complete copyright and permission notice is maintained, intact, in
;;; all copies and supporting documentation.
;;;
;;; This program 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.
;;;

;;; NOTE: we need to watch maximum request sizes and somehow work
;;; around them. Sometimes e.g. in AddGlyphs this is not possible,
;;; which is a design failure.

;;; TODO

;; - some request are still to be implemented at all.

;; - we need to invent something for the color values of e.g.  fill-rectangles;
;;   I would prefer some generic functions, so that we later can map CLIM design
;;   directly to colors.

;; - we want some conviencene function to turn graphics contexts into render
;;   pictures. --GB 2002-08-21

;; - also: uniform-alpha-picture display alpha-value
;;         uniform-color-picture display red green blue
;;   --GB 2002-08-21

;; - maybe we should aim for a higher level interface to color-trapzoids and
;;   color-triangles and offer a low level [raw] interface also for high
;;   performance apps?

;; - Write tests.

;;;; API issues

;; - On one hand we want convenience functions like RENDER-TRIANGLE or
;;   WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to write a full
;;   rasterization library you obviously want high performance entry points as
;;   RENDER-TRIANGLES-1.

;; - We want to extend XLIB:COLOR into something with alpha channel.  How to
;;   name it? -- maybe XLIB:COLOR*?

;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body
;;
;;   Example:
;;   (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0)
;;     (RENDER-TRIANGLE dest color ...))

;; - Pose the filter and the transform slots of a picture.

;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT?

;; - COPY-PICTURE?

;; - WITH-PICTURE-OPTIONS ?
;;
;;   (WITH-PICTURE-OPTIONS (pic :repeat :on) ...)

;; - WITH-PICTURE ?
;;
;;   (WITH-PICTURE (picture drawable ...) ...)

(in-package :xlib)

;; Beginning to collect the external interface for documentation.
(export '(render-create-picture
          render-free-picture

          render-create-glyph-set
          render-reference-glyph-set
          render-free-glyph-set

          render-add-glyph
          render-add-glyph-from-picture
          render-free-glyph
          render-fill-rectangle

          picture-format-display
          picture-format-id
          picture-format-type
          picture-format-depth
          picture-format-red-byte
          picture-format-green-byte
          picture-format-blue-byte
          picture-format-alpha-byte
          picture-format-colormap

          ;; picture object
          picture-repeat
          picture-alpha-map
          picture-alpha-x-origin
          picture-alpha-y-origin
          picture-clip-x-origin
          picture-clip-y-origin
          picture-clip-mask
          picture-graphics-exposures
          picture-subwindow-mode
          picture-poly-edge
          picture-poly-mode
          picture-dither
          picture-component-alpha
          picture-drawable

          find-matching-picture-formats
          find-window-picture-format
          find-standard-picture-format

          render-free-picture
          render-free-glyph-set
          render-query-version
          ;; render-query-picture-formats
          render-fill-rectangle
          render-triangles
          render-triangle-fan
          render-triangle-strip
          render-set-picture-transform
          render-trapezoids
          render-composite
          render-create-glyph-set
          render-reference-glyph-set
          render-composite-glyphs
          render-add-glyph
          render-add-glyph-from-picture
          render-free-glyphs))

(pushnew :clx-ext-render *features*)

(define-extension "RENDER")

;;; X-RenderQueryVersion will always return the highest version it supports
;;; which is no higher than requested client version. For example:
;;;
;;; server version: 0.11; client version: 0.10; answer: 0.10
;;; server version: 0.11; client version: 0.12; answer: 0.11
;;; server version: 0.11; client version: 0.1; answer: 0.1
;;; server version: 0.11; client version: 1.0; answer: 0.11
(defconstant +X-client-major-version+ 0)
(defconstant +X-client-minor-version+ 10)

;;;; Request constants
(defconstant +X-RenderQueryVersion+              0) ;done
(defconstant +X-RenderQueryPictFormats+          1)
(defconstant +X-RenderQueryPictIndexValues+      2) ;0.7
(defconstant +X-RenderQueryDithers+              3)
(defconstant +X-RenderCreatePicture+             4) ;done
(defconstant +X-RenderChangePicture+             5) ;done
(defconstant +X-RenderSetPictureClipRectangles+  6) ;done
(defconstant +X-RenderFreePicture+               7) ;done
(defconstant +X-RenderComposite+                 8) ;we need better arglist
(defconstant +X-RenderScale+                     9)
(defconstant +X-RenderTrapezoids+               10) ;low-level done
(defconstant +X-RenderTriangles+                11) ;low-level done
(defconstant +X-RenderTriStrip+                 12)
(defconstant +X-RenderTriFan+                   13)
(defconstant +X-RenderColorTrapezoids+          14) ;nyi in X server, not mentioned in renderproto.h
(defconstant +X-RenderColorTriangles+           15) ;nyi in X server, not mentioned in renderproto.h
;(defconstant +X-RenderTransform+                16) ;commented out in render.h
(defconstant +X-RenderCreateGlyphSet+           17) ;done
(defconstant +X-RenderReferenceGlyphSet+        18) ;done
(defconstant +X-RenderFreeGlyphSet+             19) ;done
(defconstant +X-RenderAddGlyphs+                20) ;done, untested
(defconstant +X-RenderAddGlyphsFromPicture+     21) ;done, untested
(defconstant +X-RenderFreeGlyphs+               22) ;done, untested
(defconstant +X-RenderCompositeGlyphs8+         23) ;done
(defconstant +X-RenderCompositeGlyphs16+        24) ;done
(defconstant +X-RenderCompositeGlyphs32+        25) ;done
;;; >= 0.1
(defconstant +X-RenderFillRectangles+           26) ;single rectangle version done
;;; >= 0.5
(defconstant +X-RenderCreateCursor+             27)
;;; >= 0.6
(defconstant +X-RenderSetPictureTransform+      28) ;done (transforms picture used)
(defconstant +X-RenderQueryFilters+             29) ;some work done, needs more
(defconstant +X-RenderSetPictureFilter+         30) ;some work done, needs more
;;; >= 0.8
(defconstant +X-RenderCreateAnimCursor+         31)
;;; >= 0.9
(defconstant +X-RenderAddTraps+                 32)
;;; >= 0.10
(defconstant +X-RenderCreateSolidFill+          33)
(defconstant +X-RenderCreateLinearGradient+     34)
(defconstant +X-RenderCreateRadialGradient+     35)
(defconstant +X-RenderCreateConicalGradient+    36)

;;; Errors (not implemented yet!)
(defconstant +BadPictFormat+ 0)
(defconstant +BadPicture+    1)
(defconstant +BadPictOp+     2)
(defconstant +BadGlyphSet+   3)
(defconstant +BadGlyph+      4)

;;; Picture types (implemented with keywords)
(defconstant +PictTypeIndexed+ 0)
(defconstant +PictTypeDirect+  1)

;;; Operators (implemented with keywrods and member8-get)
(defconstant +PictOpClear+                       0)
(defconstant +PictOpSrc+                         1)
(defconstant +PictOpDst+                         2)
(defconstant +PictOpOver+                        3)
(defconstant +PictOpOverReverse+                 4)
(defconstant +PictOpIn+                          5)
(defconstant +PictOpInReverse+                   6)
(defconstant +PictOpOut+                         7)
(defconstant +PictOpOutReverse+                  8)
(defconstant +PictOpAtop+                        9)
(defconstant +PictOpAtopReverse+                10)
(defconstant +PictOpXor+                        11)
(defconstant +PictOpAdd+                        12)
(defconstant +PictOpSaturate+                   13)
;;; >= 0.2
(defconstant +PictOpDisjointClear+            #x10)
(defconstant +PictOpDisjointSrc+              #x11)
(defconstant +PictOpDisjointDst+              #x12)
(defconstant +PictOpDisjointOver+             #x13)
(defconstant +PictOpDisjointOverReverse+      #x14)
(defconstant +PictOpDisjointIn+               #x15)
(defconstant +PictOpDisjointInReverse+        #x16)
(defconstant +PictOpDisjointOut+              #x17)
(defconstant +PictOpDisjointOutReverse+       #x18)
(defconstant +PictOpDisjointAtop+             #x19)
(defconstant +PictOpDisjointAtopReverse+      #x1a)
(defconstant +PictOpDisjointXor+              #x1b)
;;
(defconstant +PictOpConjointClear+            #x20)
(defconstant +PictOpConjointSrc+              #x21)
(defconstant +PictOpConjointDst+              #x22)
(defconstant +PictOpConjointOver+             #x23)
(defconstant +PictOpConjointOverReverse+      #x24)
(defconstant +PictOpConjointIn+               #x25)
(defconstant +PictOpConjointInReverse+        #x26)
(defconstant +PictOpConjointOut+              #x27)
(defconstant +PictOpConjointOutReverse+       #x28)
(defconstant +PictOpConjointAtop+             #x29)
(defconstant +PictOpConjointAtopReverse+      #x2a)
(defconstant +PictOpConjointXor+              #x2b)
;;; >= 0.11 (not implemented yet!)
(defconstant +PictOpMultiply+                 #x30)
(defconstant +PictOpScreen+                   #x31)
(defconstant +PictOpOverlay+                  #x32)
(defconstant +PictOpDarken+                   #x33)
(defconstant +PictOpLighten+                  #x34)
(defconstant +PictOpColorDodge+               #x35)
(defconstant +PictOpColorBurn+                #x36)
(defconstant +PictOpHardLight+                #x37)
(defconstant +PictOpSoftLight+                #x38)
(defconstant +PictOpDifference+               #x39)
(defconstant +PictOpExclusion+                #x3a)
(defconstant +PictOpHSLHue+                   #x3b)
(defconstant +PictOpHSLSaturation+            #x3c)
(defconstant +PictOpHSLColor+                 #x3d)
(defconstant +PictOpHSLLuminosity+            #x3e)

;;; Filters (some work done, needs more)
(defvar +FilterNearest+            "nearest") ; 0.6
(defvar +FilterBilinear+          "bilinear") ; 0.6
(defvar +FilterConvolution+    "convolution") ; 0.10
;;; Filter quality (ditto)
(defvar +FilterFast+  "fast")
(defvar +FilterGood+  "good")
(defvar +FilterBest+  "best")

;;; Subpixel orders (>=0.6)
(defconstant +SubPixelUnknown+            0)
(defconstant +SubPixelHorizontalRGB+      1)
(defconstant +SubPixelHorizontalBGR+      2)
(defconstant +SubPixelVerticalRGB+        3)
(defconstant +SubPixelVerticalBGR+        4)
(defconstant +SubPixelNone+               5)

;;; Extended repeat attributes (>= 0.10)
(defconstant +RepeatNone+                 0)
(defconstant +RepeatNormal+               1)
(defconstant +RepeatPad+                  2)
(defconstant +RepeatReflect+              3)


;;;;

;; Sanity measures:

;; We do away with the distinction between pict-format and
;; picture-format-info. That is we cache picture-format-infos.

(defstruct picture-format
  display
  (id   0 :type (unsigned-byte 29))
  type
  depth
  red-byte
  green-byte
  blue-byte
  alpha-byte
  colormap)

(def-clx-class (glyph-set (:copier nil))
  (id 0 :type resource-id)
  (display nil :type (or null display))
  (format))

(defstruct render-info
  major-version
  minor-version
  picture-formats)

(defun display-render-info (display)
  (getf (xlib:display-plist display) 'render-info))

(defun (setf display-render-info) (new-value display)
  (setf (getf (xlib:display-plist display) 'render-info)
        new-value))

(defun ensure-render-initialized (display)
  "Ensures that the RENDER extension is initialized. Should be called
by every function, which attempts to generate RENDER requests."
  ;; xxx locking?
  (unless (display-render-info display)
    (let ((q (make-render-info)))
      (multiple-value-bind (maj min) (render-query-version display)
        (setf (render-info-major-version q) maj
              (render-info-minor-version q) min)
        (setf (render-info-picture-formats q)
              (make-hash-table :test #'eql))
        (dolist (pf (render-query-picture-formats display))
          (setf (gethash (picture-format-id pf) (render-info-picture-formats q))
                pf))
        (setf (display-render-info display) q)))))

(defun find-matching-picture-formats
    (display
     &key depth-min depth-max depth
          red-min red-max red
          green-min green-max green
          blue-min blue-max blue
          alpha-min alpha-max alpha
          type
          colormap)
  ;;
  (ensure-render-initialized display)
  (let ((res nil))
    (maphash (lambda (k f)
               (declare (ignore k))
               (when (and
                      (or (null type) (eql (picture-format-type f) type))
                      (or (null colormap)  (eql (picture-format-colormap f) colormap))
                      ;; min
                      (or (null depth-min) (>= (picture-format-depth f) depth-min))
                      (or (null red-min)   (>= (byte-size (picture-format-red-byte f)) red-min))
                      (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min))
                      (or (null blue-min)  (>= (byte-size (picture-format-blue-byte f)) blue-min))
                      (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min))
                      ;; max
                      (or (null depth-max) (<= (picture-format-depth f) depth-max))
                      (or (null red-max)   (<= (byte-size (picture-format-red-byte f)) red-max))
                      (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max))
                      (or (null blue-max)  (<= (byte-size (picture-format-blue-byte f)) blue-max))
                      (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max))
                      ;; match
                      (or (null depth)     (= (picture-format-depth f) depth))
                      (or (null red)       (= (byte-size (picture-format-red-byte f)) red))
                      (or (null green)     (= (byte-size (picture-format-green-byte f)) green))
                      (or (null blue)      (= (byte-size (picture-format-blue-byte f)) blue))
                      (or (null alpha)     (= (byte-size (picture-format-alpha-byte f)) alpha)))
                 (pushnew f res)))
             (render-info-picture-formats
              (display-render-info display)))
    res))

(defun find-standard-picture-format (display format)
  (ensure-render-initialized display)
  (maphash (ecase format
             (:argb32
              (lambda (k f)
                (declare (ignore k))
                (when (and (= (picture-format-depth f) 32)
                           (= (byte-size (picture-format-alpha-byte f)) 8)
                           (= (byte-size (picture-format-red-byte f)) 8)
                           (= (byte-size (picture-format-green-byte f)) 8)
                           (= (byte-size (picture-format-blue-byte f)) 8)
                           (= (byte-position (picture-format-alpha-byte f)) 24)
                           (= (byte-position (picture-format-red-byte f)) 16)
                           (= (byte-position (picture-format-green-byte f)) 8)
                           (= (byte-position (picture-format-blue-byte f)) 0))
                  (return-from find-standard-picture-format f))))
             (:rgb24
              (lambda (k f)
                (declare (ignore k))
                (when (and (= (picture-format-depth f) 24)
                           (= (byte-size (picture-format-red-byte f)) 8)
                           (= (byte-size (picture-format-green-byte f)) 8)
                           (= (byte-size (picture-format-blue-byte f)) 8)
                           (= (byte-position (picture-format-red-byte f)) 16)
                           (= (byte-position (picture-format-green-byte f)) 8)
                           (= (byte-position (picture-format-blue-byte f)) 0))
                  (return-from find-standard-picture-format f))))
             (:a8
              (lambda (k f)
                (declare (ignore k))
                (when (and (= (picture-format-depth f) 8)
                           (= (byte-size (picture-format-alpha-byte f)) 8))
                  (return-from find-standard-picture-format f))))
             (:a4
              (lambda (k f)
                (declare (ignore k))
                (when (and (= (picture-format-depth f) 4)
                           (= (byte-size (picture-format-alpha-byte f)) 4))
                  (return-from find-standard-picture-format f))))
             (:a1
              (lambda (k f)
                (declare (ignore k))
                (when (and (= (picture-format-depth f) 1)
                           (= (byte-size (picture-format-alpha-byte f)) 1))
                  (return-from find-standard-picture-format f)))))
           (render-info-picture-formats (display-render-info display)))
  (error "Standard format ~s not found." format))

;;; fixme?
(defun find-window-picture-format (window)
  "Find the picture format which matches the given window."
  (let* ((vi (window-visual-info window))
         (display (window-display window)))
    (ensure-render-initialized display)
    (case (visual-info-class vi)
      ((:true-color)
       (maphash (lambda (k f)
                  (declare (ignore k))
                  (when (and (eql (picture-format-type f) :direct)
                             (eql (picture-format-depth f) (drawable-depth window))
                             (eql (dpb -1 (picture-format-red-byte f) 0)
                                  (visual-info-red-mask vi))
                             (eql (dpb -1 (picture-format-green-byte f) 0)
                                  (visual-info-green-mask vi))
                             (eql (dpb -1 (picture-format-blue-byte f) 0)
                                  (visual-info-blue-mask vi))
                             (eql (byte-size (picture-format-alpha-byte f)) 0))
                    (return-from find-window-picture-format f)))
                (render-info-picture-formats
                 (display-render-info display))))
      (t
       ))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-accessor picture (32)
    ((index) index :blip)
    ((index thing) `(resource-id-put ,index (picture-id ,thing))))
  (define-accessor glyph-set (32)
    ((index) index :blip)
    ((index thing) `(resource-id-put ,index (glyph-set-id ,thing)))))

;;; picture format

(defmethod print-object ((object picture-format) stream)
  (let ((abbrev
         (with-output-to-string (bag)
           ;; build an abbreviated representation of the format
           (let ((bytes (sort (list (cons "r" (picture-format-red-byte object))
                                    (cons "g" (picture-format-green-byte object))
                                    (cons "b" (picture-format-blue-byte object))
                                    (cons "a" (picture-format-alpha-byte object)))
                              #'>
                              :key #'(lambda (x) (byte-position (cdr x))))))
             (dolist (k bytes)
               (unless (zerop (byte-size (cdr k)))
                 (format bag " ~A~D" (car k) (byte-size (cdr k)))))))))
    (print-unreadable-object (object stream :type t :identity nil)
      (format stream "~D ~S ~S ~S~A"
              (picture-format-id object)
              (picture-format-colormap object)
              (picture-format-depth object)
              (picture-format-type object) abbrev))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-accessor picture-format (32)
    ((index)       `(gethash (read-card32 ,index)
                     (render-info-picture-formats (display-render-info .display.))))
    ((index thing) `(write-card32 ,index (picture-format-id ,thing))))
  (define-accessor render-op (8)
    ((index) `(member8-get ,index
               :clear :src :dst :over :over-reverse :in :in-reverse
               :out :out-reverse :atop :atop-reverse :xor :add :saturate
               '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh
               :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
               :disjoint-over-reverse :disjoint-in :disjoint-in-reverse
               :disjoint-out :disjoint-out-reverse :disjoint-atop
               :disjoint-atop-reverse :disjoint-xor
               '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh
               '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh
               :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
               :conjoint-over-reverse :conjoint-in :conjoint-in-reverse
               :conjoint-out :conjoint-out-reverse :conjoint-atop
               :conjoint-atop-reverse :conjoint-xor))
    ((index thing) `(member8-put ,index ,thing
                     :clear :src :dst :over :over-reverse :in :in-reverse
                     :out :out-reverse :atop :atop-reverse :xor :add :saturate
                     '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh
                     :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
                     :disjoint-over-reverse :disjoint-in :disjoint-in-reverse
                     :disjoint-out :disjoint-out-reverse :disjoint-atop
                     :disjoint-atop-reverse :disjoint-xor
                     '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh
                     '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh
                     :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
                     :conjoint-over-reverse :conjoint-in :conjoint-in-reverse
                     :conjoint-out :conjoint-out-reverse :conjoint-atop
                     :conjoint-atop-reverse :conjoint-xor)))
  (deftype render-op ()
    '(member :clear :src :dst :over :over-reverse :in :in-reverse
      :out :out-reverse :atop :atop-reverse :xor :add :saturate
      :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
      :disjoint-over-reverse :disjoint-in :disjoint-in-reverse
      :disjoint-out :disjoint-out-reverse :disjoint-atop
      :disjoint-atop-reverse :disjoint-xor
      :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
      :conjoint-over-reverse :conjoint-in :conjoint-in-reverse
      :conjoint-out :conjoint-out-reverse :conjoint-atop
      :conjoint-atop-reverse :conjoint-xor)))

;; Now these pictures objects are like graphics contexts. I was about
;; to introduce a synchronous mode, realizing that the RENDER protocol
;; provides no provision to actually query a picture object's values.
;; *sigh*

(def-clx-class (picture (:copier nil))
  (id 0 :type resource-id)
  (display nil :type (or null display))
  (format)
  (%changed-p)
  (%server-values)
  (%values)
  (%drawable))

(defun picture-drawable (picture)
  (picture-%drawable picture))

;; xx make id, display, format readonly

(defun %render-change-picture-clip-rectangles (picture rectangles)
  "Dont call me, use (SETF PICTURE-CLIP-MASK) instead."
  (declare (optimize (speed 0)))
  (let ((display (picture-display picture)))
    (ensure-render-initialized display)
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderSetPictureClipRectangles+)
      (picture picture)
      (int16    (picture-clip-x-origin picture))
      (int16    (picture-clip-y-origin picture))
      ((sequence :format int16) rectangles))))

(macrolet ((foo (&rest specs)
             `(progn
               ,@(loop for (type slot default) in specs
                       for index from 0
                       collect
                       `(progn
                         (defun ,(xintern 'picture- slot) (picture)
                           (aref (picture-%values picture) ,index))
                         (defun (setf ,(xintern 'picture- slot)) (new-value picture)
                           (setf (picture-%changed-p picture) t)
                           (setf (aref (picture-%values picture) ,index) new-value))))
    
               (defun synchronise-picture-state (picture)
                 (when (picture-%changed-p picture)
                   (let ((display (picture-display picture)))
                     (ensure-render-initialized display)
                     (with-buffer-request (display (extension-opcode display "RENDER"))
                       (data +X-RenderChangePicture+)
                       (picture picture)
                       (mask
                        ,@(loop for (type slot default) in specs
                                for index from 0
                                collect
                                `(,type (and
                                         ,(cond ((eql slot 'clip-mask)
                                                 `(not (typep (aref (picture-%values picture) ,index)
                                                        'sequence)))
                                                (t
                                                 't))
                                         (not (eq (aref (picture-%values picture) ,index)
                                                  (aref (picture-%server-values picture) ,index)))
                                         (setf (aref (picture-%server-values picture) ,index)
                                          (aref (picture-%values picture) ,index))))))))
                   ,(let ((index (position 'clip-mask specs :key #'second)))
                         `(unless (eql (aref (picture-%values picture) ,index)
                                   (aref (picture-%server-values picture)
                                    ,index))
                           (%render-change-picture-clip-rectangles
                            picture (aref (picture-%values picture) ,index))
                           (setf (aref (picture-%server-values picture) ,index)
                                 (aref (picture-%values picture) ,index))))

                   (setf (picture-%changed-p picture) nil)))

               (defun render-create-picture
                   (drawable
                    &key format
                         (picture (make-picture :display (drawable-display drawable)))
                         ,@(loop for (type slot default-value) in specs
                                 collect (cond ((eql slot 'clip-mask)
                                                `(clip-mask :none))
                                               (t
                                                slot)))
                         )
                 ;; xxx also offer to give a colormap instead of a picture-format
                 ;; values!
                 (let ((display (drawable-display drawable)))
                   (ensure-render-initialized display)
                   (unless format
                     ;; xxx check for drawable being a window
                     (setf format (find-window-picture-format drawable)))
                   (let ((pid (allocate-resource-id display picture 'picture)))
                     (setf (picture-id picture) pid)
                     (with-buffer-request (display (extension-opcode display "RENDER"))
                       (data +X-RenderCreatePicture+)
                       (resource-id pid)
                       (drawable drawable)
                       (picture-format format)
                       (mask
                        ,@(loop for (type slot default) in specs
                                collect
                                (cond ((eql slot 'clip-mask)
                                       (list type `(and
                                                    (not (typep clip-mask 'sequence))
                                                    clip-mask)))
                                      (t
                                       (list type slot)))))))
                   (when (typep clip-mask 'sequence)
                     (%render-change-picture-clip-rectangles picture clip-mask))
                   (setf (picture-format picture) format)
                   (setf (picture-%server-values picture)
                         (vector ,@(loop for (type slot default) in specs
                                         collect
                                         `(or ,slot ,default))))
                   (setf (picture-%values picture) (copy-seq (picture-%server-values picture)))
                   (setf (picture-%drawable picture) drawable)
                   picture))

               (defconstant +picture-state-length+
                 ,(length specs)) )))

  (foo ((member :off :on) repeat                                          :off)
       ((or (member :none) picture) alpha-map                             :none)
       (int16 alpha-x-origin                                              0)
       (int16 alpha-y-origin                                              0)
       (int16 clip-x-origin                                               0)
       (int16 clip-y-origin                                               0)
       ;; ### Now that is not correct is it?:
       ((or (member :none) pixmap) clip-mask                              :none)
       ((member :off :on) graphics-exposures                              :on)
       ((member :clip-by-children :include-inferiors) subwindow-mode      :clip-by-children)
       ((member :sharp :smooth) poly-edge                                 :smooth)
       ((member :precise :imprecise) poly-mode                            :precise)
       ((or (member :none) #||xatom||#) dither                            :none)
       ((member :off :on) component-alpha                                 :off)))

(defun render-free-picture (picture)
  (let ((display (picture-display picture)))
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderFreePicture+)
      (picture  picture))
    (deallocate-resource-id display (picture-id picture) 'picture)))

(defun render-free-glyph-set (glyph-set)
  (let ((display (glyph-set-display glyph-set)))
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderFreeGlyphSet+)
      (glyph-set  glyph-set))
    (deallocate-resource-id display (glyph-set-id glyph-set) 'glyph-set)))

(defun render-query-version (display)
  (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
    ((data +X-RenderQueryVersion+)
     (card32 +X-client-major-version+)
     (card32 +X-client-minor-version+))
    (values
     (card32-get 8)
     (card32-get 12) )))

(defun render-query-picture-formats (display)
  (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
    ((data +X-RenderQueryPictFormats+))
    (let ((n-picture-formats (card32-get 8))
          (n-screens      (card32-get 12))
          (n-depths       (card32-get 16))
          (n-visuals      (card32-get 20))
          (n-subpixel     (card32-get 24)))
      (declare (ignore n-screens n-depths n-visuals n-subpixel))
      (loop for i below n-picture-formats
            collect
            (let ((off (+ (* 8 4)
                          (* i 28))))   ;size of picture-format-info
              (make-picture-format
               :display display
               :id         (card32-get (+ off 0))
               :type       (member8-get (+ off 4) :indexed :direct)
               :depth      (card8-get   (+ off 5))
               :red-byte   (byte (integer-length (card16-get (+ off 10)))
                                 (card16-get (+ off 8)))
               :green-byte (byte (integer-length (card16-get (+ off 14)))
                                 (card16-get (+ off 12)))
               :blue-byte  (byte (integer-length (card16-get (+ off 18)))
                                 (card16-get (+ off 16)))
               :alpha-byte (byte (integer-length (card16-get (+ off 22)))
                                 (card16-get (+ off 20)))
               :colormap   (let ((cmid (card32-get (+ off 24))))
                             (unless (zerop cmid)
                               (lookup-colormap display cmid)))))))))

(defun render-fill-rectangle (picture op color x1 y1 w h)
  (let ((display (picture-display picture)))
    (ensure-render-initialized display)
    (synchronise-picture-state picture)
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderFillRectangles+)
      (render-op op)
      (pad8 0)
      (pad16 0)
      (resource-id (picture-id picture))
      (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3))
      (int16 x1) (int16 y1) (card16 w) (card16 h))))

;; fill rectangles, colors.

(declaim (inline render-triangles-impl))
(defun render-triangles-impl (code picture op source src-x src-y format coord-sequence)
  ;; For performance reasons we do a special typecase on (simple-array
  ;; (unsigned-byte 32) (*)), so that it'll be possible to have high
  ;; performance rasters.
  (macrolet ((guts ()
               '(let ((display (picture-display picture)))
                  (synchronise-picture-state picture)
                  (synchronise-picture-state source)
                  (labels ((funk (x) (truncate (* x #x10000))))
                    (with-buffer-request (display (extension-opcode display "RENDER"))
                      (data code)
                      (render-op op)
                      (pad8 0)
                      (pad16 0)
                      (resource-id (picture-id source))
                      (resource-id (picture-id picture))
                      ((or (member :none) picture-format) format)
                      (int16 src-x)
                      (int16 src-y)
                      ((sequence :format int32 :transform #'funk) coord-sequence))))))
    (typecase coord-sequence
      ((simple-array (unsigned-byte 32) (*))
       (locally
           (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence))
         (guts)))
      (t
       (guts)))))

(defun render-triangles (picture op source src-x src-y format coord-sequence)
  (render-triangles-impl +X-RenderTriangles+ picture op source src-x src-y format coord-sequence))

(defun render-triangle-fan (picture op source src-x src-y format coord-sequence)
  (render-triangles-impl +X-RenderTriFan+ picture op source src-x src-y format coord-sequence))

(defun render-triangle-strip (picture op source src-x src-y format coord-sequence)
  (render-triangles-impl +X-RenderTriStrip+ picture op source src-x src-y format coord-sequence))

#||
(defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1))
  ...)
||#

(defun render-set-picture-transform (picture a b c d e f p q r)
  (let ((display (picture-display picture)))
    (ensure-render-initialized display)
    (synchronise-picture-state picture)
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderSetPictureTransform+)
      #|
      (card8 0) ;; render-op op)                    ;op
      (card8 0)                         ;pad
      (card16 0)                        ;pad
      |#
      (resource-id (picture-id picture))

      (card32 a)
      (card32 b)
      (card32 c)

      (card32 d)
      (card32 e)
      (card32 f)

      (card32 p)
      (card32 q)
      (card32 r))))

(defun render-query-filters (drawable)
  (let ((display (drawable-display drawable)))
    (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
      ((data +X-RenderQueryFilters+)
       (drawable drawable))
      (let* ((len (card32-get 4))
             (n-aliases (card32-get 8))
             (n-filters (card32-get 12))
             (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4)))))
        (print (list :aliases
                     (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2))))))
        (print (list :foo len n-aliases n-filters
                     (loop for i below len
                           collect (card8-get (+ off 0 (* 4 i)))
                           collect (card8-get (+ off 1 (* 4 i)))
                           collect (card8-get (+ off 2 (* 4 i)))
                           collect (card8-get (+ off 3 (* 4 i))))))
        (print
         (labels ((grab-string (j)
                    (let ((n (card8-get j)))
                      (incf j)
                      (values
                       (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j)))
                       j))))
           (loop repeat n-filters collect
                 (multiple-value-bind (s j) (grab-string off)
                   (setf off j)
                   (intern (string-upcase s) :keyword)))))
        #+NIL
        (loop for i below n-picture-formats
              collect
              (let ((off (+ (* 8 4)
                            (* i 28)))) ;size of picture-format-info
                (make-picture-format
                 :display display
                 :id         (card32-get (+ off 0))
                 :type       (member8-get (+ off 4) :indexed :direct)
                 :depth      (card8-get   (+ off 5))
                 :red-byte   (byte (integer-length (card16-get (+ off 10)))
                                   (card16-get (+ off 8)))
                 :green-byte (byte (integer-length (card16-get (+ off 14)))
                                   (card16-get (+ off 12)))
                 :blue-byte  (byte (integer-length (card16-get (+ off 18)))
                                   (card16-get (+ off 16)))
                 :alpha-byte (byte (integer-length (card16-get (+ off 22)))
                                   (card16-get (+ off 20)))
                 :colormap   (let ((cmid (card32-get (+ off 24))))
                               (unless (zerop cmid)
                                 (lookup-colormap display cmid))))))))))

(defun render-set-filter (picture filter)
  (let ((display (picture-display picture)))
    (ensure-render-initialized display)
    (synchronise-picture-state picture)
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderSetPictureFilter+)
      (resource-id (picture-id picture))
      (card16 (length filter))
      (pad16 0)
      ((sequence :format card8) (map 'vector #'char-code filter)))))



#||
(defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over))
  (render-triangles-1 destination op source ...)
  )
||#

(defun render-trapezoids (picture op source src-x src-y mask-format coord-sequence)
  ;; coord-sequence is  top bottom
  ;;                    left-x1 left-y1 left-x2 left-y2
  ;;                    right-x1 right-y1 right-x2 right-y2 ...
  ;;
  (let ((display (picture-display picture)))
    (synchronise-picture-state picture)
    (synchronise-picture-state source)
    (labels ((funk (x) (ash x 16)))
      (with-buffer-request (display (extension-opcode display "RENDER"))
        (data +X-RenderTrapezoids+)
        (render-op op)
        (pad8 0)
        (pad16 0)
        (resource-id (picture-id source))
        (resource-id (picture-id picture))
        ((or (member :none) picture-format) mask-format)
        (int16 src-x)
        (int16 src-y)
        ((sequence :format int32 :transform #'funk) coord-sequence)))))

(defun render-composite (op
                         source mask dest
                         src-x src-y mask-x mask-y dst-x dst-y
                         width height)
  (let ((display (picture-display source)))
    (synchronise-picture-state source)
    (when mask (synchronise-picture-state mask))
    (synchronise-picture-state dest)
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderComposite+)
      (render-op op)
      (pad8 0)
      (pad16 0)
      (resource-id (picture-id source))
      (resource-id (if mask (picture-id mask) 0))
      (resource-id (picture-id dest))
      (int16 src-x)
      (int16 src-y)
      (int16 mask-x)
      (int16 mask-y)
      (int16 dst-x)
      (int16 dst-y)
      (card16 width)
      (card16 height))))

(defun render-create-glyph-set (format &key glyph-set)
  (let ((display (picture-format-display format)))
    (let* ((glyph-set (or glyph-set (make-glyph-set :display display)))
           (gsid (setf (glyph-set-id glyph-set)
                       (allocate-resource-id display glyph-set 'glyph-set))))
      (declare (ignore gsid))
      (setf (glyph-set-format glyph-set) format)
      (with-buffer-request (display (extension-opcode display "RENDER"))
        (data +X-RenderCreateGlyphSet+)
        (glyph-set glyph-set)
        (picture-format format))
      glyph-set)))

(defun render-reference-glyph-set (existing-glyph-set &key glyph-set)
  (let ((display (glyph-set-display existing-glyph-set)))
    (let* ((glyph-set (or glyph-set (make-glyph-set :display display)))
           (gsid (setf (glyph-set-id glyph-set)
                       (allocate-resource-id display glyph-set 'glyph-set))))
      (declare (ignore gsid))
      (setf (glyph-set-format glyph-set)
            (glyph-set-format existing-glyph-set))
      (with-buffer-request (display (extension-opcode display "RENDER"))
        (data +X-RenderReferenceGlyphSet+)
        (glyph-set glyph-set)
        (glyph-set existing-glyph-set))
      glyph-set)))

(defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence
                                  &key (op :over)
                                       (alu op) ;for the fun of it
                                       (src-x 0)
                                       (src-y 0)
                                       (mask-format :none)
                                       (start 0)
                                       (end (length sequence)))
  (let ((display (picture-display dest)))
    (ensure-render-initialized display)
    (synchronise-picture-state dest)
    (synchronise-picture-state source)
    (when (stringp sequence)
      ;; lazy me, but then you should not confuse glyphs with
      ;; characters anyway.
      (setf sequence (map 'vector #'char-code sequence)))
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderCompositeGlyphs8+)
      (render-op alu)
      (pad8 0)
      (pad16 0)
      (picture source)
      (picture dest)
      ((or (member :none) picture-format) mask-format)
      (glyph-set glyph-set)
      (int16 src-x) (int16 src-y)
      (card8 (- end start)) ;length of glyph elt
      (pad8 0)
      (pad16 0)
      (int16 dest-x) (int16 dest-y)             ;dx, dy
      ((sequence :format card8) sequence))))

(defmacro %render-composite-glyphs
    (opcode type transform display dest glyph-set source dest-x dest-y sequence
     alu src-x src-y mask-format start end)
  (let ((size (ecase type (card8 1) (card16 2) (card32 4)))
        ;; FIXME: the last chunk for CARD8 can be 254.
        (chunksize (ecase type (card8 252) (card16 254) (card32 254))))
    `(multiple-value-bind (nchunks leftover)
         (floor (- end start) ,chunksize)
       (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size)))
                              (if (> leftover 0)
                                  (+ 8 (* 4 (ceiling (* leftover ,size) 4)))
                                  0)))
              (request-length (+ 7 (/ payloadsize 4))))
         (declare (integer request-length))
         (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length))
           (data ,opcode)
           (length request-length)
           (render-op ,alu)
           (pad8 0)
           (pad16 0)
           (picture ,source)
           (picture ,dest)
           ((or (member :none) picture-format) ,mask-format)
           (glyph-set ,glyph-set)
           (int16 ,src-x) (int16 ,src-y)
           (progn
             (let ((boffset (+ buffer-boffset 28))
                   (start ,start)
                   (end ,end)
                   (dest-x ,dest-x)
                   (dest-y ,dest-y))
               (dotimes (i nchunks)
                 (set-buffer-offset boffset)
                 (put-items (0)
                   (card8 ,chunksize)
                   (card8 0)
                   (card16 0)
                   (int16 dest-x)
                   (int16 dest-y)
                   ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence))
                 (setq dest-x 0 dest-y 0)
                 (incf boffset (+ 8 (* ,chunksize ,size)))
                 (incf start ,chunksize))
               (when (> leftover 0)
                 (set-buffer-offset boffset)
                 (put-items (0)
                   (card8 leftover)
                   (card8 0)
                   (card16 0)
                   (int16 dest-x)
                   (int16 dest-y)
                   ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence))
                 ;; padding?
                 (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4)))))
               (setf (buffer-boffset ,display) boffset))))))))

(defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence
                                &key (op :over)
                                     (alu op)   ;for the fun of it
                                     (src-x 0)
                                     (src-y 0)
                                     (mask-format :none)
                                     (start 0)
                                     (end (length sequence)))
  ;; xxx do we want to go with some translate function as draw-glyphs?
  (declare (type array-index start end))
  (let ((display (picture-display dest)))
    (ensure-render-initialized display)
    (synchronise-picture-state dest)
    (synchronise-picture-state source)
    ;; hmm find out the element size
    (typecase sequence
      ((array (unsigned-byte 8) (*))
       (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil
                                 display dest glyph-set source dest-x dest-y sequence alu src-x
                                 src-y mask-format start end))
      ((array (unsigned-byte 16) (*))
       (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil
                                 display dest glyph-set source dest-x dest-y sequence alu src-x
                                 src-y mask-format start end))
      ((array (unsigned-byte 32) (*))
       (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil
                                 display dest glyph-set source dest-x dest-y sequence alu src-x
                                 src-y mask-format start end))
      (string
       (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8))  '+X-RenderCompositeGlyphs8+)
                                         ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+)
                                         ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+)
                                         (t
                                          (error "Wow!")))
                                 #.(cond ((<= char-code-limit (expt 2 8))  'card8)
                                         ((<= char-code-limit (expt 2 16)) 'card16)
                                         ((<= char-code-limit (expt 2 32)) 'card32)
                                         (t
                                          (error "Wow!")))
                                 #'char-code
                                 display dest glyph-set source dest-x dest-y sequence alu src-x
                                 src-y mask-format start end))
      (t
       ;; should we bother testing the array element type?
       (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32
                                 #'(lambda (elt)
                                     (if (characterp elt)
                                         (char-code elt)
                                         elt))
                                 display dest glyph-set source dest-x dest-y sequence alu src-x
                                 src-y mask-format start end))) ))

;; --- idea: Allow data to be an image to avoid unecessary consing? - noss
(defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data)
  (let ((display (glyph-set-display glyph-set)))
    (ensure-render-initialized display)
    (let* ((w (array-dimension data 1))
           (h (array-dimension data 0))
           (bitmap-format (display-bitmap-format display))
           (unit (bitmap-format-unit bitmap-format))
           (byte-lsb-first-p (display-image-lsb-first-p display))
           (bit-lsb-first-p  (bitmap-format-lsb-first-p bitmap-format)))
      (let* ((padded-bytes-per-line
              (index* (index-ceiling
                       (index* w (picture-format-depth
                                  (glyph-set-format glyph-set)))
                       32)
                      4))
             (request-bytes
              (index+ 28 (index* h padded-bytes-per-line)))
             (max-bytes-per-request
              (index* (index- (display-max-request-length display) 6) 4)))
        ;; INV: we can do better – if at least one scanline of the
        ;; image fits in the request, we may render glyph in a loop
        ;; like it's done in a function `put-image' in `image.lisp'.
        (when (> request-bytes max-bytes-per-request)
          (error "Glyph won't fit in a single request"))
        (with-buffer-request (display (extension-opcode display "RENDER"))
          (data +X-RenderAddGlyphs+)
          (length (ceiling request-bytes 4))
          (glyph-set glyph-set)
          (card32 1)                    ;number glyphs
          (card32 id)                   ;id
          (card16 w)
          (card16 h)
          (int16 x-origin)
          (int16 y-origin)
          (int16 x-advance)
          (int16 y-advance)
          (progn
            (setf (buffer-boffset display) (advance-buffer-offset 28))
            (let ((im (create-image :width w :height h :depth 8 :data data)))
              (write-image-z display im 0 0 w h
                             padded-bytes-per-line
                             unit byte-lsb-first-p bit-lsb-first-p)) ))) )))

(defun render-add-glyph-from-picture (glyph-set picture
                                      &key x-origin y-origin x-advance y-advance
                                           x y width height)
  ;; untested, the duplication of x-origin seems bogus.
  ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture.
  ;; and orgin advance would be properties of the defined glyph.
  (let ((display (glyph-set-display glyph-set)))
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderAddGlyphsFromPicture+)
      (glyph-set glyph-set)
      (picture picture)
      (card16 width)
      (card16 height)
      (card16 x-origin)
      (card16 y-origin)
      (card16 x-advance)
      (card16 y-advance)
      (card16 x)
      (card16 y))))

;; untested
(defun render-free-glyphs (glyph-set glyphs)
  "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)."
  (let ((display (glyph-set-display glyph-set)))
    (with-buffer-request (display (extension-opcode display "RENDER"))
      (data +X-RenderFreeGlyphs+)
      (glyph-set glyph-set)
      ((sequence :format card32) glyphs))))


#||
;;; --------------------------------------------------------------------------------

;; testing code:

(defun x (op)
  (let ((dpy (open-display "")))
    (render-query-version dpy)
    (unwind-protect
         (let* ((win (screen-root (first (display-roots dpy))))
                (display dpy)
                (pf  (find-window-picture-format win))
                (pm   (xlib:create-pixmap
                       :depth (xlib:drawable-depth win)
                       :drawable win :width 1 :height 1))
                (pm.p  (render-create-picture pm
                                              :format pf
                                              :repeat :on))
                (win.p (render-create-picture win :format pf))
                (gs  (render-create-glyph-set (first
                                               (find-matching-picture-formats
                                                dpy
                                                :alpha 8
                                                :red-max 0
                                                :green-max 0
                                                :blue-max 0)))))
           (xlib:clear-area win)
           (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100)
           (render-add-glyph gs 18
                             :data (make-array (list 3 3)
                                               :initial-contents '((255 000 000)
                                                                   (000 255 000)
                                                                   (000 000 255))
                                               :element-type '(unsigned-byte 8))
                             :x-advance 4
                             :y-advance 0
                             :x-origin 0
                             :y-origin 0)
           (let ((w 50)
                 (h 50))
             (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0)))
               (dotimes (i w)
                 (dotimes (j h)
                   (setf (aref data i j) (* 3 i))))
               (render-add-glyph gs 17
                                 :data data
                                 :x-advance (+ w 2)
                                 :y-advance 0
                                 :x-origin 0
                                 :y-origin 0)))

           (render-composite-glyphs-8 win.p gs pm.p
                                      200 330
                                      (vector 17 18 18 17 17 17 17 17 17 17)
                                      :alu op
                                      )
                                      ;;
           (display-finish-output dpy)
           (close-display dpy)))))

(defun z (op)
  (let ((dpy (open-display "")))
    (unwind-protect
         (let* ((win (screen-root (first (display-roots dpy))))
                (pic (render-create-picture win))
                (fmt (first (find-matching-picture-formats
                             dpy
                             :red-min 8
                             :green-min 8
                             :blue-min 8
                             :alpha-min 8)))
                (px  (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt)
                      :drawable win))
                (px.pic (render-create-picture px :format fmt))
                (px.gc (xlib:create-gcontext :drawable px)))
           (xlib:clear-area win)
           ;;
           (render-fill-rectangle px.pic :src
                                  (list #x8000 #x0000 #x8000 #xFFFF)
                                  0 0 256 256)

           (render-composite :src pic pic px.pic
                             350 350 350 350 0 0 256 256)
           ;;
           (render-fill-rectangle px.pic :over
                                  (list #x8000 #x8000 #x8000 #x8000)
                                  0 0 100 100)
           (render-composite :src
                             px.pic px.pic pic
                             0 0 0 0 350 350
                             256 256)
           (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800)
           (display-finish-output dpy))
      (close-display dpy))))

;;; ----------------------------------------------------------------------------------------------------

(defun y (op)
  (let ((dpy (open-display "")))
    (render-query-version dpy)
    (unwind-protect
         (let* ((win (screen-root (first (display-roots dpy))))
                (pic
                  (render-create-picture win))
                (px  (xlib:create-pixmap :drawable win
                      :width 256
                      :height 256
                      :depth 32))
                (px.gc (xlib:create-gcontext :drawable px)))
           (dotimes (x 256)
             (dotimes (y 256)
               (setf (xlib:gcontext-foreground px.gc)
                     (dpb x (byte 8 24)
                          (dpb y (byte 8 16)
                               (dpb y (byte 8 8)
                                    y))))
               (xlib:draw-point px px.gc x y)
               ))
           (xlib:clear-area win)
           (let ((q (render-create-picture px
                                           :format
                                           (first (find-matching-picture-formats
                                                   dpy
                                                   :depth 32
                                                   :alpha 8 :red 8 :green 8 :blue 8))
                                           :component-alpha :on
                                           :repeat :off)))
             (render-composite op
                               q
                               q
                               pic
                               0 0
                               0 0
                               100 100
                               400 400))
           (let ()
             ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200)
             (display-finish-output dpy)))
      (close-display dpy))))

(defun zz ()
  (let* ((dpy (xlib:open-display ""))
        (win (screen-root (first (display-roots dpy))))
        (pic (render-create-picture win)))
    (xlib:clear-area win)
    (setf (picture-clip-mask pic) (list 100 100 200 2000))
    (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000)
    (display-finish-output dpy)
    (close-display dpy)))
||#


;;;; Cursors

(defun render-create-cursor (picture &optional (x 0) (y 0))
  (let ((display (picture-display picture)))
    (ensure-render-initialized display)
    (synchronise-picture-state picture)
    (let* ((cursor (make-cursor :display display))
           (cid (allocate-resource-id display cursor 'cursor)))
      (setf (cursor-id cursor) cid)
      (with-buffer-request (display (extension-opcode display "RENDER"))
        (data +X-RenderCreateCursor+)
        (resource-id cid)
        (resource-id (picture-id picture))
        (card16 x)
        (card16 y))
      cursor)))

(defun render-create-anim-cursor (cursors delays)
  "Create animated cursor. cursors length must be the same as delays length."
  (let ((display (cursor-display (first cursors))))
    (ensure-render-initialized display)
    (let* ((cursor (make-cursor :display display))
           (cid (allocate-resource-id display cursor 'cursor))
           (cursors-length (length cursors))
           (cursors-delays (make-list (* 2 (length cursors)))))
      (setf (xlib:cursor-id cursor) cid)
      (dotimes (i cursors-length)
        (setf (elt cursors-delays (* 2 i)) (cursor-id (elt cursors i))
              (elt cursors-delays (1+ (* 2 i))) (elt delays i)))
      (xlib::with-buffer-request (display (extension-opcode display "RENDER"))
        (data +X-RenderCreateAnimCursor+)
        (resource-id cid)
        ((sequence :format card32) cursors-delays))
      cursor)))
