source: project/demonstrations/foreign-functions/squares-bind.scm @ 20640

Last change on this file since 20640 was 20640, checked in by felix winkelmann, 11 years ago

squares fixes and bind version

File size: 2.2 KB
Line 
1;;;; squares-bind.scm - draw random squares
2
3
4(use foreigners bind)
5
6
7;;; Constants
8
9(define-constant +width+ 800)
10(define-constant +height+ 600)
11(define-constant +max-size+ 50)
12
13
14;;; Include SDL header
15
16(foreign-declare "#include <SDL/SDL.h>")
17
18
19;;; Foreign constants
20
21(define-foreign-variable SDL_INIT_VIDEO int)
22(define-foreign-variable SDL_DOUBLEBUF int)
23(define-foreign-variable SDL_QUIT int)
24(define-foreign-variable SDL_KEYDOWN int)
25
26
27;;; Foreign record types
28
29(define-foreign-type sdl-rect (c-pointer "SDL_Rect"))
30(define-foreign-type sdl-surface (c-pointer "SDL_Surface"))
31(define-foreign-type sdl-pixel-format (c-pointer "SDL_PixelFormat"))
32
33(define-foreign-record-type (sdl-rect SDL_Rect)
34  (constructor: make-sdl-rect)
35  (short x sdl-rect-x sdl-rect-x-set!)
36  (short y sdl-rect-y sdl-rect-y-set!)
37  (unsigned-short w sdl-rect-w sdl-rect-w-set!)
38  (unsigned-short h sdl-rect-h sdl-rect-h-set!) )
39
40(define-foreign-record-type (sdl-surface SDL_Surface)
41  (sdl-pixel-format format sdl-surface-format))
42
43(define-foreign-record-type (sdl-event SDL_Event)
44  (constructor: make-sdl-event)
45  (int type sdl-event-type))
46
47
48;;; Foreign functions
49
50(bind #<<EOF
51
52int SDL_init(unsigned int);
53SDL_Surface *SDL_SetVideoMode(int, int, int, uint32_t);
54void SDL_FillRect(SDL_Surface *, SDL_Rect *, uint32_t);
55void SDL_Flip(SDL_Surface *);
56___bool SDL_PollEvent(SDL_Event *);
57
58
59;;; initialize SDL
60
61(assert (zero? (SDL_Init SDL_INIT_VIDEO)))
62
63
64;;; Draw random squares
65
66(define (draw screen n)
67  (let ((rect (make-sdl-rect))
68        (event (make-sdl-event)))
69    (let loop ()
70      (do ((i 0 (add1 i)))
71          ((>= i n))
72        (sdl-rect-x-set! rect (random +width+))
73        (sdl-rect-y-set! rect (random +height+))
74        (sdl-rect-w-set! rect (random +max-size+))
75        (sdl-rect-h-set! rect (random +max-size+))
76        (SDL_FillRect
77         screen rect 
78         (SDL_MapRGB
79          (sdl-surface-format screen) 
80          (random 256) (random 256) (random 256))))
81      (SDL_Flip screen)
82      (unless (and (SDL_PollEvent event)
83                   (or (= SDL_QUIT (sdl-event-type event))
84                       (= SDL_KEYDOWN (sdl-event-type event))))
85        (loop)))))
86
87
88;;; main procedure
89
90(define (main #!optional (count 100))
91  (let ((screen (SDL_SetVideoMode 800 600 0 SDL_DOUBLEBUF)))
92    (draw screen count)))
93
94(apply main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.