[cl-cairo2-cvs] r16 - tutorial
tpapp at common-lisp.net
tpapp at common-lisp.net
Thu Dec 20 13:17:51 UTC 2007
Author: tpapp
Date: Thu Dec 20 08:17:49 2007
New Revision: 16
Added:
gtk-context.lisp
tutorial/test-xlib.lisp
tutorial/xlib-image-context-test.lisp
xlib-image-context.lisp
Modified:
cl-cairo2.asd
package.lisp
Log:
added gtk-context, contributed by Peter Hildebrandt
Modified: cl-cairo2.asd
==============================================================================
--- cl-cairo2.asd (original)
+++ cl-cairo2.asd Thu Dec 20 08:17:49 2007
@@ -1,3 +1,8 @@
+(defpackage #:cl-cairo2-asd
+ (:use :cl :asdf))
+
+(in-package :cl-cairo2-asd)
+
(defsystem cl-cairo2
:description "Cairo 1.4 bindings"
:version "0.3"
@@ -17,5 +22,8 @@
(compile-op (feature :unix))))
(:file "xlib-image-context" :depends-on ("xlib")
:in-order-to ((load-op (feature :unix))
+ (compile-op (feature :unix))))
+ (:file "gtk-context" :depends-on ("context")
+ :in-order-to ((load-op (feature :unix))
(compile-op (feature :unix)))))
:depends-on (:cffi :cl-colors :cl-utilities))
Added: gtk-context.lisp
==============================================================================
--- (empty file)
+++ gtk-context.lisp Thu Dec 20 08:17:49 2007
@@ -0,0 +1,40 @@
+(in-package :cl-cairo2)
+
+
+;; library functions to create a gdk-surface
+;; written by Peter Hildebrandt <peter.hildebrandt at washbear-network.de>
+
+(define-foreign-library :gdk
+ (cffi-features:unix "libgdk-x11-2.0.so")
+ (cffi-features:windows "libgdk-win32-2.0-0.dll")
+ (cffi-features:darwin "libgdk-win32-2.0-0.dylib"))
+
+(load-foreign-library :gdk)
+(defcfun ("gdk_cairo_create" gdk-cairo-create) :pointer (window :pointer))
+
+(defclass gtk-context (context)
+ ())
+
+(defun create-gtk-context (gdk-window)
+ "creates an context to draw on a GTK widget, more precisely on the
+associated gdk-window. This should only be called from within the
+expose event. In cells-gtk, use (gtk-adds-widget-window gtk-pointer)
+to obtain the gdk-window. 'gtk-pointer' is the pointer parameter
+passed to the expose event handler."
+ (make-instance 'gtk-context
+ :pointer (gdk-cairo-create gdk-window)))
+
+(defmethod destroy ((self gtk-context))
+ (cairo_destroy (slot-value self 'pointer)))
+
+(defmacro with-gtk-context ((context gdk-window) &body body)
+ "Executes body while context is bound to a valid cairo context for
+gdk-window. This should only be called from within an expose event
+handler. In cells-gtk, use (gtk-adds-widget-window gtk-pointer) to
+obtain the gdk-window. 'gtk-pointer' is the pointer parameter passed
+to the expose event handler."
+ (with-gensyms (context-pointer)
+ `(let ((,context (create-gtk-context ,gdk-window)))
+ (with-context (,context ,context-pointer)
+ , at body)
+ (destroy ,context))))
Modified: package.lisp
==============================================================================
--- package.lisp (original)
+++ package.lisp Thu Dec 20 08:17:49 2007
@@ -1,54 +1,58 @@
(defpackage :cl-cairo2
- (:use :common-lisp :cffi :cl-colors :cl-utilities)
- (:export
+ (:use :common-lisp :cffi :cl-colors :cl-utilities)
+ (:export
- ;; cairo
+ ;; cairo
- destroy deg-to-rad
+ destroy deg-to-rad
- ;; surface
-
- get-width get-height destroy create-ps-surface create-pdf-surface
- create-svg-surface 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
+ ;; surface
- ;; context
+ get-width get-height destroy create-ps-surface create-pdf-surface
+ create-svg-surface 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
- create-context sync sync-lock sync sync-unlock sync-reset
- with-sync-lock *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 get-target
-
- ;; 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
+ ;; context
+
+ create-context sync sync-lock sync sync-unlock sync-reset
+ with-sync-lock *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 get-target
+
+ ;; 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
+
+ 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
- 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-image-context
- ;; xlib-image-context
+ xlib-image-context create-xlib-image-context
- xlib-image-context create-xlib-image-context))
+ ;; gtk-context
+
+ gtk-context create-gtk-context with-gtk-context))
Added: tutorial/test-xlib.lisp
==============================================================================
--- (empty file)
+++ tutorial/test-xlib.lisp Thu Dec 20 08:17:49 2007
@@ -0,0 +1,51 @@
+(in-package :cl-cairo2)
+
+(defun random-size ()
+ (+ 200 (random 100)))
+(defparameter *list-of-contexts* nil)
+(defparameter *max-number-of-contexts* 50)
+
+(defun x-on-window (context)
+ (let ((width (get-width context))
+ (height (get-height context)))
+ ;; clear
+ (rectangle 0 0 width height context)
+ (set-source-color +white+ context)
+ (fill-path context)
+ ;; draw X
+ (move-to 0 0 context)
+ (line-to width height context)
+ (set-source-color +green+ context)
+ (stroke context)
+ (move-to 0 height context)
+ (line-to width 0 context)
+ (set-source-color +blue+ context)
+ (stroke context)))
+
+(defun remove-random-window (list)
+ (assert (not (null list)))
+ (let* ((length (length list))
+ (index (random length))
+ (context (nth index list)))
+ (format t "killing ~a~%" index)
+ (destroy context)
+ (remove context list)))
+
+;; create contexts with an x on them
+(dotimes (i *max-number-of-contexts*)
+ (let ((context (create-xlib-image-context (random-size) (random-size))))
+ (x-on-window context)
+ (push context *list-of-contexts*)))
+
+;; close all, in random order
+(do ()
+ ((not *list-of-contexts*))
+ (setf *list-of-contexts* (remove-random-window *list-of-contexts*)))
+
+
+(defparameter *c1* (create-xlib-context 100 100))
+(x-on-window *c1*)
+(defparameter *c2* (create-xlib-context 140 200))
+(x-on-window *c2*)
+
+(destroy *c1*)
Added: tutorial/xlib-image-context-test.lisp
==============================================================================
--- (empty file)
+++ tutorial/xlib-image-context-test.lisp Thu Dec 20 08:17:49 2007
@@ -0,0 +1,27 @@
+(in-package :cl-cairo2)
+
+(setf *context* (create-xlib-image-context 400 200 :display-name ":0"))
+(move-to 0 0)
+(line-to 400 200)
+(set-source-color +green+)
+(stroke)
+
+(let* ((display (slot-value *context* 'display))
+ (screen (xdefaultscreen display))
+ (depth (xdefaultdepth display screen)))
+ depth)
+
+(with-foreign-slots ((width height format data
+ byte-order bitmap-unit
+ bitmap-bit-order bitmap-pad
+ depth bytes-per-line
+ bits-per-pixel red-mask
+ green-mask blue-mask
+ xoffset) (slot-value *context* 'ximage) ximage)
+ (values width height format data
+ byte-order bitmap-unit
+ bitmap-bit-order bitmap-pad
+ depth bytes-per-line
+ bits-per-pixel red-mask
+ green-mask blue-mask
+ xoffset))
Added: xlib-image-context.lisp
==============================================================================
--- (empty file)
+++ xlib-image-context.lisp Thu Dec 20 08:17:49 2007
@@ -0,0 +1,197 @@
+(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-image-context-count* 0 "window counter for autogenerating names")
+
+(defun next-xlib-image-context-name ()
+ "Return an autogenerated window name using *xlib-context-count*."
+ (format nil "cl-cairo2 ~a" (incf *xlib-image-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))
+
+(defclass xlib-image-context (context)
+ ((display :initarg :display)
+ window graphics-context signal-window
+ (xlib-context :accessor xlib-context)
+ wm-delete-window
+ (width :initarg :width)
+ (height :initarg :height)
+ thread
+ (sync-counter :initform 0 :accessor sync-counter)))
+
+(defun create-xlib-image-context (width height &key
+ (display-name nil)
+ (window-name (next-xlib-image-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-image-context (make-instance 'xlib-image-context
+ :display display
+ :width width
+ :height height)))
+ (labels (;; Repaint the xlib context with the image surface
+ ;; (previously set as source during initialization.
+ (refresh ()
+ (cairo_paint (xlib-context xlib-image-context)))
+ ;; The main event loop, started as a separate thread
+ ;; when initialization is complete. The main thread is
+ ;; supposed to communicate with this one via X signals
+ ;; using an unmapped InputOnly window (see
+ ;; send-message-to-signal-window).
+ (event-loop ()
+ (with-slots (display (this-window window) signal-window
+ wm-delete-window graphics-context)
+ xlib-image-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 events
+ ((and (= type 12) (= window this-window))
+ (refresh))
+ ;; 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)))))))))))
+ ;; close down everything
+ (with-slots (display pixmap window signal-window pointer
+ xlib-context)
+ xlib-image-context
+ (xsynchronize display 1)
+ (let ((saved-pointer pointer))
+ (setf pointer nil) ; invalidate first so it can't be used
+ (cairo_destroy saved-pointer))
+ (cairo_destroy xlib-context)
+ ;; !! free xlib-context, surface
+ (xdestroywindow display window)
+ (xdestroywindow display signal-window)
+ (xclosedisplay display))))
+ ;; initialize
+ (xsynchronize display 1)
+ (let* ((screen (xdefaultscreen display))
+ (root (xdefaultrootwindow display))
+ (visual (xdefaultvisual display screen))
+ (whitepixel (xwhitepixel display screen)))
+ (with-slots (window signal-window thread wm-delete-window
+ pointer graphics-context xlib-context)
+ xlib-image-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 graphics-context
+ (setf graphics-context
+ (xcreategc display window 0 (null-pointer)))
+ ;; set size hints on window (most window managers will respect this)
+ (set-window-size-hints display window width width height height)
+ ;; 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)
+ ;; first we create an X11 surface and context on the window
+ (let ((xlib-surface (cairo_xlib_surface_create display window visual
+ width height)))
+ (setf xlib-context (cairo_create xlib-surface))
+ (cairo_surface_destroy xlib-surface))
+ ;; create cairo surface, then context, then set the
+ ;; surface as the source of the xlib-context
+ (let ((surface (cairo_image_surface_create :CAIRO_FORMAT_RGB24
+ width height)))
+ (setf pointer (cairo_create surface))
+ (cairo_set_source_surface xlib-context surface 0 0)
+ (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-image-context)))
+
+(defun send-message-to-signal-window (xlib-image-context message)
+ "Send the desired message to the context window."
+ (with-slots (pointer (display-pointer display) signal-window) xlib-image-context
+ (unless pointer
+ (warn "context is not active, can't send message to window")
+ (return-from send-message-to-signal-window))
+ (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-image-context))
+ (send-message-to-signal-window object +destroy-message+))
+
+(defmethod sync ((object xlib-image-context))
+ (when (zerop (sync-counter object))
+ (send-message-to-signal-window object +refresh-message+)))
+
+(defmethod sync-lock ((object xlib-image-context))
+ (incf (sync-counter object)))
+
+(defmethod sync-unlock ((object xlib-image-context))
+ (with-slots (sync-counter) object
+ (when (plusp sync-counter)
+ (decf sync-counter)))
+ (sync object))
+
+(defmethod sync-reset ((object xlib-image-context))
+ (setf (sync-counter object) 0)
+ (sync object))
More information about the Cl-cairo2-cvs
mailing list