X-Git-Url: https://git.jsancho.org/?p=gacela.git;a=blobdiff_plain;f=src%2Fvideo.scm;h=e65d6bdcecaeb787b003764932237c03663a718c;hp=3e5553dd816357c6f862bb50af35d2e3592cdd8e;hb=bdc03bcc2da4d01745fb542d7a7d642b888b691e;hpb=f02971f747ab2e643e2bc6bd962a068329b0f402

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 "#<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))