From 361f23e1a9ef0d905cc879f9a4b0a4832a1d4287 Mon Sep 17 00:00:00 2001
From: Javier Sancho <jsf@jsancho.org>
Date: Fri, 28 Sep 2012 00:52:27 +0200
Subject: [PATCH] Primitives definition (for meshes)

---
 src/video.scm | 43 +++++++++++++++++++++++++++++++++++++++----
 1 file changed, 39 insertions(+), 4 deletions(-)

diff --git a/src/video.scm b/src/video.scm
index 0e6a513..87ba9e0 100644
--- a/src/video.scm
+++ b/src/video.scm
@@ -455,9 +455,7 @@
  		    '(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))))
+ 		      (for-each (lambda (x) (format port " ~a" x))
  				(mesh-properties record))
  		      (display ">" port))))
 
@@ -555,6 +553,15 @@
   mesh)
 
 
+;;; Advanced meshes
+
+(define (mesh-join . meshes)
+  (make-mesh
+   'joined-meshes
+   (lambda (props)
+     (for-each (lambda (m) (glmatrix-block (mesh-draw m))) meshes))))
+
+
 ;;; Primitives
 
 (define-macro (define-mesh header . body)
@@ -569,9 +576,37 @@
 	 (mesh-properties-set! m (list ,@(map (lambda (a) `(cons ',a ,a)) (names-arguments args))))
 	 m))))
 
-(define-mesh (square size #:key texture color)
+(define-macro (primitive header . body)
+  (let* ((type (car header))
+	 (args (cdr header))
+	 (list-args (names-arguments args)))
+    `(lambda* ,args
+       (let ((m (make-mesh
+		 ',type
+		 (lambda (props)
+		   (apply (lambda* ,(cons #:key list-args) ,@body)
+			  (list
+			   ,@(let get-params ((l list-args))
+			       (cond ((null? l) '())
+				     (else
+				      (cons (symbol->keyword (car l))
+					    (cons `(assoc-ref props ',(car l))
+						  (get-params (cdr l)))))))))))))
+	 (mesh-properties-set! m (list ,@(map (lambda (a) `(cons ',a ,a)) list-args)))
+	 m))))
+
+(define-macro (define-primitive header . body)
+  `(define ,(car header) (primitive ,header ,@body)))
+
+
+;;; Primitives definition
+
+(define-primitive (square size #:key texture color)
   (draw-square size #:texture texture #:color color))
 
+(define-primitive (rectangle width height #:key texture color texture-coord)
+  (draw-rectangle width height #:texture texture #:color color #:texture-coord texture-coord))
+
 
 (module-map (lambda (sym var)
 	      (if (not (eq? sym '%module-public-interface))
-- 
2.39.5