source: project/gl-display-glx/chicken/gl-display-glx.scm @ 7349

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

moved things around

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