X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fgacela.scm;h=e2be9a8c5091dd992a49420642b15ced35387927;hb=bdc03bcc2da4d01745fb542d7a7d642b888b691e;hp=db6a827d9e4a9b50378b2591530ee788afb77d5c;hpb=9fef3eaa3b432926d3af475fb2a673c76131c779;p=gacela.git diff --git a/src/gacela.scm b/src/gacela.scm index db6a827..e2be9a8 100644 --- a/src/gacela.scm +++ b/src/gacela.scm @@ -15,291 +15,359 @@ ;;; 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 game-loop-flag #f) +(define game-loop-thread #f) +(define game-loop-procedure #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) + `(set! game-loop-procedure + ,(if (null? code) + `#f + `(lambda (game-elements) ,@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 game-loop-flag)) + #t) + +(define (quit-gacela) +; (hide-all-mobs) + (set! game-loop-thread #f) + (set! game-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! game-loop-flag #t) + (let loop ((game-elements '())) + (cond (game-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) + (if game-loop-procedure + (set! game-elements (game-loop-procedure game-elements))) + (process-game-elements game-elements) + (flip-screen) + (delay-frame) + (loop))))))) + +(define (game-running?) + game-loop-flag) + +(define (process-game-elements elements) + (cond ((not (list? elements)) + (process-game-elements (list elements))) + (else + (draw-meshes (filter (lambda (e) (mesh? e)) elements)) +))) + +;;; 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) (define *height-screen* 480) (define *bpp-screen* 32) (define *frames-per-second* 20) - -;;; SDL Initialization Subsystem -(let (initialized) - - (define (init-sdl) - (cond ((null initialized) (set! initialized (SDL_Init SDL_INIT_EVERYTHING))) - (#t initialized))) - - (define (quit-sdl) - (set! initialized (SDL_Quit)))) - - -;;; Video Subsystem -(let (screen flags (current-width *width-screen*) (current-height *height-screen*) current-bpp) - - (defun init-video-mode (&key (width current-width) (height current-height) (bpp *bpp-screen*)) - (cond ((null screen) - (init-sdl) - (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1) - (setq flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE - (if (= (getf (SDL_GetVideoInfo) :hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE) - (if (= (getf (SDL_GetVideoInfo) :blit_hw) 0) 0 SDL_HWACCEL))) - (setq screen (SDL_SetVideoMode width height bpp flags)) - (init-GL) - (resize-screen-GL width height) - (setq current-width width current-height height current-bpp bpp)) - (t t))) - - (defun resize-screen (width height &optional (bpp current-bpp)) - (cond (screen (setq screen (SDL_SetVideoMode width height bpp flags)) - (resize-screen-GL width height))) - (setq current-width width current-height height)) - - (defun apply-mode-change () - (resize-screen-GL current-width current-height)) - - (defun quit-video-mode () - (setq screen nil))) - -(defun set-2d-mode () - (cond ((not (3d-mode?)) - (init-video-mode) - (glDisable GL_DEPTH_TEST) - (apply-mode-change)))) - -(defun set-3d-mode () - (cond ((3d-mode?) - (init-video-mode) - (glClearDepth 1) - (glEnable GL_DEPTH_TEST) - (glDepthFunc GL_LEQUAL) - (apply-mode-change)))) - -(defun 3d-mode? () - (eq (getf (get-game-properties) :mode) '3d)) - -(defun init-GL () - (glShadeModel GL_SMOOTH) - (glClearColor 0 0 0 0) -; (glClearDepth 1) -; (glDepthFunc GL_LEQUAL) -; (glEnable GL_BLEND) -; (glBlendFunc GL_SRC_ALPHA GL_ONE) - (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST) - t) - -(defun init-lighting () - (init-video-mode) - (glEnable GL_LIGHTING)) - -(defun 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 - (t (let* ((w (/ width 2)) (-w (neg w)) (h (/ height 2)) (-h (neg h))) - (glOrtho -w w -h h 0 1)))) - (glMatrixMode GL_MODELVIEW) - (glLoadIdentity) - t)) - -(let ((current-color '(1 1 1 1))) - (defun get-current-color () - current-color) - - (defun set-current-color (red green blue &optional (alpha 1)) - (setq current-color (list red green blue alpha)) - (glColor4f red green blue alpha))) - -(defun load-image (image-file &key (transparent-color nil)) - (init-video-mode) - (let ((loaded-image (IMG_Load image-file))) - (cond ((= loaded-image 0) nil) - (t (let ((optimized-image (SDL_DisplayFormat loaded-image))) - (SDL_FreeSurface loaded-image) - (cond ((= optimized-image 0) nil) - ((null transparent-color) optimized-image) - (t (SDL_SetColorKey optimized-image - SDL_SRCCOLORKEY - (SDL_MapRGB (surface-format optimized-image) - (car transparent-color) - (cadr transparent-color) - (caddr transparent-color))) - optimized-image))))))) - - -;;; Audio Subsystem -(let ((audio nil)) - - (defun init-audio () - (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 MIX_DEFAULT_FORMAT 2 4096)))) - (t audio))) - - (defun quit-audio () - (setq audio (Mix_CloseAudio)))) - - -;;; Resources Manager -(defstruct resource plist constructor destructor time) - -(defun make-resource-texture (&key filename min-filter mag-filter) - `(:type texture :filename ,filename :min-filter ,min-filter :mag-filter ,mag-filter)) - -(defun make-resource-font (&key filename encoding) - `(:type font :filename ,filename :enconding ,encoding)) - -(defun make-resource-sound (&key filename) - `(:type sound :filename ,filename)) - -(defun make-resource-music (&key filename) - `(:type music :filename ,filename)) - -(defmacro get-rtime (key) - `(resource-time (gethash ,key resources-table))) - -(defmacro get-rplist (key) - `(resource-plist (gethash ,key resources-table))) - -(defmacro get-rconstructor (key) - `(resource-constructor (gethash ,key resources-table))) - -(defmacro get-rdestructor (key) - `(resource-destructor (gethash ,key resources-table))) - -(let ((resources-table (make-hash-table :test 'equal)) - (expiration-time 50000)) - - (defun set-expiration-time (new-time) - (setq expiration-time new-time)) - - (defun set-resource (key plist constructor destructor &key static) - (expire-resources) - (setf (gethash key resources-table) - (make-resource :plist plist - :constructor constructor - :destructor destructor - :time (if static t (SDL_GetTicks))))) - - (defun get-resource (key) - (cond ((null (gethash key resources-table)) nil) - (t (let ((time (get-rtime key))) - (cond ((null time) (funcall (get-rconstructor key))) - ((numberp time) (setf (get-rtime key) (SDL_GetTicks)))) - (get-rplist key))))) - - (defun free-resource (key) - (funcall (get-rdestructor key)) - (setf (get-rtime key) nil)) - - (defun expire-resource (key &optional (now (SDL_GetTicks))) - (let ((time (get-rtime key))) - (cond ((and (numberp time) (> (- now time) expiration-time)) (free-resource key))))) - - (defun expire-resources () - (maphash (lambda (key res) (expire-resource key)) resources-table)) - - (defun free-all-resources () - (maphash (lambda (key res) (free-resource key)) resources-table))) - - -;;; Connection with Gacela Clients -(let (server-socket clients) - (defun start-server (port) - (cond ((null server-socket) (setq server-socket (si::socket port :server #'check-connections))))) - - (defun check-connections () - (cond ((and server-socket (listen server-socket)) (setq clients (cons (si::accept server-socket) clients))))) - - (defun eval-from-clients () - (labels ((eval-clients (cli-socks) - (cond (cli-socks - (let ((cli (car cli-socks))) - (cond ((si::listen cli) - (secure-block cli (eval (read cli))) - (si::close cli) - (eval-clients (cdr cli-socks))) - (t - (cons cli (eval-clients (cdr cli-socks)))))))))) - (setq clients (eval-clients clients)))) - - (defun stop-server () - (cond (server-socket (si::close server-socket) (setq server-socket nil))) - (cond (clients - (labels ((close-clients (cli-socks) - (si::close (car cli-socks)) - (close-clients (cdr cli-socks)))) - (close-clients clients)) - (setq clients nil))))) - - -;;; GaCeLa Functions -(let (time (time-per-frame (/ 1000.0 *frames-per-second*))) - (defun set-frames-per-second (fps) - (setq time-per-frame (/ 1000.0 fps))) - - (defun init-frame-time () - (setq time (SDL_GetTicks))) - - (defun delay-frame () - (let ((frame-time (- (SDL_GetTicks) time))) - (cond ((< frame-time time-per-frame) - (SDL_Delay (- time-per-frame frame-time))))))) - - -(let ((ptitle "") (pwidth *width-screen*) (pheight *height-screen*) (pbpp *bpp-screen*) (pfps *frames-per-second*) (pmode '2d)) - (defun set-game-properties (&key title width height bpp fps mode) - (init-video-mode) - (when title (progn (setq ptitle title) (SDL_WM_SetCaption title ""))) - (when (or width height bpp) - (progn - (when width (setq pwidth width)) - (when height (setq pheight height)) - (when bpp (setq pbpp bpp)) - (resize-screen pwidth pheight pbpp))) - (when fps (progn (setq pfps fps) (set-frames-per-second fps))) - (when mode (progn (setq pmode mode) (if (eq mode '3d) (set-3d-mode) (set-2d-mode)))) - (get-game-properties)) - - (defun get-game-properties () - (list :title ptitle :width pwidth :height pheight :bpp pbpp :fps pfps :mode pmode))) - - -(defmacro run-game (&body code) - `(let ((game-function (lambda () ,@code))) - (init-video-mode) - (set-game-code game-function) - (cond ((not (game-running?)) - (game-loop))))) - -(let (running game-code) - (defun game-loop () - (setq running t) - (do () ((quit?)) - (init-frame-time) - (check-connections) - (eval-from-clients) - (process-events) - (cond ((not (quit?)) - (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) - (to-origin) - (refresh-active-objects) - (when (functionp game-code) (funcall game-code)) - (render-objects) - (SDL_GL_SwapBuffers) - (delay-frame)))) - (setq running nil)) - - (defun game-running? () - running) - - (defun set-game-code (game-function) - (setq game-code game-function))) - -(defun quit-game () - (free-all-resources) - (quit-audio) - (quit-video-mode) -; (quit-all-mobs) - (kill-all-objects) -; (clear-events) -; (quit-events) - (quit-sdl)) +(define *mode* '2d) +(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))