cl-cairo2-cvs

Download

cl-cairo2-cvs@common-lisp.net

December 2007

1 participants
2 discussions

[cl-cairo2-cvs] r16 - tutorial
by tpapp＠common-lisp.net 20 Dec '07

20 Dec '07

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(a)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))

1 0

[cl-cairo2-cvs] r15 - tutorial
by tpapp＠common-lisp.net 20 Dec '07

20 Dec '07

Author: tpapp Date: Thu Dec 20 08:05:07 2007 New Revision: 15 Modified: cl-cairo2.asd context.lisp package.lisp tutorial/example.lisp xlib-context.lisp xlib.lisp Log: reorganization, bugfixes Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Thu Dec 20 08:05:07 2007 @@ -13,9 +13,9 @@ (:file "text" :depends-on ("context")) (:file "transformations" :depends-on ("context")) (:file "xlib" :depends-on ("context") - :in-order-to ((load-op (feature :unix)) - (compile-op (feature :unix)))) - (:file "xlib-context" :depends-on ("xlib") - :in-order-to ((load-op (feature :unix)) - (compile-op (feature :unix))))) + :in-order-to ((load-op (feature :unix)) + (compile-op (feature :unix)))) + (:file "xlib-image-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 Thu Dec 20 08:05:07 2007 @@ -172,6 +172,14 @@ (define-with-default-context-sync stroke) (define-with-default-context-sync stroke-preserve) +;;;; get-target + +(defun get-target (context) + "Obtain the target surface of a given context. Width and height +will be nil, as cairo can't provide that in general." + (new-surface-with-check (cairo_get_target (slot-value context 'pointer)) + nil nil)) + ;;;; ;;;; set colors using the cl-colors library ;;;; @@ -184,7 +192,7 @@ (defmethod set-source-color ((color rgba) &optional (context *context*)) (with-slots (red green blue alpha) color - (set-source-rgb red green blue alpha context))) + (set-source-rgba red green blue alpha context))) (defmethod set-source-color ((color hsv) &optional (context *context*)) (with-slots (red green blue) (hsv->rgb color) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Thu Dec 20 08:05:07 2007 @@ -8,10 +8,10 @@ ;; 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 + 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 ;; context @@ -25,7 +25,7 @@ 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 + create-svg-context get-target ;; path @@ -49,6 +49,6 @@ trans-matrix-rotate trans-matrix-invert trans-matrix-multiply trans-matrix-distance transform-point - ;; xlib-context + ;; xlib-image-context - xlib-context xlib-display open-xlib-display create-xlib-context)) + xlib-image-context create-xlib-image-context)) Modified: tutorial/example.lisp ============================================================================== --- tutorial/example.lisp (original) +++ tutorial/example.lisp Thu Dec 20 08:05:07 2007 @@ -14,9 +14,8 @@ (setf *context* (create-context *surface*)) (destroy *surface*) ;; clear the whole canvas with blue -(rectangle 0 0 200 100) (set-source-rgb 0.2 0.2 1) -(fill-path) +(paint) ;; draw a white diagonal line (move-to 200 0) (line-to 0 100) @@ -49,11 +48,7 @@ (defun mark-at (x y d red green blue) "Make a rectangle of size 2d around x y with the given colors, 50% alpha. Used for marking points." - (move-to (+ x d) (+ y d)) - (line-to (- x d) (+ y d)) - (line-to (- x d) (- y d)) - (line-to (+ x d) (- y d)) - (close-path) + (rectangle (- x d) (- y d) (* 2 d) (* 2 d)) (set-source-rgba red green blue 0.5) (fill-path)) @@ -71,9 +66,8 @@ (defparameter y 50) (setf *context* (create-ps-context "text.ps" width height)) ;; white background -(rectangle 0 0 width height) (set-source-rgb 1 1 1) -(fill-path) +(paint) ;; setup font (select-font-face "Arial" 'font-slant-normal 'font-weight-normal) (set-font-size size) Modified: xlib-context.lisp ============================================================================== --- xlib-context.lisp (original) +++ xlib-context.lisp Thu Dec 20 08:05:07 2007 @@ -51,31 +51,6 @@ 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))) @@ -101,7 +76,7 @@ (with-foreign-slots ((type window serial) xev xanyevent) ;; action based on event type (cond - ;; expose and configurenotify events + ;; expose events ((and (= type 12) (= window this-window)) (refresh-xlib-context xlib-context)) ;; clientnotify event @@ -121,14 +96,16 @@ ;; close down everything (with-slots (display pixmap window signal-window pointer) xlib-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 saved-pointer) + ) (xfreepixmap display pixmap) (xdestroywindow display window) - (xdestroywindow display signal-window) - (xclosedisplay display)))) - ;; initialize + (xdestroywindow display signal-window) + (xclosedisplay display)))) + ;; initialize (xsynchronize display 1) (let* ((screen (xdefaultscreen display)) (root (xdefaultrootwindow display)) @@ -201,7 +178,10 @@ (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-slots (pointer (display-pointer display) signal-window) xlib-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) @@ -213,8 +193,7 @@ (setf format 32) (setf data0 message) (xsendevent display-pointer signal-window 0 0 xev)) - (xflush display-pointer)))) - + (xsync display-pointer 1)))) (defmethod destroy ((object xlib-context)) (send-message-to-signal-window object +destroy-message+)) Modified: xlib.lisp ============================================================================== --- xlib.lisp (original) +++ xlib.lisp Thu Dec 20 08:05:07 2007 @@ -387,7 +387,102 @@ (first-event :int) (first-error :int)) +;; image manipulation + +(cffi:defcstruct XImage + (width :int) + (height :int) + (xoffset :int) + (format :int) + (data :pointer) + (byte-order :int) + (bitmap-unit :int) + (bitmap-bit-order :int) + (bitmap-pad :int) + (depth :int) + (bytes-per-line :int) + (bits-per-pixel :int) + (red-mask :unsigned-long) + (green-mask :unsigned-long) + (blue-mask :unsigned-long) + (obdata :pointer) + ;; funcs + (create-image :pointer) + (destroy-image :pointer) + (get-pixel :pointer) + (put-pixel :pointer) + (sub-image :pointer) + (add-pixel :pointer)) + +(defcfun ("XInitImage" xinitimage) :int + (ximage :pointer)) + +(defcfun ("XPutImage" xputimage) :int + (display display) + (drawable drawable) + (graphics-context graphics-context) + (ximage :pointer) + (src-x :int) + (src-y :int) + (dest-x :int) + (dest-y :int) + (width :unsigned-int) + (height :unsigned-int)) ;; call xinitthreads (xinitthreads) + + +;; various higher level functions + +(defun set-window-size-hints (display window + min-window-width max-window-width + min-window-height max-window-height) + ;; 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 + ;; we don't need to set the following, but some WMs go + ;; crazy if we don't + (foreign-slot-value hints 'xsizehints 'width) max-window-width + (foreign-slot-value hints 'xsizehints 'height) max-window-height + ;; set desired min/max width/height + min-width min-window-width + max-width max-window-width + min-height min-window-height + max-height max-window-height) + (xsetwmnormalhints display window hints) + (xfree hints)))) + +(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)))

1 0