← Back to branch summary

~ubuntu-branches/ubuntu/lucid/gauche-c-wrapper/lucid

« back to all changes in this revision

Viewing changes to examples/sdl/breakout.scm

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2008-04-07 09:15:03 UTC
  • Revision ID: james.westby@ubuntu.com-20080407091503-wu0h414koe95kj4i
Tags: upstream-0.5.2
Import upstream version 0.5.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/sdl/breakout.scm
 
1
;; -*- coding: utf-8; mode: scheme -*-
 
2
;;
 
3
;; breakout.scm - Breakout
 
4
;;
 
5
;;   Copyright (c) 2007 KOGURO, Naoki (naoki@koguro.net)
 
6
;;   All rights reserved.
 
7
;;
 
8
;;   Redistribution and use in source and binary forms, with or without 
 
9
;;   modification, are permitted provided that the following conditions 
 
10
;;   are met:
 
11
;;
 
12
;;   1. Redistributions of source code must retain the above copyright 
 
13
;;      notice, this list of conditions and the following disclaimer.
 
14
;;   2. Redistributions in binary form must reproduce the above copyright 
 
15
;;      notice, this list of conditions and the following disclaimer in the 
 
16
;;      documentation and/or other materials provided with the distribution.
 
17
;;   3. Neither the name of the authors nor the names of its contributors 
 
18
;;      may be used to endorse or promote products derived from this 
 
19
;;      software without specific prior written permission.
 
20
;;
 
21
;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
 
22
;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
 
23
;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
 
24
;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 
 
25
;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
 
26
;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 
 
27
;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
 
28
;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
 
29
;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
 
30
;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
 
31
;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
32
;;
 
33
;;   $Id: $
 
34
;;
 
35
 
 
36
(use c-wrapper)
 
37
(use srfi-1)
 
38
(use srfi-27)
 
