X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fgacela.scm;fp=src%2Fgacela.scm;h=0000000000000000000000000000000000000000;hb=4cb735ffd3fddfdc53fd1b944756c6ec6616b819;hp=b9d13160dccac4bce3695d60fb0922e657d3393f;hpb=2eee3eb546a25305d548fcb331769be84fd3a38f;p=gacela.git diff --git a/src/gacela.scm b/src/gacela.scm deleted file mode 100644 index b9d1316..0000000 --- a/src/gacela.scm +++ /dev/null @@ -1,382 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(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 - (catch #t - (lambda () (set! game-elements (game-loop-procedure game-elements))) - (lambda (key . args) #f))) - (process-game-elements game-elements) - (flip-screen) - (delay-frame) - (loop game-elements))))))) - -(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))))) - -(define (draw-meshes meshes) - (cond ((null? meshes) #t) - (else - (catch #t - (lambda () (mesh-draw (car meshes))) - (lambda (key . args) #f)) - (draw-meshes (cdr meshes))))) - -;;; 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) -(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))