X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fgacela.scm;h=1a5a0d96fff0662c449c52e356200005b61b3df9;hb=65b948c4b2b72bbf86304e9e2d84e0527b69b97f;hp=f14b837bdd956ca859d84a9e70d2b2a7d1681cbd;hpb=472c0b5d6812da7ee5c5136028aacc35108082e7;p=gacela.git diff --git a/src/gacela.scm b/src/gacela.scm index f14b837..1a5a0d9 100644 --- a/src/gacela.scm +++ b/src/gacela.scm @@ -15,7 +15,143 @@ ;;; along with this program. If not, see . -;;; Default values for Gacela +(define-module (gacela gacela) + #:use-module (gacela events) + #:use-module (gacela video) + #:use-module (gacela audio) + #:use-module (ice-9 optargs) + #:export (*title* + *width-screen* + *height-screen* + *bpp-screen* + *frames-per-second* + *mode* + set-game-properties! + get-game-properties + init-gacela + quit-gacela + game-loop + gacela-script + game-running? + show-mob-hash + hide-mob-hash + get-active-mobs + hide-all-mobs + get-current-mob-id + get-mob-function-name + map-mobs + translate-mob) + #:export-syntax (game + show-mob + hide-mob + the-mob + define-mob-function + define-mob + lambda-mob + define-checking-mobs) + #:re-export (get-frame-time + 3d-mode?)) + + +;;; Main Loop + +(define loop-flag #f) +(define game-loop-thread #f) + +(define-macro (run-in-game-loop proc) + (let ((pgl (string->symbol (string-concatenate (list (symbol->string proc) "-in-game-loop")))) + (flag-symbol (gensym)) + (value-symbol (gensym))) + `(begin + (define ,pgl ,proc) + (define (,proc . param) + (cond ((and game-loop-thread (not (eq? game-loop-thread (current-thread)))) + (let ((,flag-symbol #f)) + (define ,value-symbol) + (system-async-mark + (lambda () + (catch #t + (lambda () (set! ,value-symbol (apply ,pgl param))) + (lambda (key . args) #f)) + (set! ,flag-symbol #t)) + game-loop-thread) + (while (not ,flag-symbol)) + ,value-symbol)) + (else + (apply ,pgl param))))))) + +(run-in-game-loop load-texture) +(run-in-game-loop load-font) +(run-in-game-loop set-screen-bpp!) +(run-in-game-loop resize-screen) + +(define-macro (game . code) + (if (null? code) + #f + `(call-with-new-thread (lambda () ,@code)))) + +(define (init-gacela) + (hide-all-mobs) + (cond ((not game-loop-thread) + (set! game-loop-thread (call-with-new-thread (lambda () (cond ((not (game-running?)) (game-loop)))))))) + (while (not loop-flag)) + #t) + +(define (quit-gacela) + (hide-all-mobs) + (set! game-loop-thread #f) + (set! loop-flag #f) + (quit-video)) + +(define (game-loop) + (refresh-active-mobs) + (init-video *width-screen* *height-screen* *bpp-screen* #:title *title* #:mode *mode* #:fps *frames-per-second*) + (set! loop-flag #t) + (let loop () + (cond (loop-flag + (init-frame-time) +; (check-connections) + (process-events) + (cond ((quit-signal?) + (quit-gacela)) + (else + (clear-screen) + (to-origin) + (refresh-active-mobs) + (run-mobs) + (run-extensions) + (flip-screen) + (delay-frame) + (loop))))))) + +(define (gacela-script args) + (while loop-flag (sleep 1))) + +(define (game-running?) + loop-flag) + + +;;; Extensions to main loop + +(define extensions '()) + +(define (add-extension! proc pri) + "Add an extension with a priority to the main loop" + (set! extensions + (sort (assoc-set! extensions proc pri) + (lambda (a b) + (< (cdr a) (cdr b)))))) + +(define (remove-extension! proc) + "Remove an extension from the main loop" + (set! extensions + (assoc-remove! extensions proc))) + +(define (run-extensions) + (for-each (lambda (x) ((car x))) extensions)) + + +;;; Game Properties (define *title* "Gacela") (define *width-screen* 640) @@ -23,253 +159,207 @@ (define *bpp-screen* 32) (define *frames-per-second* 20) (define *mode* '2d) - - -;;; SDL Initialization Subsystem - -(define init-sdl #f) -(define sdl-on? #f) -(define quit-sdl #f) - -(let ((initialized #f)) - (set! init-sdl - (lambda () - (cond ((not initialized) (SDL_Init SDL_INIT_EVERYTHING) (set! initialized #t)) - (else initialized)))) - - (set! sdl-on? - (lambda () - (if initialized #t #f))) - - (set! quit-sdl - (lambda () - (SDL_Quit) - (set! initialized #f)))) - - -;;; Video Subsystem - -(define init-video-mode #f) -(define video-mode-on? #f) -(define resize-screen #f) -(define quit-video-mode #f) - -(let ((screen #f) (flags 0)) - (set! init-video-mode - (lambda () - (cond ((not screen) - (init-sdl) - (let* ((props (get-game-properties)) - (width (assoc-ref props 'width)) (height (assoc-ref props 'height)) - (bpp (assoc-ref props 'bpp)) (title (assoc-ref props 'title)) - (mode (assoc-ref props 'mode)) - (info (SDL_GetVideoInfo))) - (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1) - (set! flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE - (if (= (assoc-ref info 'hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE) - (if (= (assoc-ref info 'blit_hw) 0) 0 SDL_HWACCEL))) - (set! screen (SDL_SetVideoMode width height bpp flags)) - (SDL_WM_SetCaption title "") - (init-gl) - (if (eq? mode '3d) (set-3d-mode) (set-2d-mode)))) - (else #t)))) - - (set! video-mode-on? - (lambda () (if screen #t #f))) - - (set! resize-screen - (lambda* (width height #:optional (bpp current-bpp)) - (cond (screen (set! screen (SDL_SetVideoMode width height bpp flags)) - (resize-screen-GL width height))))) - - (set! quit-video-mode - (lambda () - (SDL_FreeSurface screen) - (set! screen #f)))) - -(define (set-2d-mode) - (cond ((not (3d-mode?)) - (init-video-mode) - (glDisable GL_DEPTH_TEST) - (apply-mode-change)))) - -(define (set-3d-mode) - (cond ((3d-mode?) - (init-video-mode) - (glClearDepth 1) - (glEnable GL_DEPTH_TEST) - (glDepthFunc GL_LEQUAL) - (apply-mode-change)))) - -(define (apply-mode-change) - (let* ((props (get-game-properties)) - (width (assoc-ref props 'width)) (height (assoc-ref props 'height))) - (resize-screen-GL width height))) - -(define (3d-mode?) - (eq? (assoc-ref (get-game-properties) 'mode) '3d)) - -(define (init-gl) - (glShadeModel GL_SMOOTH) - (glClearColor 0 0 0 0) -; (glClearDepth 1) -; (glDepthFunc GL_LEQUAL) - (glEnable GL_BLEND) -; (glBlendFunc GL_SRC_ALPHA GL_ONE) - (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) - (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST) - #t) - -(define (init-lighting) - (init-video-mode) - (glEnable GL_LIGHTING)) - -(define (resize-screen-GL width height) - (glViewport 0 0 width height) - (glMatrixMode GL_PROJECTION) - (glLoadIdentity) - (cond ((3d-mode?) (let ((ratio (if (= height 0) width (/ width height)))) - (gluPerspective 45 ratio 0.1 100))) ;0.1 - (else (let* ((w (/ width 2)) (h (/ height 2))) - (glOrtho (- w) w (- h) h 0 1)))) - (glMatrixMode GL_MODELVIEW) - (glLoadIdentity) - #t) - -(define get-current-color #f) -(define set-current-color #f) - -(let ((current-color '(1 1 1 1))) - (set! get-current-color - (lambda () - current-color)) - - (set! set-current-color - (lambda* (red green blue #:optional (alpha 1)) - (set! current-color (list red green blue alpha)) - (glColor4f red green blue alpha)))) - - -;;; Audio Subsystem - -(define init-audio #f) -(define quit-audio #f) - -(let ((audio #f)) - (set! init-audio - (lambda () - (cond ((not audio) (begin (init-sdl) (set! audio (Mix_OpenAudio 22050 MIX_DEFAULT_FORMAT 2 4096)))) - (else audio)))) - - (set! quit-audio - (lambda () - (Mix_CloseAudio) - (set! audio #f)))) - - -;;; Resources Cache - -(define resources-cache (make-weak-value-hash-table)) - - -;;; GaCeLa Functions - -(define set-frames-per-second #f) -(define init-frame-time #f) -(define delay-frame #f) - -(let ((time 0) (time-per-frame (/ 1000.0 *frames-per-second*))) - (set! set-frames-per-second - (lambda (fps) - (set! time-per-frame (/ 1000.0 fps)))) - - (set! init-frame-time - (lambda () - (set! time (SDL_GetTicks)))) - - (set! delay-frame - (lambda () - (let ((frame-time (- (SDL_GetTicks) time))) - (cond ((< frame-time time-per-frame) - (SDL_Delay (- time-per-frame frame-time)))))))) - - -(define set-game-properties! #f) -(define get-game-properties #f) - -(let ((ptitle *title*) (pwidth *width-screen*) (pheight *height-screen*) (pbpp *bpp-screen*) (pfps *frames-per-second*) (pmode *mode*)) - (set! set-game-properties! - (lambda* (#:key title width height bpp fps mode) -; (init-video-mode) - (if title - (begin - (set! ptitle title) - (if (video-mode-on?) (SDL_WM_SetCaption title "")))) - (if (or width height bpp) - (begin - (if width (set! pwidth width)) - (if height (set! pheight height)) - (if bpp (set! pbpp bpp)) - (if (video-mode-on?) (resize-screen pwidth pheight pbpp)))) - (if fps - (begin - (set! pfps fps) - (set-frames-per-second fps))) - (if mode - (begin - (set! pmode mode) - (if (video-mode-on?) - (if (eq? mode '3d) (set-3d-mode) (set-2d-mode))))) - (get-game-properties))) - - (set! get-game-properties - (lambda () - `((title . ,ptitle) (width . ,pwidth) (height . ,pheight) (bpp . ,pbpp) (fps . ,pfps) (mode . ,pmode))))) - - -(define-macro (run-game . code) - `(let ((game-function ,(if (null? code) - `(lambda () #f) - `(lambda () ,@code)))) - (init-video-mode) - (set-game-code game-function) - (cond ((not (game-running?)) - (game-loop))))) - -(define game-loop #f) -(define game-running? #f) -(define set-game-code #f) - -(let ((running #f) (game-code #f) (mobs '())) - (set! game-loop - (lambda () - (set! mobs (get-active-mobs)) - (set! running #t) - (quit! #f) - (do () ((quit?)) - (init-frame-time) - (check-connections) - (eval-from-clients) - (process-events) - (cond ((not (quit?)) - (cond ((video-mode-on?) - (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) - (to-origin))) - (cond ((mobs-changed?) (set! mobs (get-active-mobs)))) - (if (procedure? game-code) - (catch #t - (lambda () (game-code)) - (lambda (key . args) #f))) - (cond ((video-mode-on?) - (run-mobs mobs) - (SDL_GL_SwapBuffers))) - (delay-frame)))) - (set! running #f))) - - (set! game-running? - (lambda () - running)) - - (set! set-game-code - (lambda (game-function) - (set! game-code game-function)))) +(define *fullscreen* 'off) + +(define* (set-game-properties! #:key title width height bpp fps mode fullscreen) + (if title + (set-screen-title! title)) + (if bpp + (set-screen-bpp! bpp)) + (if (or width height) + (begin + (if (not width) (set! width (get-screen-width))) + (if (not height) (set! height (get-screen-height))) + (resize-screen width height))) + (if fps + (set-frames-per-second! fps)) + (if mode + (if (eq? mode '3d) (set-3d-mode) (set-2d-mode))) + (if fullscreen + (set-fullscreen! fullscreen)) + (get-game-properties)) + +(define (get-game-properties) + `((title . ,(get-screen-title)) (width . ,(get-screen-width)) (height . ,(get-screen-height)) (bpp . ,(get-screen-bpp)) (fps . ,(get-frames-per-second)) (mode . ,(if (3d-mode?) '3d '2d)) (fullscreen . ,(get-fullscreen)))) + + +;;; Mobs Factory + +(define mobs-table (make-hash-table)) +(define active-mobs '()) +(define mobs-changed #f) + +(define (show-mob-hash mob) + (hash-set! mobs-table (mob 'get-mob-id) mob) + (set! mobs-changed #t)) + +(define (hide-mob-hash mob-id) + (hash-remove! mobs-table mob-id) + (set! mobs-changed #t)) + +(define (refresh-active-mobs) + (cond (mobs-changed + (set! mobs-changed #f) + (set! active-mobs (hash-map->list (lambda (k v) v) mobs-table))))) + +(define (get-active-mobs) + active-mobs) + +(define (hide-all-mobs) + (set! mobs-changed #t) + (hash-clear! mobs-table)) + +(define (mobs-changed?) + mobs-changed) + + +(define-macro (show-mob mob) + (cond ((list? mob) + `(let ((m ,mob)) + (show-mob-hash m))) + (else + `(show-mob-hash (lambda* (#:optional (option #f)) (,mob option)))))) + +(define-macro (hide-mob mob) + (cond ((list? mob) + `(let ((m ,mob)) + (hide-mob-hash (m 'get-mob-id)))) + (else + `(hide-mob-hash (,mob 'get-mob-id))))) + +(define current-mob-id #f) + +(define translate-mob translate) + +(define (get-current-mob-id) + current-mob-id) + +(define* (run-mobs #:optional (mobs (get-active-mobs))) + (let ((sorted-mobs (sort mobs (lambda (m1 m2) (< (m1 'get-z-index) (m2 'get-z-index)))))) + (for-each + (lambda (m) + (set! current-mob-id (m 'get-mob-id)) + (glmatrix-block (m))) + sorted-mobs) + (set! current-mob-id #f))) + + +;;; Making mobs + +(define mob-functions (make-hash-table)) + +(define (get-mob-function-name mob-name) + (let ((name (hash-ref mob-functions mob-name))) + (cond ((not name) + (set! name (gensym)) + (hash-set! mob-functions mob-name name))) + name)) + +(define-macro (the-mob mob-name init-data) + `(let ((mob-id (gensym)) + (mob-z-index 0) + (mob-time 0) + (mob-data ,init-data) + (saved-data ,init-data)) + (lambda* (#:optional (option #f)) + (define (save-data) + (let ((time (get-frame-time))) + (cond ((not (= time mob-time)) + (set! mob-time time) + (set! saved-data mob-data))))) + (case option + ((get-mob-id) + mob-id) + ((get-z-index) + mob-z-index) + ((get-type) + (procedure-name ,mob-name)) + ((get-data) + (save-data) + saved-data) + (else + (cond ((keyword? option) + (assoc-ref saved-data (keyword->symbol option))) + (else + (save-data) + (let ((res (,mob-name mob-id mob-data))) + (set! mob-z-index (car res)) + (set! mob-data (cadr res)))))))))) + +(define-macro (define-mob-function attr . body) + (let ((attr (map (lambda (a) (if (list? a) a (list a #f))) attr)) + (mob-id-symbol (gensym)) + (mob-id-z-index (gensym)) + (data-symbol (gensym))) + `(lambda (,mob-id-symbol ,data-symbol) + (let ((,mob-id-z-index 0)) + (define (kill-me) + (hide-mob-hash ,mob-id-symbol)) + (define* (translate x y #:optional (z 0)) + (cond ((3d-mode?) + (translate-mob x y z)) + (else + (set! ,mob-id-z-index (+ ,mob-id-z-index z)) + (translate-mob x y)))) + (let* ,attr + ,@(map + (lambda (a) + `(let ((val (assoc-ref ,data-symbol ',(car a)))) + (cond (val (set! ,(car a) val))))) + attr) + (catch #t + (lambda* () ,@body) + (lambda (key . args) #f)) + (list ,mob-id-z-index (list ,@(map (lambda (a) `(cons ',(car a) ,(car a))) attr)))))))) + +(define-macro (define-mob mob-head . body) + (let* ((name (car mob-head)) + (attr (cdr mob-head)) + (make-fun-symbol (gensym)) + (mob-fun-symbol (gensym)) + (params-symbol (gensym))) + `(define (,name . ,params-symbol) + (define ,make-fun-symbol + (lambda* ,(if (null? attr) '() `(#:key ,@attr)) + (the-mob ,name (list ,@(map (lambda (a) `(cons ',(car a) ,(car a))) attr))))) + (define ,mob-fun-symbol + (define-mob-function ,attr ,@body)) + (cond ((or (null? ,params-symbol) (keyword? (car ,params-symbol))) + (apply ,make-fun-symbol ,params-symbol)) + (else + (apply ,mob-fun-symbol ,params-symbol)))))) + +(define-macro (lambda-mob attr . body) + (let ((fun-name (gensym))) + `(begin + (define-mob-function ,(cons fun-name attr) ,@body) + (the-mob 'undefined '() ,fun-name)))) + + +;;; Functions for checking mobs (collisions and more) + +(define (map-mobs fun type) + (let ((mobs (filter (lambda (m) (and (eq? (m 'get-type) type) (not (eq? (m 'get-mob-id) (get-current-mob-id))))) (get-active-mobs)))) + (map (lambda (m) (fun (m 'get-data))) mobs))) + +(define-macro (define-checking-mobs head mob-def . body) + (let ((type (car mob-def)) (attr (cdr mob-def))) + `(define ,head + (map-mobs + (lambda (m) + (let ,(map (lambda (a) `(,(car a) (assoc-ref m ',(cadr a)))) attr) + ,@body)) + ',type)))) + + +;;; Scenes + +(define-macro (define-scene name . body) + `(define (,name) + ,@body)) + + +(module-map (lambda (sym var) + (if (not (eq? sym '%module-public-interface)) + (module-export! (current-module) (list sym)))) + (current-module))