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

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

makefile, bugfixes

File size: 2.3 KB
Line 
1;;;; squares-bind.scm - draw random squares
2
3
4(use foreigners bind extras)
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_SWSURFACE 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, unsigned int);
54void SDL_FillRect(SDL_Surface *, SDL_Rect *, unsigned int);
55void SDL_Flip(SDL_Surface *);
56___bool SDL_PollEvent(SDL_Event *);
57unsigned int SDL_MapRGB(SDL_PixelFormat *, int, int, int);
58
59EOF
60)
61
62
63;;; initialize SDL
64
65(assert (zero? (SDL_Init SDL_INIT_VIDEO)))
66
67
68;;; Draw random squares
69
70(define (draw screen n)
71  (let ((rect (make-sdl-rect))
72        (event (make-sdl-event)))
73    (let loop ()
74      (do ((i 0 (add1 i)))
75          ((>= i n))
76        (sdl-rect-x-set! rect (random +width+))
77        (sdl-rect-y-set! rect (random +height+))
78        (sdl-rect-w-set! rect (random +max-size+))
79        (sdl-rect-h-set! rect (random +max-size+))
80        (SDL_FillRect
81         screen rect 
82         (SDL_MapRGB
83          (sdl-surface-format screen) 
84          (random 256) (random 256) (random 256))))
85      (SDL_Flip screen)
86      (unless (and (SDL_PollEvent event)
87                   (or (= SDL_QUIT (sdl-event-type event))
88                       (= SDL_KEYDOWN (sdl-event-type event))))
89        (loop)))))
90
91
92;;; main procedure
93
94(define (main #!optional (count 100))
95  (let ((screen (SDL_SetVideoMode 800 600 0 SDL_SWSURFACE)))
96    (draw screen count)))
97
98(apply main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.