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@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) + ,@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))