39
 
 
40
(c-load '("SDL.h" "SDL_mixer.h" "stdio.h" "stdlib.h" "sdl_helper.c")
 
41
        :cppflags-cmd "sdl-config --cflags"
 
42
        :libs-cmd "sdl-config --libs; echo '-lSDL_mixer'"
 
43
        :import (list (lambda (header sym)
 
44
                        (#/\/SDL\/.*\.h$/ header))
 
45
                      'NULL
 
46
                      'run_sdl_main)
 
47
        :compiled-lib "sdllib")
 
48
 
 
49
(define *screen* #f)
 
50
(define-constant *screen-width* 640)
 
51
(define-constant *screen-height* 480)
 
52
(define-constant *screen-depth* 8)
 
53
(define *unit* 8)
 
54
 
 
55
(define *ball-rect* #f)
 
56
;; vx and vy must be a multiple of *unit*.
 
57
(define *ball-vx* 0)
 
58
(define *ball-vy* 0)
 
59
(define *ball-count* 0)
 
60
(define-constant *ball-size* *unit*)
 
61
 
 
62
(define *paddle-rect* #f)
 
63
(define *paddle-width* (* 8 *unit*))
 
64
(define *paddle-vx* 0)
 
65
 
 
66
(define *block-list* '())
 
67
(define *block-start-x* 0)
 
68
(define *block-start-y* 0)
 
69
(define *block-end-x* 0)
 
70
(define *block-end-y* 0)
 
71
 
 
72
(define-constant *block-width* (* 6 *unit*))
 
73
(define-constant *block-height* (* 3 *unit*))
 
74
 
 
75
(define *tick* 0)
 
76
(define *tick-threshold* 20)
 
77
 
 
78
(define *bounce-sound* #f)
 
79
(define *shoot-sound* #f)
 
80
 
 
81
(define (init)
 
82
  (SDL_Init (logior SDL_INIT_VIDEO SDL_INIT_AUDIO))
 
83
  (set! *screen* (SDL_SetVideoMode *screen-width* *screen-height*
 
84
                                   *screen-depth*
 
85
                                   (logior SDL_HWSURFACE
 
86
                                           SDL_DOUBLEBUF)))
 
87
  (SDL_WM_SetCaption "Breakout" NULL)
 
88
  (set! *paddle-rect* (make <SDL_Rect>))
 
89
  (set! (ref *paddle-rect* 'w) *paddle-width*)
 
90
  (set! (ref *paddle-rect* 'h) *unit*)
 
91
  
 
92
  (Mix_OpenAudio 44100 AUDIO_S16SYS 2 1024)
 
93
  (set! *bounce-sound* (Mix_LoadWAV "cursor5.wav"))
 
94
  (set! *shoot-sound* (Mix_LoadWAV "cursor6.wav"))
 
95
  (init-game))
 
96
 
 
97
(define (init-game)
 
98
  (set! (ref *paddle-rect* 'x) (- (/ *screen-width* 2)
 
99
                                  (/ (ref *paddle-rect* 'w) 2)))
 
100
  (set! (ref *paddle-rect* 'y) (- *screen-height* (* 3 *unit*)))
 
101
  (set! *ball-count* 2)
 
102
  (make-blocks))
 
103
  
 
104
(define (make-block x y color)
 
105
  (let ((rect (make <SDL_Rect>)))
 
106
    (set! (ref rect 'x) (+ x 1))
 
107
    (set! (ref rect 'y) (+ y 1))
 
108
    (set! (ref rect 'w) (- *block-width* 2))
 
109
    (set! (ref rect 'h) (- *block-height* 2))
 
110
  (vector (list x y (+ x *block-width*) (+ y *block-height*))
 
111
          rect
 
112
          color)))
 
113
 
 
114
(define (block-vertical-reflect? block x y vx)
 
115
  (receive (sx sy ex ey) (apply values (vector-ref block 0))
 
116
    (and (<= sy y ey)
 
117
         (or (and (= x sx) (< 0 vx))
 
118
             (and (= x ex) (< vx 0))))))
 
119
 
 
120
(define (block-horizontal-reflect? block x y vy)
 
121
  (receive (sx sy ex ey) (apply values (vector-ref block 0))
 
122
    (and (<= sx x ex)
 
123
         (or (and (= y sy) (< 0 vy))
 
124
             (and (= y ey) (< vy 0))))))
 
125
 
 
126
(define (block-hit? block x y)
 
127
  (receive (sx sy ex ey) (apply values (vector-ref block 0))
 
128
    (and (<= sx x ex) (<= sy y ey))))
 
129
  
 
130
(define (make-blocks)
 
131
  (do ((block-list '())
 
132
       (level 0 (+ level 1))
 
133
       (colors '(#o700 #o770 #o373 #o077 #o007) (cdr colors))
 
134
       (y (* 7 *unit*) (+ y *block-height*)))
 
135
      ((<= 5 level)
 
136
       (set! *block-list* block-list))
 
137
    (do ((x (* 1 *unit*) (+ x *block-width*)))
 
138
        ((<= *screen-width* (+ x *block-width*)))
 
139
      (push! block-list (make-block x y (car colors)))))
 
140
  (set! *block-start-x* *screen-width*)
 
141
  (set! *block-start-y* *screen-height*)
 
142
  (set! *block-end-x* 0)
 
143
  (set! *block-end-y* 0)
 
144
  (for-each (lambda (block)
 
145
              (receive (sx sy ex ey) (apply values (vector-ref block 0))
 
146
                (when (< sx *block-start-x*)
 
147
                  (set! *block-start-x* sx))
 
148
                (when (< sy *block-start-y*)
 
149
                  (set! *block-start-y* sy))
 
150
                (when (< *block-end-x* ex)
 
151
                  (set! *block-end-x* ex))
 
152
                (when (< *block-end-y* ey)
 
153
                  (set! *block-end-y* ey))))
 
154
            *block-list*))
 
155
                
 
156
(define (teardown)
 
157
  (Mix_CloseAudio)
 
158
  (SDL_Quit))
 
159
 
 
160
(define clear-screen
 
161
  (let ((rect (make <SDL_Rect>)))
 
162
    (set! (ref rect 'x) 0)
 
163
    (set! (ref rect 'y) 0)
 
164
    (set! (ref rect 'w) *screen-width*)
 
165
    (set! (ref rect 'h) *screen-height*)
 
166
    (lambda ()
 
167
      (SDL_FillRect *screen* (ptr rect) 0))))
 
168
  
 
169
(define (draw-paddle)
 
170
  (SDL_FillRect *screen* (ptr *paddle-rect* ) #o777))
 
171
 
 
172
(define (move-paddle-left)
 
173
  (set! *paddle-vx* (- *unit*)))
 
174
 
 
175
(define (move-paddle-right)
 
176
  (set! *paddle-vx* *unit*))
 
177
 
 
178
(define (move-paddle)
 
179
  (let ((new-x (+ (ref *paddle-rect* 'x) *paddle-vx*))
 
180
        (w (ref *paddle-rect* 'w)))
 
181
    (when (< new-x 0)
 
182
      (set! new-x 0))
 
183
    (when (< (- *screen-width* w) new-x)
 
184
      (set! new-x (- *screen-width* w)))
 
185
    (set! (ref *paddle-rect* 'x) new-x)))
 
186
 
 
187
(define (stop-paddle)
 
188
  (set! *paddle-vx* 0))
 
189
 
 
190
(define (draw-ball)
 
191
  (when *ball-rect*
 
192
    (SDL_FillRect *screen* (ptr *ball-rect*) #o777)))
 
193
 
 
194
(define (move-ball)
 
195
  (let ((reflect? #f))
 
196
    (define (reflect-x)
 
197
      (set! *ball-vx* (- *ball-vx*))
 
198
      (set! reflect? #t))
 
199
    (define (reflect-y)
 
200
      (set! *ball-vy* (- *ball-vy*))
 
201
      (set! reflect? #t))
 
202
    (when *ball-rect*
 
203
      (let ((new-x (+ (ref *ball-rect* 'x) *ball-vx*))
 
204
            (new-y (+ (ref *ball-rect* 'y) *ball-vy*))
 
205
            (paddle-x (ref *paddle-rect* 'x))
 
206
            (paddle-y (ref *paddle-rect* 'y))
 
207
            (paddle-w (ref *paddle-rect* 'w))
 
208
          (paddle-h (ref *paddle-rect* 'h))
 
209
          (w (ref *ball-rect* 'w))
 
210
          (h (ref *ball-rect* 'h)))
 
211
        (when (< new-x 0)
 
212
          (reflect-x)
 
213
          (set! new-x (- new-x)))
 
214
        (when (< (- *screen-width* w) new-x)
 
215
          (reflect-x)
 
216
          (set! new-x (- (* 2 (- *screen-width* w)) new-x)))
 
217
        (when (< new-y 0)
 
218
          (reflect-y)
 
219
          (set! new-y 0))
 
220
        (when (and (<= paddle-y new-y (+ paddle-y paddle-h))
 
221
                   (<= paddle-x new-x (+ paddle-x paddle-w)))
 
222
          (reflect-y)
 
223
          (when (or (and (= paddle-x new-x)
 
224
                         (< 0 *ball-vx*))
 
225
                    (and (= (+ paddle-x paddle-w (- *unit*)) new-x)
 
226
                         (< *ball-vx* 0)))
 
227
            (reflect-x))
 
228
          (set! new-y (- paddle-y h)))
 
229
        (when (< (- *screen-height* h) new-y)
 
230
          (dec! *ball-count*)
 
231
          (set! *ball-rect* #f))
 
232
        (when (and (<= *block-start-x* new-x *block-end-x*)
 
233
                   (<= *block-start-x* new-y *block-end-y*))
 
234
          (do ((block-list *block-list* (cdr block-list))
 
235
               (result '() (cons (car block-list) result)))
 
236
              ((or (null? block-list)
 
237
                   (block-hit? (car block-list) new-x new-y))
 
238
               (unless (null? block-list)
 
239
                 (when (block-vertical-reflect? (car block-list) new-x new-y
 
240
                                                *ball-vx*)
 
241
                   (reflect-x))
 
242
                 (when (block-horizontal-reflect? (car block-list) new-x new-y
 
243
                                                  *ball-vy*)
 
244
                   (reflect-y))
 
245
                 (set! *block-list* (append result (cdr block-list)))))))
 
246
        (when *ball-rect*
 
247
          (set! (ref *ball-rect* 'x) new-x)
 
248
          (set! (ref *ball-rect* 'y) new-y))
 
249
        (when reflect?
 
250
          (Mix_PlayChannel -1 *bounce-sound* 0))))))
 
251
 
 
252
(define (shoot-ball)
 
253
  (unless *ball-rect*
 
254
    (let ((paddle-x (ref *paddle-rect* 'x))
 
255
          (paddle-y (ref *paddle-rect* 'y))
 
256
          (paddle-w (ref *paddle-rect* 'w))
 
257
          (paddle-h (ref *paddle-rect* 'h)))
 
258
      (set! *ball-rect* (make <SDL_Rect>))
 
259
      (set! (ref *ball-rect* 'w) *ball-size*)
 
260
      (set! (ref *ball-rect* 'h) *ball-size*)
 
261
      (set! (ref *ball-rect* 'x) (+ paddle-x (/ paddle-w 2)))
 
262
      (set! (ref *ball-rect* 'y) paddle-y)
 
263
      (set! *ball-vx* (* (- (* 2 (random-integer 2)) 1) *unit*))
 
264
      (set! *ball-vy* (- *unit*))
 
265
      (format #t "ball: ~a~%" *ball-count*)
 
266
      (Mix_PlayChannel -1 *shoot-sound* 0))))
 
267
 
 
268
(define (draw-blocks)
 
269
  (for-each (lambda (block)
 
270
              (SDL_FillRect *screen*
 
271
                            (ptr (vector-ref block 1))
 
272
                            (vector-ref block 2)))
 
273
            *block-list*))
 
274
 
 
275
(define (poll-event event)
 
276
  (SDL_PollEvent (ptr event))
 
277
  (unless (< 0 (SDL_PollEvent (ptr event)))
 
278
    (let ((type (ref event 'type)))
 
279
      (cond
 
280
       ((eq? type SDL_QUIT)
 
281
        #f)
 
282
       ((eq? type SDL_KEYDOWN)
 
283
        (case (ref* event 'key 'keysym 'sym)
 
284
          ((27)
 
285
           #f)
 
286
          ((32)
 
287
           (shoot-ball)
 
288
           #t)
 
289
          ((122)
 
290
           (move-paddle-left)
 
291
           #t)
 
292
          ((120)
 
293
           (move-paddle-right)
 
294
           #t)
 
295
          (else
 
296
           #t)))
 
297
       (else
 
298
        #t)))))
 
299
 
 
300
(define (sdl-main argc argv)
 
301
  (init)
 
302
  (let ((event (make <SDL_Event>)))
 
303
    (do ((continue? (poll-event event) (poll-event event)))
 
304
        ((not continue?) #f)
 
305
      (clear-screen)
 
306
      (move-paddle)
 
307
      (let ((delta (- (SDL_GetTicks) *tick*)))
 
308
        (when (< *tick-threshold* delta)
 
309
          (move-ball)
 
310
          (set! *tick* (SDL_GetTicks))))
 
311
      (draw-paddle)
 
312
      (draw-ball)
 
313
      (draw-blocks)
 
314
      (stop-paddle)
 
315
      (SDL_Flip *screen*)
 
316
      (cond
 
317
       ((< *ball-count* 0)
 
318
        (print "GAME OVER!!")
 
319
        (init-game))
 
320
       ((null? *block-list*)
 
321
        (set! *ball-rect* #f)
 
322
        (make-blocks)))))
 
323
  (teardown)
 
324
  0)
 
325
  
 
326
(define (main args)
 
327
  (run_sdl_main (length args) args sdl-main))
 
328
  
 
329
;; end of file