[cl-cairo2-cvs] r13 - tutorial
tpapp at common-lisp.net
tpapp at common-lisp.net
Wed Aug 22 16:13:16 UTC 2007
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 (, at args &optional (context *context*))
- (with-context (context pointer)
- (,(prepend-intern "cairo_" name) pointer , at args)))))
+ `(defun ,name (, at args &optional (context *context*))
+ (with-context (context pointer)
+ (,(prepend-intern "cairo_" name) pointer , at 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 (, at args &optional (context *context*))
- (with-context (context pointer)
- (,(prepend-intern "cairo_" name) pointer , at args))
- (sync context))))
+ `(defun ,name (, at args &optional (context *context*))
+ (with-context (context pointer)
+ (,(prepend-intern "cairo_" name) pointer , at 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 (, at args &optional (context *context*))
- (with-context (context ,pointer)
- , at body))))
+ `(defun ,name (, at args &optional (context *context*))
+ (with-context (context ,pointer)
+ , at 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
, at 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
- , at 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
+ , at 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
- , at 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
+ , at 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))
More information about the Cl-cairo2-cvs
mailing list