[cl-cairo2-cvs] r11 - cffi tutorial
tpapp at common-lisp.net
tpapp at common-lisp.net
Mon Aug 13 14:30:45 UTC 2007
Author: tpapp
Date: Mon Aug 13 10:30:44 2007
New Revision: 11
Added:
tutorial/x11-example.lisp
x11-context.lisp
xlib.lisp
Removed:
README.xlib-context
cffi/
tutorial/xlib-example.lisp
xlib-context.lisp
Modified:
cl-cairo2-swig.lisp
cl-cairo2.asd
cl-cairo2.i
context.lisp
package.lisp
path.lisp
surface.lisp
transformations.lisp
tutorial/tutorial.tex
Log:
minor bugfixes, complete reworking of x11 support, support for cl-colors
Modified: cl-cairo2-swig.lisp
==============================================================================
--- cl-cairo2-swig.lisp (original)
+++ cl-cairo2-swig.lisp Mon Aug 13 10:30:44 2007
@@ -1279,50 +1279,4 @@
(cffi:defcfun ("cairo_svg_version_to_string" cairo_svg_version_to_string) :string
(version cairo_svg_version_t))
-(cffi:defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) :pointer
- (dpy :pointer)
- (drawable :pointer)
- (visual :pointer)
- (width :int)
- (height :int))
-
-(cffi:defcfun ("cairo_xlib_surface_create_for_bitmap" cairo_xlib_surface_create_for_bitmap) :pointer
- (dpy :pointer)
- (bitmap :pointer)
- (screen :pointer)
- (width :int)
- (height :int))
-
-(cffi:defcfun ("cairo_xlib_surface_set_size" cairo_xlib_surface_set_size) :void
- (surface :pointer)
- (width :int)
- (height :int))
-
-(cffi:defcfun ("cairo_xlib_surface_set_drawable" cairo_xlib_surface_set_drawable) :void
- (surface :pointer)
- (drawable :pointer)
- (width :int)
- (height :int))
-
-(cffi:defcfun ("cairo_xlib_surface_get_display" cairo_xlib_surface_get_display) :pointer
- (surface :pointer))
-
-(cffi:defcfun ("cairo_xlib_surface_get_drawable" cairo_xlib_surface_get_drawable) :pointer
- (surface :pointer))
-
-(cffi:defcfun ("cairo_xlib_surface_get_screen" cairo_xlib_surface_get_screen) :pointer
- (surface :pointer))
-
-(cffi:defcfun ("cairo_xlib_surface_get_visual" cairo_xlib_surface_get_visual) :pointer
- (surface :pointer))
-
-(cffi:defcfun ("cairo_xlib_surface_get_depth" cairo_xlib_surface_get_depth) :int
- (surface :pointer))
-
-(cffi:defcfun ("cairo_xlib_surface_get_width" cairo_xlib_surface_get_width) :int
- (surface :pointer))
-
-(cffi:defcfun ("cairo_xlib_surface_get_height" cairo_xlib_surface_get_height) :int
- (surface :pointer))
-
Modified: cl-cairo2.asd
==============================================================================
--- cl-cairo2.asd (original)
+++ cl-cairo2.asd Mon Aug 13 10:30:44 2007
@@ -1,6 +1,6 @@
(defsystem cl-cairo2
:description "Cairo 1.4 bindings"
- :version "0.2.3"
+ :version "0.3"
:author "Tamas K Papp"
:license "GPL"
:components ((:file "package")
@@ -12,7 +12,10 @@
(:file "path" :depends-on ("context"))
(:file "text" :depends-on ("context"))
(:file "transformations" :depends-on ("context"))
- (:file "xlib-context" :depends-on ("context")
- :in-order-to ((load-op (feature :unix))
- (compile-op (feature :unix)))))
- :depends-on (:cffi :cl-colors))
+ (:file "xlib" :depends-on ("context")
+ :in-order-to ((load-op (feature :unix))
+ (compile-op (feature :unix))))
+ (:file "x11-context" :depends-on ("xlib")
+ :in-order-to ((load-op (feature :unix))
+ (compile-op (feature :unix)))))
+ :depends-on (:cffi :cl-colors :cl-utilities))
Modified: cl-cairo2.i
==============================================================================
--- cl-cairo2.i (original)
+++ cl-cairo2.i Mon Aug 13 10:30:44 2007
@@ -44,6 +44,5 @@
%include /usr/include/cairo/cairo-xlib-xrender.h
%include /usr/include/cairo/cairo-pdf.h
%include /usr/include/cairo/cairo-svg.h
-%include /usr/include/cairo/cairo-xlib.h
Modified: context.lisp
==============================================================================
--- context.lisp (original)
+++ context.lisp Mon Aug 13 10:30:44 2007
@@ -30,10 +30,10 @@
(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))))
+;; (let ((context-pointer (slot-value context 'pointer)))
+;; (finalize context
+;; #'(lambda ()
+;; (cairo_destroy context-pointer))))
;; return context
context))))
@@ -97,7 +97,7 @@
(with-context (context ,pointer)
, at body))))
-(defmacro define-many-with-default-context (&rest args)
+(defmacro define-many-with-default-context (&body args)
"Apply define-with-default context to a list. Each item is
itself a list, first element gives the function name, the rest
the arguments."
@@ -131,8 +131,8 @@
;;;;
(define-many-with-default-context
- (save)
- (restore)
+ (save)
+ (restore)
(push-group)
(pop-group)
(pop-group-to-source)
@@ -151,28 +151,27 @@
(define-with-default-context-sync stroke-preserve)
;;;;
-;;;; set colors using the color library
+;;;; set colors using the cl-colors library
;;;;
+
(defgeneric set-source-color (color &optional context))
(defmethod set-source-color
- ((color rgb-color) &optional (context *context*))
- (set-source-rgb
- (rgb-color-red color)
- (rgb-color-green color)
- (rgb-color-blue color)
- context))
+ ((color rgb) &optional (context *context*))
+ (with-slots (red green blue) color
+ (set-source-rgb red green blue context)))
(defmethod set-source-color
- ((color rgba-color) &optional (context *context*))
- (set-source-rgba
- (rgba-color-red color)
- (rgba-color-green color)
- (rgba-color-blue color)
- (rgba-color-alpha color)
- context))
-
+ ((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*))
+ (with-slots (red green blue) (hsv->rgb color)
+ (set-source-rgb red green blue context)))
+
;;;;
;;;; functions that get/set a property without any conversion
;;;;
Modified: package.lisp
==============================================================================
--- package.lisp (original)
+++ package.lisp Mon Aug 13 10:30:44 2007
@@ -1,5 +1,5 @@
(defpackage :cl-cairo2
- (:use :common-lisp :cffi :cl-colors)
+ (:use :common-lisp :cffi :cl-colors :cl-utilities)
(:export ; !!! when the interface
; stabilizes, remove export's
; from all other places and
@@ -10,4 +10,6 @@
*context* set-source-color
;; 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))
+ trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p
+ ;; x11-context
+ x11-context x11-display open-x11-display create-x11-context))
Modified: path.lisp
==============================================================================
--- path.lisp (original)
+++ path.lisp Mon Aug 13 10:30:44 2007
@@ -1,8 +1,8 @@
(in-package :cl-cairo2)
(define-many-with-default-context
- (new-path)
- (new-sub-path)
+ (new-path)
+ (new-sub-path)
(close-path)
(arc xc yc radius angle1 angle2)
(arc-negative xc yc radius angle1 angle2)
Modified: surface.lisp
==============================================================================
--- surface.lisp (original)
+++ surface.lisp Mon Aug 13 10:30:44 2007
@@ -45,7 +45,7 @@
(check-surface-pointer-status pointer
(setf (slot-value surface 'pointer) pointer)
;; register finalizer
- (finalize surface #'(lambda () (cairo_surface_destroy pointer)))
+;; (finalize surface #'(lambda () (cairo_surface_destroy pointer)))
;; return surface
surface)))
Modified: transformations.lisp
==============================================================================
--- transformations.lisp (original)
+++ transformations.lisp Mon Aug 13 10:30:44 2007
@@ -18,8 +18,8 @@
;;;;
(define-many-with-default-context
- (translate tx ty)
- (scale sx sy)
+ (translate tx ty)
+ (scale sx sy)
(rotate angle))
(define-flexible (reset-matrix pointer)
@@ -82,8 +82,8 @@
and copies x and y in/out before/after (respectively) the
execution of body."
`(with-foreign-objects ((xp :double) (yp :double))
- (setf (mem-ref xp :double) x
- (mem-ref yp :double) y)
+ (setf (mem-ref xp :double) (coerce x 'double-float)
+ (mem-ref yp :double) (coerce y 'double-float))
, at body
(values (mem-ref xp :double) (mem-ref yp :double))))
@@ -92,7 +92,7 @@
returns the latter two."
`(define-flexible (,name pointer x y)
(with-x-y
- (,(prepend-intern "cairo_" name) pointer xp yp))))
+ (,(prepend-intern "cairo_" name) pointer xp yp))))
;;;;
;;;; transformation and conversion functions
Modified: tutorial/tutorial.tex
==============================================================================
--- tutorial/tutorial.tex (original)
+++ tutorial/tutorial.tex Mon Aug 13 10:30:44 2007
@@ -229,7 +229,7 @@
written to PNG files) are supported.
Drawing in X11 windows is implemented using the
-\lstinline!xlib-context! class --- see Section~\ref{sec:xlib-context}
+\lstinline!x11-context! class --- see Section~\ref{sec:x11-context}
for more information.
\subsection{Contexts}
@@ -331,32 +331,42 @@
with \lstinline!trans-matrix-!, and other a few other functions have
been renamed to avoid conflicts with linear algebra packages.
-\subsection{Xlib Contexts}
-\label{sec:xlib-context}
+\subsection{X11 Contexts}
+\label{sec:x11-context}
-The xlib context is not part of cairo -- it is a bit of glue code that
+The x11 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). For the latter, it uses the XDamage
-extension.
+cairo draws on the pixmap).
-The X11 event loop runs in a separate thread, so you need a Lisp
-implementation that supports threads. The surface is not exposed to
-the user, who is only allowed to see the context. This makes memory
-management and proper cleanup easier.
-
-\textbf{Important:} before proceeding, make sure that you read
-\verb!README.xlib-context! on how to install the shared library with
-the necessary code.
+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
+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
\begin{lstlisting}
- (create-xlib-context width height)
+ (create-x11-context width height display)
\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
+implementation precludes the resizing of the window.
-Example code can be found in \verb!tutorial/xlib-example.lisp!. The
+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.
Added: tutorial/x11-example.lisp
==============================================================================
--- (empty file)
+++ tutorial/x11-example.lisp Mon Aug 13 10:30:44 2007
@@ -0,0 +1,60 @@
+(asdf:operate 'asdf:load-op :cl-cairo2)
+
+;;;; Make a test package
+(defpackage :cairo-xlib-example
+ (:use :common-lisp :cl-cairo2))
+
+(in-package :cairo-xlib-example)
+
+;; open display
+(defparameter *display* (open-x11-display ":0"))
+
+(let ((width 400)
+ (height 300))
+ (setf *context* (create-x11-context width height *display*))
+ ;; clear the whole canvas with blue
+ (rectangle 0 0 width height)
+ (set-source-rgb 0.2 0.2 0.5)
+ (fill-path)
+ ;; draw a white diagonal line
+ (move-to width 0)
+ (line-to 0 height)
+ (set-source-rgb 1 1 1)
+ (set-line-width 5)
+ (stroke)
+ ;; draw a green diagonal line
+ (move-to 0 0)
+ (line-to width height)
+ (set-source-rgb 0 1 0)
+ (set-line-width 5)
+ (stroke))
+;; need to close window manually
+
+
+(defun random-square (alpha)
+ "Draw a blue rectangle with fixed size and the given transparency alpha."
+ (move-to 1 1)
+ (line-to -1 1)
+ (line-to -1 -1)
+ (line-to 1 -1)
+ (close-path)
+ (set-source-rgba 0 0 1 alpha)
+ (fill-path))
+
+(defparameter width 800)
+(defparameter height 600)
+(defparameter max-angle 90d0)
+(setf *context* (create-x11-context width height *display*))
+;; fill with white
+(rectangle 0 0 width height)
+(set-source-rgb 1 1 1)
+(fill-path)
+;; draw the rectangles
+(dotimes (i 500)
+ (let ((scaling (+ 5d0 (random 40d0))))
+ (reset-matrix) ; reset matrix
+ (translate (random width) (random height)) ; move the origin
+ (scale scaling scaling) ; scale
+ (rotate (deg-to-rad (random max-angle))) ; rotate
+ (random-square (+ 0.1 (random 0.4)))))
+;; need to close window manually
Added: x11-context.lisp
==============================================================================
--- (empty file)
+++ x11-context.lisp Mon Aug 13 10:30:44 2007
@@ -0,0 +1,272 @@
+(in-package :cl-cairo2)
+
+
+(defconstant x11-display-destroy-message-type 29653)
+(defconstant x11-display-destroy-data0 17875817)
+
+(defvar *x11-context-count* 0 "window counter for autogenerating names")
+
+(defun next-x11-context-name ()
+ "Return an autogenerated window name using *x11-context-count*."
+ (format nil "cl-cairo2 ~a" (incf *x11-context-count*)))
+
+;; x11-display
+
+(defclass x11-context (context)
+ ((width :initarg :width)
+ (height :initarg :height)
+ (window :initarg :window :accessor window)
+ (pixmap :initarg :pixmap)
+ (graphics-context :initarg :graphics-context)
+ (x11-display
+ :initarg :x11-display
+ :documentation "refers back to the context's X11 display")))
+
+(defclass x11-display ()
+ ((display
+ :initform nil
+ :documentation "pointer to an xlib display, if nil, the display is
+closed and all other fields should be ignored")
+ (screen
+ :documentation "screen number")
+ (root)
+ (visual)
+ (depth)
+ (whitepixel)
+ (wm-delete-window
+ :documentation "atom for the WM_DELETE_WINDOW event")
+ (signal-window
+ :documentation "window used for sending signals to the event loop, unmapped")
+ (thread
+ :documentation "the thread id")
+ (x11-contexts
+ :initform nil
+ :documentation "a list of X11 contexts on this display")))
+
+
+;; 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 important code starts here. The event model is the
+;;;; following: we open an x11-display, which is attached to an Xlib
+;;;; display, and has a list of x11-contexts, which is initially
+;;;; empty. An event loop is started in a separate thread: each time
+;;;; an event arrives, it is matched to one of the windows and is
+;;;; acted upon.
+;;;;
+;;;; Each x11-context has a window where its contents appear.
+;;;;
+;;;; The window signal-window serves a special purpose. It remains
+;;;; unmapped, but allows us to send events (eg requests to terminate)
+;;;; to the event loop even if there are no x11-contexts.
+
+(defun refresh-x11-context (display x11-context)
+ "Copy the contents of the pixmap to the window."
+ (with-slots (width height window pixmap graphics-context) x11-context
+ (xcopyarea display pixmap window graphics-context
+ 0 0 width height 0 0)
+ (xsync display 1)))
+
+
+(defun open-x11-display (display-name)
+ "Open an X11 display, get the constants and start an event loop."
+ (let ((x11-display (make-instance 'x11-display)))
+ (with-slots (display screen root visual depth whitepixel wm-delete-window
+ signal-window thread x11-contexts) x11-display
+ ;; open display
+ (setf display (xopendisplay display-name))
+ (when (null-pointer-p display)
+ (error "couldn't open display ~a" display-name))
+ ;; get defaults
+ (setf screen (xdefaultscreen display)
+ root (xdefaultrootwindow display))
+ (setf visual (xdefaultvisual display screen)
+ depth (xdefaultdepth display screen)
+ whitepixel (xwhitepixel display screen))
+ ;; get WM_DELETE_WINDOW atom
+ (setf wm-delete-window
+ (xinternatom display "WM_DELETE_WINDOW" 1))
+ ;; create signal-window
+ (setf signal-window
+ ;; window is given strictly positive size
+ (xcreatesimplewindow display root 0 0 1 1 0
+ whitepixel whitepixel))
+ (xselectinput display signal-window 0)
+ ;; start threads
+ (setf thread
+ (start-thread
+ (lambda ()
+ (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) xev xanyevent)
+ (let ((x11-context (find window x11-contexts :key #'window)))
+ ;; action based on event type
+ (cond
+ ;; expose event
+ ((and (= type 12) x11-context)
+ (refresh-x11-context display x11-context))
+ ; clientnotify event
+ ((= type 33)
+ (with-foreign-slots ((message-type data0) xev
+ xclientmessageevent)
+ ;; WM_DELETE_WINDOW
+ (when (and x11-context
+ (= message-type wm-protocols)
+ (= data0 wm-delete-window))
+ (destroy x11-context))
+ ;; signal to the x11-display
+ (when (= window signal-window)
+ (xclosedisplay display)
+ (setf display nil)
+ (setf got-close-signal t)))))))))))
+ (format nil "thread for display ~a" display-name)))
+ ;; return x11-display
+ x11-display)))
+
+
+(defun close-x11-context (x11-context)
+ "Close related window and do some cleanup, except removal from
+ x11-contexts of the x11-display. This function is meant to be used
+ internally and is not exported."
+ (with-slots (x11-display window pixmap pointer) x11-context
+ (with-slots (x11-contexts display) x11-display
+ ;; we will sync all operations during destruction of the window
+ (xsynchronize display 1)
+ ;; destroy cairo context
+ (let ((saved-pointer pointer))
+ (setf pointer nil) ; invalidate first so it can't be used
+ (cairo_destroy saved-pointer))
+ ;; free pixmap
+ (xfreepixmap display pixmap)
+ (setf pixmap nil)
+ ;; destroy window
+ (xdestroywindow display window)
+ (setf window nil)
+ ;; set x11-display of context to nil
+ (setf x11-display nil))))
+
+
+(defmethod destroy ((object x11-context))
+ (with-slots (x11-contexts) (slot-value object 'x11-display)
+ ;; close
+ (close-x11-context object)
+ ;; remove from the list of windows
+ (setf x11-contexts (remove object x11-contexts))))
+
+
+(defun create-x11-context (width height x11-display
+ &optional (x11-context-name (next-x11-context-name)))
+ "Create an x11-context (a window with a context that belongs to it)
+with given dimensions and optional name. If the name is not given, it
+will be autogenerated."
+ (assert (typep x11-display 'x11-display))
+ (let ((x11-context (make-instance 'x11-context
+ :width width
+ :height height
+ :x11-display x11-display)))
+ (with-slots (pointer width height window pixmap graphics-context) x11-context
+ (with-slots (display screen root visual depth whitepixel wm-delete-window
+ x11-contexts) x11-display
+ ;; add window to list
+ (push x11-context x11-contexts)
+ ;; we will sync all operations during setup of the window
+ (xsynchronize display 1)
+ ;; create window and pixmap
+ (setf window
+ (xcreatesimplewindow display root 0 0 width height
+ 0 whitepixel whitepixel))
+ (setf pixmap
+ (xcreatepixmap display window width height depth))
+ ;; create graphics context
+ (setf graphics-context
+ (xcreategc display pixmap 0 (null-pointer)))
+ ;; window name
+ (xstorename display window x11-context-name)
+ ;; size hints (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)))
+ ;; select input
+ (xselectinput display window (logior exposuremask structurenotifymask))
+ ;; handle window closing
+ (with-foreign-object (prot 'atom)
+ (setf (mem-aref prot 'atom) wm-delete-window)
+ (xsetwmprotocols display window prot 1))
+ ;; map window
+ (xmapwindow display window)
+ ;; create xlib surface and context, destroy surface (not needed any more)
+ (let ((surface (cairo_xlib_surface_create display pixmap visual
+ width height)))
+ (setf pointer (cairo_create surface))
+ ;; !!! error checking
+ (cairo_surface_destroy surface))
+ ;; turn of synchronization
+ (xsynchronize display 0)
+ ;; return x11-context
+ x11-context))))
+
+
+(defmethod sync ((object x11-context))
+ (with-slots (x11-display) object
+ (with-slots (display) x11-display
+ (refresh-x11-context display object))))
+
+
+(defmethod destroy ((object x11-display))
+ "Close X11 display, destroying all the contexts if necessary."
+ (with-slots ((display-pointer display) signal-window x11-contexts)
+ object
+ (unless display-pointer
+ (error "This display is not open."))
+ (when x11-contexts
+ (dolist (x11-context x11-contexts)
+ (close-x11-context x11-context)
+ (setf x11-contexts nil)))
+ (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 0)
+ (xsendevent display signal-window 0 0 xev))
+ (xflush display-pointer))))
+
Added: xlib.lisp
==============================================================================
--- (empty file)
+++ xlib.lisp Mon Aug 13 10:30:44 2007
@@ -0,0 +1,319 @@
+(in-package :cl-cairo2)
+
+;;;;
+;;;; a limited interface to certain Xlib functions
+;;;;
+
+(load-foreign-library "libX11.so")
+
+;;;; types
+
+(defctype display :pointer)
+(defctype xid :unsigned-long) ; X Id type
+(defctype drawable xid)
+(defctype window xid)
+(defctype pixmap xid)
+(defctype graphics-context xid)
+(defctype visual :pointer)
+(defctype atom :unsigned-long)
+(defctype bool :int)
+
+;; constants
+
+(defmacro define-bitmask-constants (&body name-power-pairs)
+ "Define a list of constants from name-value pairs, raising 2 to
+the power value."
+ (labels ((dbc (pairs)
+ (case (length pairs)
+ (0 nil)
+ (1 (error "no power after ~a" (car name-power-pairs)))
+ (t (destructuring-bind (name power &rest rest) pairs
+ `((defconstant ,name (expt 2 ,power))
+ ,@(dbc rest)))))))
+ `(progn
+ ,@(dbc name-power-pairs))))
+
+(defconstant noeventmask 0)
+(define-bitmask-constants
+ keypressmask 0
+ keyreleasemask 1
+ buttonpressmask 2
+ buttonreleasemask 3
+ enterwindowmask 4
+ leavewindowmask 5
+ pointermotionmask 6
+ pointermotionhintmask 7
+ button1motionmask 8
+ button2motionmask 9
+ button3motionmask 10
+ button4motionmask 11
+ button5motionmask 12
+ buttonmotionmask 13
+ keymapstatemask 14
+ exposuremask 15
+ visibilitychangemask 16
+ structurenotifymask 17
+ resizeredirectmask 18
+ substructurenotifymask 19
+ substructureredirectmask 20
+ focuschangemask 21
+ propertychangemask 23
+ colormapchangemask 23
+ ownergrabbuttonmask 24)
+
+
+
+;;;; error code handling
+(defmacro check-status (call)
+ "Check the return calue of call, if nonzero, display an error message."
+ (with-unique-names (status)
+ `(let ((,status ,call))
+ (if (zerop ,status)
+ (values)
+ (error "operations ~a returned status (error) ~a" ',call ,status)))))
+
+;;;; display operations
+
+(defcfun ("XOpenDisplay" xopendisplay) display
+ (display-name :string))
+
+(defcfun ("XCloseDisplay" xclosedisplay) :int
+ (display display))
+
+
+;;;; defaults for the X11 display & screen
+
+(defcfun ("XDefaultDepth" xdefaultdepth) :int
+ (display display)
+ (screen-number :int))
+
+(defcfun ("XDefaultRootWindow" xdefaultrootwindow) window
+ (display display))
+
+(defcfun ("XDefaultScreen" xdefaultscreen) :int
+ (display display))
+
+(defcfun ("XDefaultVisual" xdefaultvisual) visual
+ (display display)
+ (screen-number :int))
+
+(defcfun ("XBlackPixel" xblackpixel) :unsigned-long
+ (display display)
+ (screen-number :int))
+
+(defcfun ("XWhitePixel" xwhitepixel) :unsigned-long
+ (display display)
+ (screen-number :int))
+
+
+;;;; graphics contexts
+
+(defcfun ("XDefaultGC" xdefaultgc) graphics-context
+ (display display)
+ (screen-number :int))
+
+(defcfun ("XCreateGC" xcreategc) graphics-context
+ (display display)
+ (drawable drawable)
+ (valuemask :unsigned-long)
+ (xgcvalues :pointer))
+
+(defcfun ("XFreeGC" xfreegc) :int
+ (display display)
+ (graphics-context graphics-context))
+
+;;;; window and pixmap management
+
+(defcfun ("XMapWindow" xmapwindow) :int
+ (display display)
+ (window window))
+
+(defcfun ("XCreateSimpleWindow" xcreatesimplewindow) window
+ (display display)
+ (parent window)
+ (x :int)
+ (y :int)
+ (width :unsigned-int)
+ (height :unsigned-int)
+ (border-width :unsigned-int)
+ (border :unsigned-long)
+ (background :unsigned-long))
+
+(defcfun ("XDestroyWindow" xdestroywindow) :int
+ (display display)
+ (window window))
+
+(defcfun ("XCreatePixmap" xcreatepixmap) pixmap
+ (display display)
+ (drawable drawable)
+ (width :unsigned-int)
+ (height :unsigned-int)
+ (depth :unsigned-int))
+
+(defcfun ("XFreePixmap" xfreepixmap) :int
+ (display display)
+ (pixmap pixmap))
+
+(defcfun ("XSelectInput" xselectinput) :int
+ (display display)
+ (window window)
+ (event-mask :long))
+
+(defcfun ("XCopyArea" xcopyarea) :int
+ (display display)
+ (source drawable)
+ (destination drawable)
+ (graphics-context graphics-context)
+ (source-x :int)
+ (source-y :int)
+ (width :unsigned-int)
+ (height :unsigned-int)
+ (destination-x :int)
+ (destination-y :int))
+
+
+;; synchronization & threads
+
+(defcfun ("XInitThreads" xinitthreads) :int)
+
+(defcfun ("XSynchronize" xsynchronize) :int
+ (display display)
+ (onoff :int))
+
+(defcfun ("XFlush" xflush) :int
+ (display display))
+
+(defcfun ("XSync" xsync) :int
+ (display display)
+ (discard :int))
+
+;; atoms & protocols
+
+(defcfun ("XInternAtom" xinternatom) atom
+ (display display)
+ (atom-name :string)
+ (only-if-exists :int))
+
+(defcfun ("XSetWMProtocols" xsetwmprotocols) :int
+ (display display)
+ (window window)
+ (protocols :pointer)
+ (count :int))
+
+
+;; events
+
+(defcstruct xanyevent
+ (type :int)
+ (serial :unsigned-long)
+ (send-event bool)
+ (display display)
+ (window window))
+
+(defcstruct xexposeevent
+ (type :int)
+ (serial :unsigned-long)
+ (send-event bool)
+ (display display)
+ (drawable drawable)
+ (x :int)
+ (y :int)
+ (width :int)
+ (height :int)
+ (count :int)
+ (major-code :int)
+ (minor-code :int))
+
+(defcstruct xdestroywindowevent
+ (type :int)
+ (serial :unsigned-long)
+ (send-event bool)
+ (display display)
+ (event window)
+ (window window))
+
+(defcstruct xclientmessageevent
+ (type :int)
+ (serial :unsigned-long)
+ (send-event bool)
+ (display display)
+ (window window)
+ (message-type atom)
+ (format :int)
+ ;; we only use first field, union of message data is not included
+ (data0 :unsigned-long))
+
+(defcfun ("XNextEvent" xnextevent) :int
+ (display display)
+ (event-return :pointer))
+
+(defcfun ("XSendEvent" xsendevent) :int
+ (display display)
+ (window window)
+ (propagate bool)
+ (event-mask :long)
+ (xevent :pointer))
+
+;; hints & misc
+
+(defcstruct xsizehints
+ (flags :long) ; marks which fields in this structure are defined
+ (x :int) ; Obsolete
+ (y :int) ; Obsolete
+ (width :int) ; Obsolete
+ (height :int) ; Obsolete
+ (min-width :int)
+ (min-height :int)
+ (max-width :int)
+ (max-height :int)
+ (min-aspect-x :int) ; numerator
+ (min-aspect-y :int) ; denominator
+ (max-aspect-x :int) ; numerator
+ (max-aspect-y :int) ; denominator
+ (base-width :int)
+ (base_height :int)
+ (win_gravity :int))
+
+(define-bitmask-constants
+ USPosition 0
+ USSize 1
+ PPosition 2
+ PSize 3
+ PMinSize 4
+ PMaxSize 5
+ PResizeInc 6
+ PAspect 7
+ PBaseSize 8
+ PWinGravity 9)
+
+(defcfun ("XAllocSizeHints" xallocsizehints) :pointer)
+
+(defcfun ("XSetWMNormalHints" xsetwmnormalhints) :void
+ (display display)
+ (window window)
+ (hints :pointer))
+
+(defcfun ("XStoreName" xstorename) :int
+ (display display)
+ (window window)
+ (window-name :string))
+
+(defcfun ("XFree" xfree) :int
+ (data :pointer))
+
+
+;; extensions
+
+(defcfun ("XAddExtension" xaddextension) :pointer
+ (display display))
+
+(defcstruct xextcodes
+ (extensions :int)
+ (major-opcode :int)
+ (first-event :int)
+ (first-error :int))
+
+
+;; call xinitthreads
+
+(xinitthreads)
More information about the Cl-cairo2-cvs
mailing list