/[cl-cairo2]/xlib-image-context.lisp
ViewVC logotype

Contents of /xlib-image-context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show annotations)
Sun Mar 23 22:58:24 2008 UTC (6 years, 1 month ago) by tpapp
File size: 7977 byte(s)
Several small changes:

- dependence on trivial-garbage for finalizer code
- fixes in examples/Makefile

1 (in-package :cl-cairo2)
2
3 ;; constants for communicating with the signal window
4 (defconstant +destroy-message+ 4072) ; just some random constant
5 (defconstant +refresh-message+ 2495) ; ditto
6
7 (defvar *xlib-image-context-count* 0 "window counter for autogenerating names")
8
9 (defun next-xlib-image-context-name ()
10 "Return an autogenerated window name using *xlib-context-count*."
11 (format nil "cl-cairo2 ~a" (incf *xlib-image-context-count*)))
12
13 ;; code to make threads, please extend with your own Lisp if needed
14 ;; testing is welcome, I only tested cmucl and sbcl
15 (defun start-thread (function name)
16 #+allegro (mp:process-run-function name function)
17 #+armedbear (ext:make-thread function :name name)
18 #+cmu (mp:make-process function :name name)
19 #+lispworks (mp:process-run-function name nil function)
20 #+openmcl (ccl:process-run-function name function)
21 #+sbcl (sb-thread:make-thread function :name name))
22
23 ;; we create this definition manually, SWIG just messes things up
24 (defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) cairo_surface_t
25 (display display)
26 (drawable drawable)
27 (visual visual)
28 (width :int)
29 (height :int))
30
31 (defclass xlib-image-context (context)
32 ((display :initarg :display)
33 window graphics-context signal-window
34 (xlib-context :accessor xlib-context)
35 wm-delete-window
36 (width :initarg :width)
37 (height :initarg :height)
38 thread
39 (sync-counter :initform 0 :accessor sync-counter)))
40
41
42 ;; synchronization after drawing
43
44 (defun send-message-to-signal-window (xlib-image-context message)
45 "Send the desired message to the context window."
46 (with-slots (pointer (display-pointer display) signal-window) xlib-image-context
47 (unless pointer
48 (warn "context is not active, can't send message to window")
49 (return-from send-message-to-signal-window))
50 (with-foreign-object (xev :long 24)
51 (with-foreign-slots
52 ((type display window message-type format data0)
53 xev xclientmessageevent)
54 (setf type 33) ; clientnotify
55 (setf display display-pointer)
56 (setf window signal-window)
57 (setf message-type 0)
58 (setf format 32)
59 (setf data0 message)
60 (xsendevent display-pointer signal-window 0 0 xev))
61 (xflush display-pointer))))
62
63 (defmethod sync ((object xlib-image-context))
64 (when (zerop (sync-counter object))
65 (send-message-to-signal-window object +refresh-message+)))
66
67 (defmethod sync-lock ((object xlib-image-context))
68 (incf (sync-counter object)))
69
70 (defmethod sync-unlock ((object xlib-image-context))
71 (with-slots (sync-counter) object
72 (when (plusp sync-counter)
73 (decf sync-counter)))
74 (sync object))
75
76 (defmethod sync-reset ((object xlib-image-context))
77 (setf (sync-counter object) 0)
78 (sync object))
79
80 (defun create-xlib-image-context (width height &key
81 (display-name nil)
82 (window-name (next-xlib-image-context-name))
83 (background-color +white+))
84 "Create a window mapped to an xlib-image-context, with given width,
85 height (non-resizable) and window-name on display-name. If
86 background-color is not nil, the window will be painted with it."
87 (let ((display (xopendisplay (if display-name display-name (null-pointer)))))
88 (when (null-pointer-p display)
89 (error "couldn't open display ~a" display-name))
90 (let ((xlib-image-context (make-instance 'xlib-image-context
91 :display display
92 :width width
93 :height height
94 :pixel-based-p t)))
95 (labels (;; Repaint the xlib context with the image surface
96 ;; (previously set as source during initialization.
97 (refresh ()
98 (cairo_paint (xlib-context xlib-image-context)))
99 ;; The main event loop, started as a separate thread
100 ;; when initialization is complete. The main thread is
101 ;; supposed to communicate with this one via X signals
102 ;; using an unmapped InputOnly window (see
103 ;; send-message-to-signal-window).
104 (event-loop ()
105 (with-slots (display (this-window window) signal-window
106 wm-delete-window graphics-context)
107 xlib-image-context
108 (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1)))
109 (with-foreign-object (xev :long 24)
110 (do ((got-close-signal nil))
111 (got-close-signal)
112 ;; get next event
113 (xnextevent display xev)
114 ;; decipher structure, at least partially
115 (with-foreign-slots ((type window serial) xev xanyevent)
116 ;; action based on event type
117 (cond
118 ;; expose events
119 ((and (= type 12) (= window this-window))
120 (refresh))
121 ;; clientnotify event
122 ((= type 33)
123 (with-foreign-slots ((message-type data0) xev
124 xclientmessageevent)
125 (cond
126 ((or (and (= window signal-window)
127 (= data0 +destroy-message+))
128 (and (= window this-window)
129 (= message-type wm-protocols)
130 (= data0 wm-delete-window)))
131 (setf got-close-signal t))
132 ((and (= window signal-window)
133 (= data0 +refresh-message+))
134 (refresh)))))))))))
135 ;; close down everything
136 (with-slots (display pixmap window signal-window pointer
137 xlib-context)
138 xlib-image-context
139 (xsynchronize display 1)
140 (let ((saved-pointer pointer))
141 (setf pointer nil) ; invalidate first so it can't be used
142 (cairo_destroy saved-pointer))
143 (cairo_destroy xlib-context)
144 ;; !! free xlib-context, surface
145 (xdestroywindow display window)
146 (xdestroywindow display signal-window)
147 (xclosedisplay display))))
148 ;; initialize
149 (xsynchronize display 1)
150 (let* ((screen (xdefaultscreen display))
151 (root (xdefaultrootwindow display))
152 (visual (xdefaultvisual display screen))
153 (whitepixel (xwhitepixel display screen)))
154 (with-slots (window signal-window thread wm-delete-window
155 pointer graphics-context xlib-context)
156 xlib-image-context
157 ;; create signal window and window
158 (setf window
159 (create-window display root width height 'inputoutput visual
160 whitepixel
161 (logior exposuremask
162 structurenotifymask)
163 t))
164 (setf signal-window
165 (create-window display root 1 1 'inputonly visual
166 whitepixel 0 nil))
167 ;; create graphics-context
168 (setf graphics-context
169 (xcreategc display window 0 (null-pointer)))
170 ;; set size hints on window (most window managers will respect this)
171 (set-window-size-hints display window width width height height)
172 ;; intern atom for window closing, set protocol on window
173 (setf wm-delete-window
174 (xinternatom display "WM_DELETE_WINDOW" 1))
175 (with-foreign-object (prot 'xatom)
176 (setf (mem-aref prot 'xatom) wm-delete-window)
177 (xsetwmprotocols display window prot 1))
178 ;; store name
179 (xstorename display window window-name)
180 ;; first we create an X11 surface and context on the window
181 (let ((xlib-surface (cairo_xlib_surface_create display window visual
182 width height)))
183 (setf xlib-context (cairo_create xlib-surface))
184 (cairo_surface_destroy xlib-surface))
185 ;; create cairo surface, then context, then set the
186 ;; surface as the source of the xlib-context
187 (let ((surface (cairo_image_surface_create :CAIRO_FORMAT_RGB24
188 width height)))
189 (setf pointer (cairo_create surface))
190 (cairo_set_source_surface xlib-context surface 0 0)
191 (cairo_surface_destroy surface))
192 ;; map window
193 (xmapwindow display window)
194 ;; end of synchronizing
195 (xsynchronize display 0)
196 ;; start thread
197 (setf thread
198 (start-thread
199 #'event-loop
200 (format nil "thread for display ~a" display-name))))))
201 ;; paint it if we are given a background color
202 (when background-color
203 (set-source-color background-color xlib-image-context)
204 (paint xlib-image-context)
205 (sync xlib-image-context))
206 ;; return context
207 xlib-image-context)))
208
209
210 (defmethod destroy ((object xlib-image-context))
211 (send-message-to-signal-window object +destroy-message+))
212

  ViewVC Help
Powered by ViewVC 1.1.5