source: project/demonstrations/foreign-functions/squares-plain.scm @ 20585

Last change on this file since 20585 was 20585, checked in by felix winkelmann, 10 years ago

started squares/SDL/FFI example

File size: 2.2 KB
Line 
1;;;; squares.scm - draw random squares
2
3
4(use foreigners)
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-record-type (sdl-rect SDL_Rect)
30  (constructor: make-sdl-rect)
31  (short x sdl-rect-x sdl-rect-x-set!)
32  (short y sdl-rect-y sdl-rect-y-set!)
33  (unsigned-short w sdl-rect-w sdl-rect-w-set!)
34  (unsigned-short h sdl-rect-h sdl-rect-h-set!) )
35
36(define-foreign-record-type (sdl-surface SDL_Surface)
37  ((c-pointer "SDL_PixelFormat") format sdl-surface-format))
38
39(define-foreign-record-type (sdl-event SDL_Event)
40  (constructor: make-sdl-event)
41  (int type sdl-event-type))
42
43
44;;; Foreign functions
45
46(define SDL_Init
47  (foreign-lambda int "SDL_Init" unsigned-int))
48
49(define SDL_SetVideoMode
50  (foreign-lambda sdl-screen "SDL_SetVideoMode" int int int unsigned-int32))
51
52(define SDL_FillRect
53  (foreign-lambda void "SDL_FillRect" sdl-surface sdl-rect unsigned-int32))
54
55(define SDL_Flip
56  (foreign-lambda void "SDL_Flip" sdl-surface))
57
58(define SDL_PollEvent
59  (foreign-lambda bool "SDL_PollEvent" sdl-event))
60
61
62;;; initialize SDL
63
64(assert (zero? (SDL_Init SDL_INIT_VIDEO)))
65
66
67;;; Draw random squares
68
69(define (draw screen n)
70  (let ((rect (make-sdl-rect))
71        (event (make-sdl-event)))
72    (let loop ()
73      (do ((i 0 (add1 i)))
74          ((>= i n))
75        (sdl-rect-x-set! rect (random +width+))
76        (sdl-rect-y-set! rect (random +height+))
77        (sdl-rect-w-set! rect (random +max-size+))
78        (sdl-rect-h-set! rect (random +max-size+))
79        (SDL_FillRect
80         screen rect 
81         (SDL_MapRGB
82          (sdl-surface-format screen) 
83          (random 256) (random 256) (random 256))))
84      (SDL_Flip screen)
85      (unless (and (SDL_PollEvent event)
86                   (or (= SDL_QUIT (sdl-event-type event))
87                       (= SDL_KEYDOWN (sdl-event-type event))))
88        (loop)))))
89
90
91;;; main procedure
92
93(define (main #!optional (count 100))
94  (let ((screen (SDL_SetVideoMode 800 600 0 SDL_DOUBLEBUF)))
95    (draw screen count)))
96
97(apply main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.