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

Contents of /xlib-image-context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

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

1 tpapp 16 (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 tpapp 17
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 tpapp 16 (defun create-xlib-image-context (width height &key
81     (display-name nil)
82 tpapp 17 (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 tpapp 16 (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 tpapp 17 :height height
94     :pixel-based-p t)))
95 tpapp 16 (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 tpapp 17 (with-foreign-object (prot 'xatom)
176     (setf (mem-aref prot 'xatom) wm-delete-window)
177 tpapp 16 (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 tpapp 17 ;; 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 tpapp 16 ;; 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