From bdc03bcc2da4d01745fb542d7a7d642b888b691e Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Fri, 21 Sep 2012 20:21:08 +0200 Subject: [PATCH] Meshes located at video module and new game loop procedure returning game elements --- src/gacela.scm | 46 ++++++++++------- src/utils.scm | 14 ++++++ src/video.scm | 132 ++++++++++++++++++++++++++++++++++++++++++++++++- src/views.scm | 1 - 4 files changed, 171 insertions(+), 22 deletions(-) diff --git a/src/gacela.scm b/src/gacela.scm index 1a5a0d9..e2be9a8 100644 --- a/src/gacela.scm +++ b/src/gacela.scm @@ -55,8 +55,9 @@ ;;; Main Loop -(define loop-flag #f) +(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")))) @@ -86,29 +87,30 @@ (run-in-game-loop resize-screen) (define-macro (game . code) - (if (null? code) - #f - `(call-with-new-thread (lambda () ,@code)))) + `(set! game-loop-procedure + ,(if (null? code) + `#f + `(lambda (game-elements) ,@code)))) (define (init-gacela) - (hide-all-mobs) +; (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)) + (while (not game-loop-flag)) #t) (define (quit-gacela) - (hide-all-mobs) +; (hide-all-mobs) (set! game-loop-thread #f) - (set! loop-flag #f) + (set! game-loop-flag #f) (quit-video)) (define (game-loop) - (refresh-active-mobs) +; (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 + (set! game-loop-flag #t) + (let loop ((game-elements '())) + (cond (game-loop-flag (init-frame-time) ; (check-connections) (process-events) @@ -117,19 +119,25 @@ (else (clear-screen) (to-origin) - (refresh-active-mobs) - (run-mobs) - (run-extensions) +; (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 (gacela-script args) - (while loop-flag (sleep 1))) - (define (game-running?) - loop-flag) + 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 diff --git a/src/utils.scm b/src/utils.scm index d63a511..ed09712 100644 --- a/src/utils.scm +++ b/src/utils.scm @@ -20,6 +20,7 @@ arguments-calling arguments-apply bound? + names-arguments make-producer)) @@ -145,6 +146,11 @@ (keyword-arguments-apply args values) (rest-arguments-apply args values)))) +(define (names-arguments args) + (map (lambda (x) (if (list? x) (car x) x)) + (filter (lambda (x) (not (keyword? x))) + (pair-to-list args)))) + ;;; Continuations and coroutines @@ -161,3 +167,11 @@ (if resume (resume real-send) (body send)))) + + +;;; Miscellaneous + +(define (pair-to-list pair) + (cond ((null? pair) '()) + ((not (pair? pair)) (list pair)) + (else (cons (car pair) (pair-to-list (cdr pair)))))) diff --git a/src/video.scm b/src/video.scm index 3e5553d..e65d6bd 100644 --- a/src/video.scm +++ b/src/video.scm @@ -374,10 +374,10 @@ (glNormal3f -1 0 0) (draw-quad (list -size -size size) (list -size -size -size) (list -size size -size) (list -size size size) #:texture (or texture-6 texture) #:color (or color-6 color))))) -(define* (translate x y #:optional (z 0)) +(define* (gtranslate x y #:optional (z 0)) (glTranslatef x y z)) -(define (rotate . rot) +(define (grotate . rot) (cond ((3d-mode?) (apply 3d-rotate rot)) (else @@ -446,3 +446,131 @@ ((not (= (ftglGetFontFaceSize font) (font-size font))) (ftglSetFontFaceSize font (font-size font) 72))) (ftglRenderFont font text FTGL_RENDER_ALL)) + + +;;; Meshes + +(define mesh-type + (make-record-type "mesh" + '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!) + (lambda (record port) + (format port "#" port)))) + +(define mesh? (record-predicate mesh-type)) + +(define* (make-mesh type proc) + (apply + (record-constructor mesh-type) + (let ((px 0) (py 0) (pz 0) + (ax 0) (ay 0) (az 0) + (rx 0) (ry 0) (rz 0) + (properties '())) + (let ((inner-properties + (lambda () + `((type . ,type) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz))))) + (list + (lambda () + "draw" + (glmatrix-block + (grotate ax ay az) + (gtranslate px py pz) + (grotate rx ry rz) + (proc properties))) + (lambda (x y z) + "translate" + (set! px (+ px x)) + (set! py (+ py y)) + (set! pz (+ pz z))) + (lambda (x y z) + "turn" + (set! ax (+ ax x)) + (set! ay (+ ay y)) + (set! az (+ az z))) + (lambda (x y z) + "rotate" + (set! rx (+ rx x)) + (set! ry (+ ry y)) + (set! rz (+ rz z))) + (lambda () + "inner-properties" + (inner-properties)) + (lambda (prop-name) + "inner-property" + (assoc-ref (inner-properties) prop-name)) + (lambda () + "properties" + properties) + (lambda (new-properties) + "properties-set!" + (set! properties new-properties)) + (lambda (prop-name) + "property" + (assoc-ref properties prop-name)) + (lambda (prop-name value) + "property-set!" + (set! properties (assoc-set! properties prop-name value)))))))) + +(define (mesh-draw mesh) + (((record-accessor mesh-type 'draw) mesh))) + +(define (mesh-inner-properties mesh) + (((record-accessor mesh-type 'inner-properties) mesh))) + +(define (mesh-inner-property mesh prop-name) + (((record-accessor mesh-type 'inner-property) mesh) prop-name)) + +(define (mesh-properties mesh) + (((record-accessor mesh-type 'properties) mesh))) + +(define (mesh-properties-set! mesh new-properties) + (((record-accessor mesh-type 'properties-set!) mesh) new-properties)) + +(define (mesh-property mesh prop-name) + (((record-accessor mesh-type 'property) mesh) prop-name)) + +(define (mesh-property-set! mesh prop-name value) + (((record-accessor mesh-type 'property-set!) mesh) prop-name value)) + +(define* (translate mesh x y #:optional (z 0)) + (((record-accessor mesh-type 'translate) mesh) x y z) + mesh) + +(define (turn mesh . params) + (apply ((record-accessor mesh-type 'turn) mesh) + (if (>= (length params) 3) + params + (list 0 0 (car params)))) + mesh) + +(define (rotate mesh . params) + (apply ((record-accessor mesh-type 'rotate) mesh) + (if (>= (length params) 3) + params + (list 0 0 (car params)))) + mesh) + + +;;; Primitives + +(define-macro (define-mesh header . body) + (let ((name (car header)) + (args (cdr header))) + `(define* ,header + (let ((m (make-mesh + ',name + (lambda (props) + (apply (lambda* ,args ,@body) + ((@ (gacela utils) arguments-apply) ,name props)))))) + (mesh-properties-set! m (list ,@(map (lambda (a) `(cons ',a ,a)) (names-arguments args)))) + m)))) + + +(module-map (lambda (sym var) + (if (not (eq? sym '%module-public-interface)) + (module-export! (current-module) (list sym)))) + (current-module)) diff --git a/src/views.scm b/src/views.scm index 887c65c..8e2c21c 100644 --- a/src/views.scm +++ b/src/views.scm @@ -116,7 +116,6 @@ (format port " ~a" x)))) (mesh-properties record)) (display ">" port)))) - (define mesh? (record-predicate mesh-type)) -- 2.39.5