Meshes located at video module and new game loop procedure returning game elements

diff --git a/src/gacela.scm b/src/gacela.scm
index 1a5a0d96fff0662c449c52e356200005b61b3df9..e2be9a8c5091dd992a49420642b15ced35387927 100644 (file)
--- 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 d63a51148f2a8f590ae1e2a545abc8dc49d5dd16..ed09712d9a990531d9e9daecdc81e1131596aed1 100644 (file)
--- 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 3e5553dd816357c6f862bb50af35d2e3592cdd8e..e65d6bdcecaeb787b003764932237c03663a718c 100644 (file)
--- 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 "#<mesh: ~a" (mesh-inner-property record 'type))
+                     (for-each (lambda (x)
+                                 (cond (((@ (gacela utils) bound?) (cdr x))
+                                        (format port " ~a" x))))
+                               (mesh-properties record))
+                     (display ">" 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 887c65cb9cbdeeecbee760f5e895493fa0b6629e..8e2c21cf47c6f7b6a366ad272bb37bf39f8aa49e 100644 (file)
--- 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))