source: project/gl-display-glx/gl-display-glx.scm @ 3732

Last change on this file since 3732 was 3732, checked in by thu, 13 years ago


File size: 8.5 KB
Line 
1;;; gl-display-glx.scm
2;;
3;; 07.01.2007 - 08.02.2007
4;; 
5;; Ce fichier peut etre compile en .so avec
6;; csc -s gl-display-glx.scm glx_display.c -I/usr/include/X11 -L/usr/X11R6/lib -L/usr/lib -lGL -lm
7;; Ensuite, le .so peut etre charger avec
8;; (require-extension gl-dislpay-glx).
9;;
10
11;; TODO color-args : prend un ou trois argument et les transforme en trois argument selon RGB, HSV,...
12;; dans un autre fichier...
13
14;
15
16;(require-for-syntax 'srfi-13)
17
18(declare
19  (export
20    gl-display:create
21    gl-display:destroy
22    gl-display:swap
23    gl-display:time
24    gl-display:receive-event
25    gl-display:event-type
26    gl-display:event-x
27    gl-display:event-y
28    gl-display:event-dx
29    gl-display:event-dy
30    gl-display:event-time
31    gl-display:event-keycode
32    gl-display:event-keysym
33    gl-display:width
34    gl-display:height
35    gl-display:screen-width
36    gl-display:screen-height
37    gl-display:enable-autorepeat
38    gl-display:disable-autorepeat
39    gl-display:disable-cursor
40    gl-display:enable-centered-cursor
41    gl-display:disable-centered-cursor
42    gl-display:enable-cycling-cursor
43    gl-display:disable-cycling-cursor
44    )
45  )
46
47(use gl)
48(use syntax-case)
49(use utf8)
50(import utf8)
51
52; xlib events
53
54#>
55#include "glx_display.h"
56#include <X.h>
57#include <keysym.h>
58<#
59
60
61(define-foreign-enum (keycode_t (enum "keycode_t"))
62  K_BACKSPACE
63  K_TAB
64  K_ENTER
65  K_ESCAPE
66
67  K_SPACE
68  K_EXCLAM
69  K_DOUBLE_QUOTE
70  K_NUMBER_SIGNE
71  K_DOLLAR
72  K_PERCENT
73  K_AMPERSAND
74  K_APOSTROPHE
75  K_LEFT_PAREN
76  K_RIGHT_PAREN
77  K_ASTERISK
78  K_PLUS
79  K_COMMA
80  K_MINUS
81  K_PERIOD
82  K_SLASH
83  K_0
84  K_1
85  K_2
86  K_3
87  K_4
88  K_5
89  K_6
90  K_7
91  K_8
92  K_9
93  K_COLON
94  K_SEMICOLON
95  K_LESS
96  K_EQUAL
97  K_GREATER
98  K_QUESTION
99  K_AT
100  K_A
101  K_B
102  K_C
103  K_D
104  K_E
105  K_F
106  K_G
107  K_H
108  K_I
109  K_J
110  K_K
111  K_L
112  K_M
113  K_N
114  K_O
115  K_P
116  K_Q
117  K_R
118  K_S
119  K_T
120  K_U
121  K_V
122  K_W
123  K_X
124  K_Y
125  K_Z
126  K_LEFT_BRACKET
127  K_BACKSLASH
128  K_RIGHT_BRACKET
129  K_ASCII_CIRCUM
130  K_UNDERSCORE
131  K_GRAVE
132  K_a
133  K_b
134  K_c
135  K_d
136  K_e
137  K_f
138  K_g
139  K_h
140  K_i
141  K_j
142  K_k
143  K_l
144  K_m
145  K_n
146  K_o
147  K_p
148  K_q
149  K_r
150  K_s
151  K_t
152  K_u
153  K_v
154  K_w
155  K_x
156  K_y
157  K_z
158  K_LEFT_BRACE
159  K_BAR
160  K_RIGHT_BRACE
161  K_ASCII_TILDE
162
163  K_COMMAND
164  K_CAPSLOCK
165  K_POWER
166  K_PAUSE
167
168  K_UP_ARROW
169  K_DOWN_ARROW
170  K_LEFT_ARROW
171  K_RIGHT_ARROW
172
173  K_LEFT_ALT
174  K_RIGHT_ALT
175  K_LEFT_CONTROL
176  K_RIGHT_CONTROL
177  K_LEFT_SHIFT
178  K_RIGHT_SHIFT
179  K_INSERT
180  K_DELETE
181  K_PAGE_DOWN
182  K_PAGE_UP
183  K_HOME
184  K_END
185
186  K_F1
187  K_F2
188  K_F3
189  K_F4
190  K_F5
191  K_F6
192  K_F7
193  K_F8
194  K_F9
195  K_F10
196  K_F11
197  K_F12
198  K_F13
199  K_F14
200  K_F15
201
202  K_KP_HOME
203  K_KP_UP_ARROW
204  K_KP_PAGE_UP
205  K_KP_LEFT_ARROW
206  K_KP_5
207  K_KP_RIGHT_ARROW
208  K_KP_END
209  K_KP_DOWN_ARROW
210  K_KP_PAGE_DOWN
211  K_KP_ENTER
212  K_KP_INSERT
213  K_KP_DELETE
214  K_KP_SLASH
215  K_KP_MINUS
216  K_KP_PLUS
217  K_KP_NUMLOCK
218  K_KP_STAR
219  K_KP_EQUALS
220
221  K_MOUSE1
222  K_MOUSE2
223  K_MOUSE3
224  K_MOUSE4
225  K_MOUSE5
226
227  K_WHEEL_DOWN
228  K_WHEEL_UP
229
230  K_LAST_KEY
231)
232
233; don't export this
234
235
236(define KEY-PRESSED     (foreign-value "KeyPress"      int))
237(define KEY-RELEASED    (foreign-value "KeyRelease"    int))
238(define BUTTON-PRESSED  (foreign-value "ButtonPress"   int))
239(define BUTTON-RELEASED (foreign-value "ButtonRelease" int))
240(define MOUSE-MOVED     (foreign-value "MotionNotify"  int))
241(define LAST-EVENT      (foreign-value "LASTEvent"     int))
242
243; FIXME is it safe ? Can other apps register new event numbers ?
244(define NO-EVENT        (+ LAST-EVENT 1))
245
246;(define ESCAPE-KEY    (foreign-value "XK_Escape" int))
247;(define RETURN-KEY    (foreign-value "XK_Return" int))
248;(define BACKSPACE-KEY (foreign-value "XK_BackSpace" int))
249
250;(define UP-KEY     (foreign-value "XK_Up"     int))
251;(define DOWN-KEY   (foreign-value "XK_Down"   int))
252;(define LEFT-KEY   (foreign-value "XK_Left"   int))
253;(define RIGHT-KEY  (foreign-value "XK_Right"  int))
254
255(define LEFT-MOUSE-BUTTON  (foreign-value "Button1"    int))
256(define RIGHT-MOUSE-BUTTON (foreign-value "Button3"    int))
257
258;
259
260(define x-event-type
261  (foreign-lambda int "event_type" c-pointer))
262(define x-event-x
263  (foreign-lambda int "event_x" c-pointer))
264(define x-event-y
265  (foreign-lambda int "event_y" c-pointer))
266(define x-event-dx
267  (foreign-lambda int "event_dx" c-pointer))
268(define x-event-dy
269  (foreign-lambda int "event_dy" c-pointer))
270
271(define x-event-keycode
272  (foreign-lambda keycode_t "event_keycode" c-pointer))
273(define x-event-keysym
274  (foreign-lambda unsigned-int "event_keysym" c-pointer))
275
276;(define (x-event-key event)
277;  (define event-xkeycode
278;    (foreign-lambda int "event_xkeycode" c-pointer))
279;  (let ((k (event-xkeycode event)))
280;    (cond ((eq? k ESCAPE-KEY) #\esc)
281;         ((eq? k RETURN-KEY) #\return)
282;         ((eq? k BACKSPACE-KEY) #\backspace)
283;         ((eq? k UP-KEY)     'UP-KEY)
284;         ((eq? k DOWN-KEY)   'DOWN-KEY)
285;         ((eq? k LEFT-KEY)   'LEFT-KEY)
286;         ((eq? k RIGHT-KEY)  'RIGHT-KEY)
287;         (else (integer->char k)))))
288
289; TODO x-event-char for unicode character instead of keycode.
290
291(define (x-event-button event)
292  (define event-button
293    (foreign-lambda int "event_button" c-pointer))
294  (let ((b (event-button event)))
295    (cond ((eq? b LEFT-MOUSE-BUTTON) 'LMB)
296          ((eq? b RIGHT-MOUSE-BUTTON) 'RMB)
297          (else 'MMB))))
298
299(define (keysym->char i)
300  (integer->char i))
301
302; returns an event from xlib
303(define (gl-display:receive-event window)
304  (define receive
305    (foreign-lambda c-pointer "receive_event" c-pointer))
306  (let* ((e (receive window))
307         (type (x-event-type e))
308         (time (gl-display:time)))
309    (cond ((eq? type KEY-PRESSED)     (list 'KEY-PRESSED time (x-event-keycode e) (keysym->char (x-event-keysym e))))
310          ((eq? type KEY-RELEASED)    (list 'KEY-RELEASED time (x-event-keycode e) (keysym->char (x-event-keysym e))))
311          ((eq? type BUTTON-PRESSED)  (list 'BUTTON-PRESSED time (x-event-button e) (x-event-x e) (x-event-y e)))
312          ((eq? type BUTTON-RELEASED) (list 'BUTTON-RELEASED time (x-event-button e) (x-event-x e) (x-event-y e)))
313          ((eq? type MOUSE-MOVED)     (list 'MOUSE-MOVED time 'dummy
314                                            (x-event-x e) (x-event-y e) (x-event-dx window) (x-event-dy window)))
315          ((eq? type NO-EVENT)        (list 'NO-EVENT))
316          (else                       (gl-display:receive-event window))))) ; pump and discard all other events
317
318(define (gl-display:event-type event)
319  (car event))
320
321(define (gl-display:event-x event)
322  (fourth event))
323(define (gl-display:event-y event)
324  (fifth event))
325(define (gl-display:event-dx event)
326  (sixth event))
327(define (gl-display:event-dy event)
328  (seventh event))
329
330(define (gl-display:event-time event)
331  (cadr event))
332
333(define (gl-display:event-keycode event)
334  (caddr event))
335
336(define (gl-display:event-keysym event)
337  (cadddr event))
338
339;
340(define gl-display:disable-cursor
341  (foreign-lambda void "disable_cursor" c-pointer))
342
343; puts the back-buffer content into the front-buffer.
344(define gl-display:swap
345  (foreign-lambda void "swap_buffers" c-pointer))
346
347(define gl-display:width
348  (foreign-lambda unsigned-int "get_width" c-pointer))
349(define gl-display:height
350  (foreign-lambda unsigned-int "get_height" c-pointer))
351(define gl-display:screen-width
352  (foreign-lambda unsigned-int "get_screen_width" c-pointer))
353(define gl-display:screen-height
354  (foreign-lambda unsigned-int "get_screen_height" c-pointer))
355
356(define gl-display:enable-autorepeat
357  (foreign-lambda void "enable_autorepeat" c-pointer))
358(define gl-display:disable-autorepeat
359  (foreign-lambda void "disable_autorepeat" c-pointer))
360(define gl-display:enable-centered-cursor
361  (foreign-lambda void "enable_centered_cursor" c-pointer))
362(define gl-display:disable-centered-cursor
363  (foreign-lambda void "disable_centered_cursor" c-pointer))
364(define gl-display:enable-cycling-cursor
365  (foreign-lambda void "enable_cycling_cursor" c-pointer))
366(define gl-display:disable-cycling-cursor
367  (foreign-lambda void "disable_cycling_cursor" c-pointer))
368
369; An optional list of properties can be provided.
370; The supported properties are:
371; - single-buffered
372; - centered
373; - full-screen
374; - no-border
375; - shaped
376; FIXME it crashes when no arg is given after a 'width...
377; is it ok ?
378(define (gl-display:create . properties)
379  (define create-display
380    (foreign-lambda c-pointer "create_gl_window" unsigned-int unsigned-int int int int int))
381 
382  (define (on? prop a b)
383    (if (memv prop properties) a b))
384 
385  (define (on-next? prop default)
386    (let ((rest (memv prop properties)))
387      (if (or (null? rest) (not rest))
388        default
389        (cadr rest))))
390 
391  (create-display
392    (on-next? 'width 100)
393    (on-next? 'height 100)
394    (on? 'single-buffered 0 1)
395    (on? 'full-screen 1 0)
396    (on? 'no-border 1 0)
397    (on? 'shape 1 0)
398    ))
399
400(define gl-display:destroy
401  (foreign-lambda void "destroy_gl_window" c-pointer))
402
403(define gl-display:time
404  (foreign-lambda int "time_milliseconds"))
405
Note: See TracBrowser for help on using the repository browser.