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

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

squares fixes and bind version

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