Drawing circles

[gacela.git] / src / video.scm

diff --git a/src/video.scm b/src/video.scm
index e65d6bdcecaeb787b003764932237c03663a718c..2cf97a62e8517e7b53967a80950d3128b6d50b74 100644 (file)
--- a/src/video.scm
+++ b/src/video.scm
@@ -247,7 +247,8 @@
 (define (begin-draw number-of-points)
   (cond ((= number-of-points 2) (glBegin GL_LINES))
        ((= number-of-points 3) (glBegin GL_TRIANGLES))
-       ((= number-of-points 4) (glBegin GL_QUADS))))
+       ((= number-of-points 4) (glBegin GL_QUADS))
+       ((> number-of-points 4) (glBegin GL_POLYGON))))
 
 (define (draw-vertexes vertexes)
   (cond ((not (null? vertexes))
@@ -328,6 +329,14 @@
          (else
           (draw (list 0 l) (list 0 (- l)))))))
 
+(define (draw-circle radius)
+  (glBegin GL_POLYGON)
+  (do ((i 0 (1+ i)))
+      ((>= i 360))
+    (let ((a (degrees-to-radians i)))
+      (draw-vertex (list (* radius (cos a)) (* radius (sin a))))))
+  (glEnd))
+
 (define* (draw-quad v1 v2 v3 v4 #:key texture color (texture-coord '((0 0) (1 1))))
   (cond (texture
         (progn-textures
@@ -353,7 +362,7 @@
               #:texture-coord texture-coord
               #:color color)))
 
-(define* (draw-square #:key (size 1) texture color)
+(define* (draw-square size #:key texture color)
   (draw-rectangle size size #:texture texture #:color color))
 
 (define* (draw-cube #:key (size 1)
@@ -455,9 +464,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,20 +562,54 @@
   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)
-  (let ((name (car header))
-       (args (cdr header)))
-    `(define* ,header
+(define-macro (primitive header . body)
+  (let* ((type (car header))
+        (args (cdr header))
+        (list-args (names-arguments args)))
+    `(lambda* ,args
        (let ((m (make-mesh
-                ',name
+                ',type
                 (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))))
+                  (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))
+
+(define-primitive (circle radius)
+  (draw-circle radius))
+
+(define-primitive (picture filename #:key (min-filter GL_LINEAR) (mag-filter GL_LINEAR) (zoom 1) (sprite '((0 0) (1 1))))
+  (draw-texture (load-texture filename #:min-filter min-filter #:mag-filter mag-filter) #:zoom zoom #:sprite sprite))
+
 
 (module-map (lambda (sym var)
              (if (not (eq? sym '%module-public-interface))