Author: tpapp Date: Wed Aug 22 12:13:14 2007 New Revision: 13

Added: xlib-context.lisp Removed: x11-context.lisp Modified: cl-cairo2.asd context.lisp package.lisp surface.lisp transformations.lisp tutorial/tutorial.tex xlib.lisp Log: another major revamping of X11 code, also put exported symbols in package.lisp where they belong

Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Wed Aug 22 12:13:14 2007 @@ -15,7 +15,7 @@ (:file "xlib" :depends-on ("context") :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix)))) - (:file "x11-context" :depends-on ("xlib") + (:file "xlib-context" :depends-on ("xlib") :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix))))) :depends-on (:cffi :cl-colors :cl-utilities))

Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Wed Aug 22 12:13:14 2007 @@ -22,20 +22,24 @@ ;;;; context class ;;;;

-(defclass context () ((pointer :initform nil))) - -(export - (defun create-context (surface) - (with-surface (surface pointer) - (let ((context (make-instance 'context))) - (setf (slot-value context 'pointer) (cairo_create pointer)) - ;; register finalizer -;; (let ((context-pointer (slot-value context 'pointer))) -;; (finalize context -;; #'(lambda () -;; (cairo_destroy context-pointer)))) - ;; return context - context)))) +(defclass context () + ((pointer :initform nil :initarg :pointer) + (width :initarg :width :reader get-width) + (height :initarg :height :reader get-height))) + +(defun create-context (surface) + (with-surface (surface pointer) + (let ((context (make-instance 'context + :pointer (cairo_create pointer) + :width (get-width surface) + :height (get-height surface)))) + ;; register finalizer + (let ((context-pointer (slot-value context 'pointer))) + (finalize context + #'(lambda () + (cairo_destroy context-pointer)))) + ;; return context + context)))

(defmethod destroy ((object context)) (with-slots (pointer) object @@ -45,11 +49,23 @@ ;; deregister finalizer (cancel-finalization object))

-(defgeneric sync (object)) - -(defmethod sync ((object context)) - ;; most contexts don't need syncing - ) +(defgeneric sync (object) + (:documentation "Synchronize contents of the object with the + physical device if needed.")) +(defgeneric sync-lock (object) + (:documentation "Suspend syncing (ie sync will have no effect) until + sync-unlock is called. Calls to sync-lock nest.")) +(defgeneric sync-unlock (object) + (:documentation "Undo a call to sync-lock.")) +(defgeneric sync-reset (object) + (:documentation "Undo all calls to sync, ie object will be +synced (if necessary) no matter how many times sync was called before.")) + +;; most contexts don't need syncing +(defmethod sync ((object context))) +(defmethod sync-lock ((object context))) +(defmethod sync-unlock ((object context))) +(defmethod sync-reset ((object context)))

;;;; ;;;; default context and convenience macros @@ -74,28 +90,25 @@ "Define cairo function with *context* as its first argument and args as the rest, automatically mapping name to the appropriate cairo function." - `(export - (defun ,name (,@args &optional (context *context*)) - (with-context (context pointer) - (,(prepend-intern "cairo_" name) pointer ,@args))))) + `(defun ,name (,@args &optional (context *context*)) + (with-context (context pointer) + (,(prepend-intern "cairo_" name) pointer ,@args))))

(defmacro define-with-default-context-sync (name &rest args) "Define cairo function with *context* as its first argument and args as the rest, automatically mapping name to the appropriate cairo function. sync will be called after the operation." - `(export - (defun ,name (,@args &optional (context *context*)) - (with-context (context pointer) - (,(prepend-intern "cairo_" name) pointer ,@args)) - (sync context)))) + `(defun ,name (,@args &optional (context *context*)) + (with-context (context pointer) + (,(prepend-intern "cairo_" name) pointer ,@args)) + (sync context)))

(defmacro define-flexible ((name pointer &rest args) &body body) "Like define-with-default context, but with arbitrary body, pointer will point to the context." - `(export - (defun ,name (,@args &optional (context *context*)) - (with-context (context ,pointer) - ,@body)))) + `(defun ,name (,@args &optional (context *context*)) + (with-context (context ,pointer) + ,@body)))

(defmacro define-many-with-default-context (&body args) "Apply define-with-default context to a list. Each item is @@ -156,18 +169,15 @@

(defgeneric set-source-color (color &optional context))

-(defmethod set-source-color - ((color rgb) &optional (context *context*)) +(defmethod set-source-color ((color rgb) &optional (context *context*)) (with-slots (red green blue) color (set-source-rgb red green blue context)))

-(defmethod set-source-color - ((color rgba) &optional (context *context*)) +(defmethod set-source-color ((color rgba) &optional (context *context*)) (with-slots (red green blue alpha) color (set-source-rgb red green blue alpha context)))

-(defmethod set-source-color - ((color hsv) &optional (context *context*)) +(defmethod set-source-color ((color hsv) &optional (context *context*)) (with-slots (red green blue) (hsv->rgb color) (set-source-rgb red green blue context)))

@@ -228,3 +238,11 @@

(define-flexible (in-stroke pointer x y) (not (zerop (cairo_in_stroke pointer x y)))) + +;;;; +;;;; convenience functions for creating contexts directly +;;;; + +(define-create-context ps) +(define-create-context pdf) +(define-create-context svg)

Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Wed Aug 22 12:13:14 2007 @@ -1,15 +1,54 @@ (defpackage :cl-cairo2 (:use :common-lisp :cffi :cl-colors :cl-utilities) - (:export ; !!! when the interface - ; stabilizes, remove export's - ; from all other places and - ; list them here - ;; utility functions - deg-to-rad + (:export + + ;; cairo + + destroy deg-to-rad + + ;; surface + + get-width get-height destroy create-image-surface + image-surface-get-format image-surface-get-width + image-surface-get-height image-surface-create-from-png + surface-write-to-png with-png-file + ;; context - *context* set-source-color + + create-context sync sync-lock sync + sync-unlock sync-reset *context* save restore push-group pop-group + pop-group-to-source set-source-rgb set-source-rgba clip + clip-preserve reset-clip copy-page show-page fill-preserve paint + paint-with-alpha stroke stroke-preserve set-source-color + get-line-width set-line-width get-miter-limit set-miter-limit + get-antialias set-antialias get-fill-rule set-fill-rule + get-line-cap set-line-cap get-line-join set-line-join get-operator + set-operator fill-path set-dash get-dash clip-extents fill-extents + in-fill in-stoke create-ps-context create-pdf-context + create-svg-context + + ;; path + + new-path new-sub-path close-path arc arc-negative curve-to line-to + move-to rectangle rel-move-to rel-curve-to rel-line-to text-path + get-current-point + + ;; text + + select-font-face set-font-size text-extents show-text + ;; transformations - make-trans-matrix trans-matrix-xx trans-matrix-yx trans-matrix-xy - trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p - ;; x11-context - x11-context x11-display open-x11-display create-x11-context)) + + translate scale rotate reset-trans-matrix make-trans-matrix + trans-matrix-xx trans-matrix-yx trans-matrix-xy trans-matrix-yy + trans-matrix-x0 trans-matrix-y0 trans-matrix-p transform + set-trans-matrix get-trans-matrix user-to-device + user-to-device-distance device-to-user device-to-user-distance + trans-matrix-init-translate trans-matrix-init-scale + trans-matrix-init-rotate trans-matrix-rotate trans-matrix-scale + trans-matrix-rotate trans-matrix-invert trans-matrix-multiply + trans-matrix-distance transform-point + + ;; xlib-context + + xlib-context xlib-display open-xlib-display create-xlib-context))

Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Wed Aug 22 12:13:14 2007 @@ -13,7 +13,10 @@ ;;;; class surface ;;;;

-(defclass surface () ((pointer :initarg :pointer :initform nil))) +(defclass surface () + ((pointer :initarg :pointer :initform nil) + (width :initarg :width :reader get-width) + (height :initarg :height :reader get-height)))

(defmacro with-alive-surface ((surface pointer) &body body) "Execute body with pointer pointing to cairo surface, if nil, @@ -39,9 +42,9 @@ (check-surface-pointer-status ,pointer ,@body)))

-(defun new-surface-with-check (pointer) +(defun new-surface-with-check (pointer width height) "Check if the creation of new surface was successful, if so, return new class." - (let ((surface (make-instance 'surface))) + (let ((surface (make-instance 'surface :width width :height height))) (check-surface-pointer-status pointer (setf (slot-value surface 'pointer) pointer) ;; register finalizer @@ -62,97 +65,93 @@ ;;;;

(defmacro define-create-surface (type) - `(export - (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface") - (filename width-in-points height-in-points) - (new-surface-with-check - (,(prepend-intern "cairo_" type :replace-dash nil - :suffix "_surface_create") - filename width-in-points height-in-points))))) + "Define the function create-<type>-surface." + `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface") + (filename width height) + (new-surface-with-check + (,(prepend-intern "cairo_" type :replace-dash nil + :suffix "_surface_create") + filename width height) + width height)))

(defmacro define-create-context (type) - `(export - (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context") - (filename width-in-points height-in-points) - "Create a surface, then a context for a file, then + `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context") + (filename width height) + "Create a surface, then a context for a file, then destroy (dereference) the surface. The user only needs to destroy the context when done." - (let* ((surface (,(prepend-intern "create-" - type :replace-dash nil :suffix "-surface") - filename width-in-points height-in-points)) - (context (create-context surface))) - (destroy surface) - context)))) - + (let* ((surface (,(prepend-intern "create-" + type :replace-dash nil :suffix "-surface") + filename width height)) + (context (create-context surface))) + (destroy surface) + context)))

;;;; ;;;; PDF surface ;;;;

(define-create-surface pdf) -(define-create-context pdf)

;;;; ;;;; PostScript surface ;;;;

(define-create-surface ps) -(define-create-context ps)

;;;; ;;;; SVG surface ;;;;

(define-create-surface svg) -(define-create-context svg)

;;;; ;;;; image surface ;;;;

-(export - (defun create-image-surface (format width height) - (new-surface-with-check - (cairo_image_surface_create (lookup-enum format table-format) - width height)))) - -(export - (defun image-surface-get-format (surface) - (with-surface (surface pointer) - (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format)))) - -(export - (defun image-surface-get-width (surface) - (with-surface (surface pointer) - (cairo_image_surface_get_width pointer)))) - -(export - (defun image-surface-get-height (surface) - (with-surface (surface pointer) - (cairo_image_surface_get_height pointer)))) +(defun create-image-surface (format width height) + (new-surface-with-check + (cairo_image_surface_create (lookup-enum format table-format) + width height) + width height)) + +(defun image-surface-get-format (surface) + (with-surface (surface pointer) + (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format))) + +(defun image-surface-get-width (surface) + (with-surface (surface pointer) + (cairo_image_surface_get_width pointer))) + +(defun image-surface-get-height (surface) + (with-surface (surface pointer) + (cairo_image_surface_get_height pointer)))

;;;; ;;;; PNG surfaces ;;;;

-(export - (defun image-surface-create-from-png (filename) - (new-surface-with-check (cairo_image_surface_create_from_png filename)))) - -(export - (defun surface-write-to-png (surface filename) - (with-surface (surface pointer) - (cairo_surface_write_to_png pointer filename)))) - -(export - (defmacro with-png-file ((filename format width height) &body body) - "Execute the body with context bound to a newly created png +(defun image-surface-create-from-png (filename) + (let ((surface + (new-surface-with-check (cairo_image_surface_create_from_png filename) + 0 0))) + (with-slots (width height) surface + (setf width (image-surface-get-width surface) + height (image-surface-get-height surface)) + surface))) + +(defun surface-write-to-png (surface filename) + (with-surface (surface pointer) + (cairo_surface_write_to_png pointer filename))) + +(defmacro with-png-file ((filename format width height) &body body) + "Execute the body with context bound to a newly created png file, and close it after executing body." - (let ((surface-name (gensym))) - `(let* ((,surface-name (create-image-surface ,format ,width ,height)) - (*context* (create-context ,surface-name))) - (progn - ,@body - (surface-write-to-png ,surface-name ,filename) - (destroy ,surface-name) - (destroy *context*)))))) + (let ((surface-name (gensym))) + `(let* ((,surface-name (create-image-surface ,format ,width ,height)) + (*context* (create-context ,surface-name))) + (progn + ,@body + (surface-write-to-png ,surface-name ,filename) + (destroy ,surface-name) + (destroy *context*)))))

Modified: transformations.lisp ============================================================================== --- transformations.lisp (original) +++ transformations.lisp Wed Aug 22 12:13:14 2007 @@ -131,12 +131,11 @@ (defmacro define-matrix-init (name &rest args) "Define a matrix initializer function with args, which returns the new matrix." - `(export - (defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) ,args - (with-trans-matrix-out matrix-pointer - (,(prepend-intern "cairo_matrix_init_" name) - matrix-pointer - ,@args))))) + `(defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) ,args + (with-trans-matrix-out matrix-pointer + (,(prepend-intern "cairo_matrix_init_" name) + matrix-pointer + ,@args))))

(define-matrix-init translate tx ty) (define-matrix-init scale sx sy) @@ -157,23 +156,20 @@ (define-matrix-transformation rotate radians) (define-matrix-transformation invert)

-(export - (defun trans-matrix-multiply (a b) - (with-trans-matrix-in a a-pointer - (with-trans-matrix-in b b-pointer - (with-trans-matrix-out result-pointer - (cairo_matrix_multiply result-pointer - a-pointer - b-pointer)))))) - -(export - (defun transform-distance (matrix x y) - (with-trans-matrix-in matrix matrix-pointer - (with-x-y - (cairo_matrix_transform_distance matrix-pointer xp yp))))) - -(export - (defun transform-point (matrix x y) - (with-trans-matrix-in matrix matrix-pointer - (with-x-y - (cairo_matrix_transform_point matrix-pointer xp yp))))) +(defun trans-matrix-multiply (a b) + (with-trans-matrix-in a a-pointer + (with-trans-matrix-in b b-pointer + (with-trans-matrix-out result-pointer + (cairo_matrix_multiply result-pointer + a-pointer + b-pointer))))) + +(defun transform-distance (matrix x y) + (with-trans-matrix-in matrix matrix-pointer + (with-x-y + (cairo_matrix_transform_distance matrix-pointer xp yp)))) + +(defun transform-point (matrix x y) + (with-trans-matrix-in matrix matrix-pointer + (with-x-y + (cairo_matrix_transform_point matrix-pointer xp yp))))

Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Wed Aug 22 12:13:14 2007 @@ -128,14 +128,15 @@ CLOS wrappers, and can be closed (\emph{destroyed}) with \lstinline!destroy!.

-When the context is created from a surface, the reference count of the -latter is incremented. You can immediately destroy the surface: it -will not be destroyed (ie the file will not be closed) until you -destroy the context.\footnote{The file will also be closed if the - wrapper object is garbage collected. However, you should not rely - on this, as calling the garbage collector is not portable.} The -following code draws a white diagonal line on a blue background, using -a Postscript file -- the result is shown in Figure~\ref{fig:example}. +When the context is created from a surface, the reference count (in +the internals of Cairo) of the latter is incremented. You can +immediately destroy the surface: it will not be destroyed (ie the file +will not be closed) until you destroy the context.\footnote{The file + will also be closed if the wrapper object is garbage collected. + However, you should not rely on this, as calling the garbage + collector is not portable.} The following code draws a white +diagonal line on a blue background, using a Postscript file -- the +result is shown in Figure~\ref{fig:example}.

\lstinputlisting[firstline=13,lastline=27]{example.lisp}

@@ -153,6 +154,10 @@ \begin{lstlisting} (setf *context* (create-ps-context "example.ps" 200 100)) \end{lstlisting} +Unlike the original Cairo API, surfaces and contexts in +\lstinline!cl-cairo2! remember their width and height. Use the +generic functions \lstinline!get-width! and \lstinline!get-height! to +extract these.

When you want to write the output into a bitmap file (for example, in PNG format), you first need to create an \emph{image surface}, then @@ -230,7 +235,7 @@ written to PNG files) are supported.

Drawing in X11 windows is implemented using the -\lstinline!x11-context! class --- see Section~\ref{sec:x11-context} +\lstinline!x11-context! class --- see Section~\ref{sec:xlib-context} for more information.

\subsection{Contexts} @@ -334,45 +339,50 @@ with \lstinline!trans-matrix-!, and other a few other functions have been renamed to avoid conflicts with linear algebra packages.

-\subsection{X11 Contexts} -\label{sec:x11-context} +\subsection{Xlib Contexts} +\label{sec:xlib-context}

-The x11 context is not part of cairo -- it is a bit of glue code that +The xlib context is not part of cairo -- it is a bit of glue code that uses cairo's X11 surface on a pixmap, and displays this pixmap when needed (when X11 asks for the window contents to be redrawn or when cairo draws on the pixmap).

-In order to open an \lstinline!x11-context!, first you need to open an -\lstinline!x11-display!, for example, -\begin{lstlisting} -(defparameter *display* (open-x11-display ":0")) -\end{lstlisting} -opens a display on the local host. Each display runs an event loop in -a separate thread, and you can open several display and several -windows on each simultaneously. The X11 event loop runs in a separate -thread, so you need a Lisp implementation that supports threads. You -can close displays with \lstinline!destroy!, all open windows will be -closed and the contexts mapping into these windows will be destroyed -(drawing on them will be an invalid operation). - -For cl-cairo2, each window maps to a context. The surface is not +In cl-cairo2, each window maps to a context. The surface is not exposed to the user, who is only allowed to see the context. This -makes memory management and proper cleanup easier. - -You can create Xlib contexts with +makes memory management and proper cleanup easier. For example, you +can create an \lstinline!xlib-context! with \begin{lstlisting} - (create-x11-context width height display) +(setf *context* (create-xlib-context 500 400 + :display-name "localhost:0" + :window-name "my pretty drawing")) \end{lstlisting} -When \lstinline!destroy!ed, the window is closed. This works the -other way too: when the window is closed, the context is destroyed. -The windows are double-buffered using a pixmap on the X11 server, -therefore redrawing exposed windows is fast. However, this +If you give \lstinline!nil! for \lstinline!display-name!, Xlib fill +probably figure out a reasonable default, usually from your +\verb!$DISPLAY! environment variable. + +The X11 event loop runs in a separate thread, so you need a Lisp +implementation that supports threads. + +When the context \lstinline!destroy!ed, the window is closed. This +works the other way too: when the window is closed, the context is +destroyed. The windows are double-buffered using a pixmap on the X11 +server, therefore redrawing exposed windows is fast. However, this implementation precludes the resizing of the window.

Example code can be found in \verb!tutorial/x11-example.lisp!. The current implementation is not optimized for speed (the whole window is -redrawn all the time) but it is fast enough for me. If you need speed -improvements desperately, please contact the author. +redrawn all the time) but it is fast enough. If you draw a lot of +objects at the same time, it is suggested that you suspend +synchronizing with the X-window server using + \lstinline!(sync-lock context)!. + When you are done, you can call \lstinline!(sync-unlock context)!, which will automatically sync the buffer and the window. +You can nest calls to \lstinline!sync-lock! and +\lstinline!sync-unlock!, and if you want to restore syncing +unconditionally, use \lstinline!sync-reset!, which also performs +syncing too. These are generic functions which do nothing for other +contexts. + +

\subsection{To Do} \label{sec:todo}

Added: xlib-context.lisp ============================================================================== --- (empty file) +++ xlib-context.lisp Wed Aug 22 12:13:14 2007 @@ -0,0 +1,238 @@ +(in-package :cl-cairo2) + +;; constants for communicating with the signal window +(defconstant +destroy-message+ 4072) ; just some random constant +(defconstant +refresh-message+ 2495) ; ditto + +(defvar *xlib-context-count* 0 "window counter for autogenerating names") + +(defun next-xlib-context-name () + "Return an autogenerated window name using *xlib-context-count*." + (format nil "cl-cairo2 ~a" (incf *xlib-context-count*))) + +;; code to make threads, please extend with your own Lisp if needed +;; testing is welcome, I only tested cmucl and sbcl +(defun start-thread (function name) + #+allegro (mp:process-run-function name function) + #+armedbear (ext:make-thread function :name name) + #+cmu (mp:make-process function :name name) + #+lispworks (mp:process-run-function name nil function) + #+openmcl (ccl:process-run-function name function) + #+sbcl (sb-thread:make-thread function :name name)) + +;; we create this definition manually, SWIG just messes things up +(defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) cairo_surface_t + (display display) + (drawable drawable) + (visual visual) + (width :int) + (height :int)) + +;; The class for an x11 context. Each context has a separate display +;; queue, window and an event loop in a separate thread. Once the +;; event loop is started, communication with the thread is done via +;; X11 ClientNotify events (see wacky constants above). + +(defclass xlib-context (context) + ((display :initarg :display) + (wm-delete-window) + (window) + (signal-window) + (pixmap) + (graphics-context) + (thread) + (sync-counter :initform 0 :accessor sync-counter))) + +(defun refresh-xlib-context (xlib-context) + "Copy the contents of the pixmap to the window. This function is +meant for internal use in the cl-cairo2 package." + (with-slots (display width height window pixmap graphics-context) xlib-context + (xcopyarea display pixmap window graphics-context + 0 0 width height 0 0) + (xsync display 1))) + +(defun create-window (display parent width height class visual background-pixel + event-mask &optional (backing-store t)) + "Create an x11 window, placed at 0 0, with the given attributes. +For internal use in the cl-cairo2 package." + ;; call xcreatewindow with attributes + (with-foreign-object (attributes 'xsetwindowattributes) + (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask) + event-mask + (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel) + background-pixel + (foreign-slot-value attributes 'xsetwindowattributes 'backing-store) + (if backing-store 1 0)) + (xcreatewindow display parent 0 0 width height + 0 ; zero border width + 0 ; depth - copy from parent + (ecase class + (copyfromparent 0) + (inputoutput 1) + (inputonly 2)) ; class + visual + (if (eq class 'inputonly) + cweventmask + (logior cwbackpixel cwbackingstore cweventmask)) + attributes))) + +(defun create-xlib-context (width height &key + (display-name nil) + (window-name (next-xlib-context-name))) + (let ((display (xopendisplay (if display-name display-name (null-pointer))))) + (when (null-pointer-p display) + (error "couldn't open display ~a" display-name)) + (let ((xlib-context (make-instance 'xlib-context + :display display + :width width + :height height))) + (flet ((event-loop () + (with-slots (display (this-window window) signal-window + pixmap + wm-delete-window graphics-context) + xlib-context + (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1))) + (with-foreign-object (xev :long 24) + (do ((got-close-signal nil)) + (got-close-signal) + ;; get next event + (xnextevent display xev) + ;; decipher structure, at least partially + (with-foreign-slots ((type window serial) xev xanyevent) + ;; action based on event type + (cond + ;; expose and configurenotify events + ((and (= type 12) (= window this-window)) + (refresh-xlib-context xlib-context)) + ;; clientnotify event + ((= type 33) + (with-foreign-slots ((message-type data0) xev + xclientmessageevent) + (cond + ((or (and (= window signal-window) + (= data0 +destroy-message+)) + (and (= window this-window) + (= message-type wm-protocols) + (= data0 wm-delete-window))) + (setf got-close-signal t)) + ((and (= window signal-window) + (= data0 +refresh-message+)) + (refresh-xlib-context xlib-context))))))))))) + ;; close down everything + (with-slots (display pixmap window signal-window pointer) + xlib-context + (let ((saved-pointer pointer)) + (setf pointer nil) ; invalidate first so it can't be used + (cairo_destroy saved-pointer)) + (xfreepixmap display pixmap) + (xdestroywindow display window) + (xdestroywindow display signal-window) + (xclosedisplay display)))) + ;; initialize + (xsynchronize display 1) + (let* ((screen (xdefaultscreen display)) + (root (xdefaultrootwindow display)) + (visual (xdefaultvisual display screen)) + (depth (xdefaultdepth display screen)) + (whitepixel (xwhitepixel display screen))) + (with-slots (window pixmap signal-window thread wm-delete-window + pointer graphics-context) xlib-context + ;; create signal window and window + (setf window + (create-window display root width height 'inputoutput visual + whitepixel + (logior exposuremask + structurenotifymask) + t)) + (setf signal-window + (create-window display root 1 1 'inputonly visual + whitepixel 0 nil)) + ;; create pixmap + (setf pixmap + (xcreatepixmap display window width height depth)) + ;; create graphics-context + (setf graphics-context + (xcreategc display pixmap 0 (null-pointer))) + ;; set size hints on window (most window managers will respect this) + (let ((hints (xallocsizehints))) + (with-foreign-slots ((flags x y min-width min-height + max-width max-height) + hints + xsizehints) + ;; we only set the first four values because old WM's might + ;; get confused if we don't, they should be ignored + (setf flags (logior pminsize pmaxsize) + x 0 + y 0 + (foreign-slot-value hints 'xsizehints 'width) width + (foreign-slot-value hints 'xsizehints 'height) height + min-width width + max-width width + min-height height + max-height height) + (xsetwmnormalhints display window hints) + (xfree hints))) + ;; intern atom for window closing, set protocol on window + (setf wm-delete-window + (xinternatom display "WM_DELETE_WINDOW" 1)) + (with-foreign-object (prot 'atom) + (setf (mem-aref prot 'atom) wm-delete-window) + (xsetwmprotocols display window prot 1)) + ;; store name + (xstorename display window window-name) + ;; create cairo context + (let ((surface (cairo_xlib_surface_create display pixmap visual + width height))) + (setf pointer (cairo_create surface)) + ;; !!! error checking + (cairo_surface_destroy surface)) + ;; map window + (xmapwindow display window) + ;; end of synchronizing + (xsynchronize display 0) + ;; start thread + (setf thread + (start-thread + #'event-loop + (format nil "thread for display ~a" display-name)))))) + ;; return context + xlib-context))) + + +(defun send-message-to-signal-window (xlib-context message) + "Send the desired message to the context window." + (with-slots ((display-pointer display) signal-window) xlib-context + (with-foreign-object (xev :long 24) + (with-foreign-slots + ((type display window message-type format data0) + xev xclientmessageevent) + (setf type 33) ; clientnotify + (setf display display-pointer) + (setf window signal-window) + (setf message-type 0) + (setf format 32) + (setf data0 message) + (xsendevent display-pointer signal-window 0 0 xev)) + (xflush display-pointer)))) + + +(defmethod destroy ((object xlib-context)) + (send-message-to-signal-window object +destroy-message+)) + +(defmethod sync ((object xlib-context)) + (when (zerop (sync-counter object)) + (send-message-to-signal-window object +refresh-message+))) + +(defmethod sync-lock ((object xlib-context)) + (incf (sync-counter object))) + +(defmethod sync-unlock ((object xlib-context)) + (with-slots (sync-counter) object + (when (plusp sync-counter) + (decf sync-counter))) + (sync object)) + +(defmethod sync-reset ((object xlib-context)) + (setf (sync-counter object) 0) + (sync object)) +

Modified: xlib.lisp ============================================================================== --- xlib.lisp (original) +++ xlib.lisp Wed Aug 22 12:13:14 2007 @@ -13,6 +13,8 @@ (defctype drawable xid) (defctype window xid) (defctype pixmap xid) +(defctype cursor xid) +(defctype colormap xid) (defctype graphics-context xid) (defctype visual :pointer) (defctype atom :unsigned-long) @@ -62,7 +64,6 @@ ownergrabbuttonmask 24)

- ;;;; error code handling (defmacro check-status (call) "Check the return calue of call, if nonzero, display an error message." @@ -139,6 +140,60 @@ (border :unsigned-long) (background :unsigned-long))

+(defcfun ("XCreateWindow" xcreatewindow) window + (display display) + (parent window) + (x :int) + (y :int) + (width :unsigned-int) + (height :unsigned-int) + (border-width :unsigned-int) + (depth :int) + (class :unsigned-int) + (visual visual) + (valuemask :unsigned-long) + (attributes :pointer)) + +(defcstruct xsetwindowattributes + (background-pixmap pixmap) + (background-pixel :unsigned-long) + (border-pixmap pixmap) + (border-pixel :unsigned-long) + (bit-gravity :int) + (win-gravity :int) + (backing-store :int) + (backing-planes :unsigned-long) + (backing-pixel :unsigned-long) + (save-under bool) + (event-mask :long) + (do-not-propagate_mask :long) + (override-redirect bool) + (colormap colormap) + (cursor cursor)) + +(define-bitmask-constants + CWBackPixmap 0 + CWBackPixel 1 + CWBorderPixmap 2 + CWBorderPixel 3 + CWBitGravity 4 + CWWinGravity 5 + CWBackingStore 6 + CWBackingPlanes 7 + CWBackingPixel 8 + CWOverrideRedirect 9 + CWSaveUnder 10 + CWEventMask 11 + CWDontPropagate 12 + CWColormap 13 + CWCursor 14) + +(defcfun ("XChangeWindowAttributes" xchangewindowattributes) :int + (display display) + (window window) + (valuemask :unsigned-long) + (attributes :pointer)) + (defcfun ("XDestroyWindow" xdestroywindow) :int (display display) (window window)) @@ -170,12 +225,23 @@ (height :unsigned-int) (destination-x :int) (destination-y :int)) -

+(defcfun ("XSetGraphicsExposures" xsetgraphicsexposures) :int + (display display) + (graphics-context graphics-context) + (graphics-exposures bool)) + + ;; synchronization & threads

(defcfun ("XInitThreads" xinitthreads) :int)

+(defcfun ("XLockDisplay" xlockdisplay) :int + (display display)) + +(defcfun ("XUnlockDisplay" xunlockdisplay) :int + (display display)) + (defcfun ("XSynchronize" xsynchronize) :int (display display) (onoff :int)) @@ -243,6 +309,14 @@ ;; we only use first field, union of message data is not included (data0 :unsigned-long))

+(defcstruct xvisibilityevent + (type :int) + (serial :unsigned-long) + (send-event bool) + (display display) + (window window) + (state :int)) + (defcfun ("XNextEvent" xnextevent) :int (display display) (event-return :pointer))