New modules figl

[gacela.git] / src / video.scm

diff --git a/src/video.scm b/src/video.scm
index e65d6bdcecaeb787b003764932237c03663a718c..0b49679605ce0e2082ee15da3cea7b0b8dad442c 100644 (file)
--- a/src/video.scm
+++ b/src/video.scm
@@ -17,7 +17,9 @@
 
 (define-module (gacela video)
   #:use-module (gacela sdl)
 
 (define-module (gacela video)
   #:use-module (gacela sdl)

-  #:use-module (gacela gl)
+;  #:use-module (gacela gl)
+  #:use-module (figl gl)
+  #:use-module (figl glu)

   #:use-module (gacela ftgl)
   #:use-module (gacela math)
   #:use-module (gacela utils)
   #:use-module (gacela ftgl)
   #:use-module (gacela math)
   #:use-module (gacela utils)


@@ -67,9 +69,7 @@
            load-font
            load-font-without-texture
            render-text)
            load-font
            load-font-without-texture
            render-text)

-  #:re-export (glPushMatrix
-              glPopMatrix)
-  #:export-syntax (glmatrix-block))
+  #:re-export (with-gl-push-matrix))

 
 
 
 
 
 


@@ -118,7 +118,7 @@
         (SDL_Quit))))
 
 (define (clear-screen)
         (SDL_Quit))))
 
 (define (clear-screen)

-  (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)))
+  (gl-clear (clear-buffer-mask color-buffer depth-buffer)))

 
 (define (flip-screen)
   (SDL_GL_SwapBuffers))
 
 (define (flip-screen)
   (SDL_GL_SwapBuffers))


@@ -138,14 +138,14 @@
 
 (define (set-2d-mode)
   (set! mode '2d)
 
 (define (set-2d-mode)
   (set! mode '2d)

-  (glDisable GL_DEPTH_TEST)
+  (gl-disable depth-test)

   (resize-screen-GL (get-screen-width) (get-screen-height)))
 
 (define (set-3d-mode)
   (set! mode '3d)
   (resize-screen-GL (get-screen-width) (get-screen-height)))
 
 (define (set-3d-mode)
   (set! mode '3d)

-  (glClearDepth 1)
-  (glEnable GL_DEPTH_TEST)
-  (glDepthFunc GL_LEQUAL)
+  (sel-gl-clear-depth 1)
+  (gl-enable depth-test)
+  (set-gl-depth-function lequal)

   (resize-screen-GL (get-screen-width) (get-screen-height)))
 
 (define (3d-mode?)
   (resize-screen-GL (get-screen-width) (get-screen-height)))
 
 (define (3d-mode?)


@@ -166,9 +166,9 @@
 
 
 (define (init-gl)
 
 
 (define (init-gl)

-  (glShadeModel GL_SMOOTH)
+  (set-gl-shade-model GL_SMOOTH)

   (glClearColor 0 0 0 0)
   (glClearColor 0 0 0 0)

-  (glEnable GL_BLEND)
+  (gl-enable GL_BLEND)

   (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
   (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST))
 
   (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
   (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST))
 


@@ -223,20 +223,20 @@
   (glColor4f red green blue alpha))
 
 (define-macro (with-color color . code)
   (glColor4f red green blue alpha))
 
 (define-macro (with-color color . code)

-  (cond (color
-        `(let ((original-color (get-current-color))
+  `(cond (,color
+         (let ((original-color (get-current-color))

                (result #f))
            (apply set-current-color ,color)
            (set! result (begin ,@code))
            (apply set-current-color original-color)
            result))
                (result #f))
            (apply set-current-color ,color)
            (set! result (begin ,@code))
            (apply set-current-color original-color)
            result))

-       (else `(begin ,@code))))
+        (else (begin ,@code))))

 
 (define-macro (progn-textures . code)
   `(let ((result #f))
 
 (define-macro (progn-textures . code)
   `(let ((result #f))

-     (glEnable GL_TEXTURE_2D)
+     (gl-enable GL_TEXTURE_2D)

      (set! result (begin ,@code))
      (set! result (begin ,@code))

-     (glDisable GL_TEXTURE_2D)
+     (gl-disable GL_TEXTURE_2D)

      result))
 
 (define (draw . vertexes)
      result))
 
 (define (draw . vertexes)


@@ -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))
 (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))
 
 (define (draw-vertexes vertexes)
   (cond ((not (null? vertexes))


@@ -255,12 +256,8 @@
         (draw-vertexes (cdr vertexes)))))
 
 (define* (draw-vertex vertex #:key texture-coord)
         (draw-vertexes (cdr vertexes)))))
 
 (define* (draw-vertex vertex #:key texture-coord)

-  (cond ((list? (car vertex))
-        (with-color (car vertex)
-                    (apply simple-draw-vertex (cadr vertex))))
-       (else
-        (cond (texture-coord (apply glTexCoord2f texture-coord)))
-        (apply simple-draw-vertex vertex))))
+  (cond (texture-coord (apply glTexCoord2f texture-coord)))
+  (apply simple-draw-vertex vertex))

 
 (define* (simple-draw-vertex x y #:optional (z 0))
   (cond ((3d-mode?) (glVertex3f x y z))
 
 (define* (simple-draw-vertex x y #:optional (z 0))
   (cond ((3d-mode?) (glVertex3f x y z))


@@ -321,14 +318,19 @@
                           #:texture texture
                           #:texture-coord sprite)))))
 
                           #:texture texture
                           #:texture-coord sprite)))))
 

-(define* (draw-line length #:optional color)
+(define* (draw-line length)

   (let ((l (/ length 2)))
   (let ((l (/ length 2)))

-    (cond (color
-          (with-color color (draw (list 0 l) (list 0 (- l)))))
-         (else
-          (draw (list 0 l) (list 0 (- l)))))))
+    (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))))
+(define* (draw-quad v1 v2 v3 v4 #:key texture (texture-coord '((0 0) (1 1))))

   (cond (texture
         (progn-textures
          (glBindTexture GL_TEXTURE_2D texture)
   (cond (texture
         (progn-textures
          (glBindTexture GL_TEXTURE_2D texture)


@@ -338,41 +340,38 @@
          (draw-vertex v3 #:texture-coord (cadr texture-coord))
          (draw-vertex v4 #:texture-coord (list (caar texture-coord) (cadadr texture-coord)))
          (glEnd)))
          (draw-vertex v3 #:texture-coord (cadr texture-coord))
          (draw-vertex v4 #:texture-coord (list (caar texture-coord) (cadadr texture-coord)))
          (glEnd)))

-       (color
-        (with-color color (draw v1 v2 v3 v4)))

        (else
         (draw v1 v2 v3 v4))))
 
        (else
         (draw v1 v2 v3 v4))))
 

-(define* (draw-rectangle width height #:key texture color texture-coord)
+(define* (draw-rectangle width height #:key texture texture-coord)

   (let ((w (/ width 2)) (h (/ height 2)))
     (draw-quad (list (- w) h 0)
               (list w h 0)
               (list w (- h) 0)
               (list (- w) (- h) 0)
               #:texture texture
   (let ((w (/ width 2)) (h (/ height 2)))
     (draw-quad (list (- w) h 0)
               (list w h 0)
               (list w (- h) 0)
               (list (- w) (- h) 0)
               #:texture texture

-              #:texture-coord texture-coord
-              #:color color)))
+              #:texture-coord texture-coord)))

 
 

-(define* (draw-square #:key (size 1) texture color)
-  (draw-rectangle size size #:texture texture #:color color))
+(define* (draw-square size #:key texture)
+  (draw-rectangle size size #:texture texture))

 
 (define* (draw-cube #:key (size 1)
                   texture texture-1 texture-2 texture-3 texture-4 texture-5 texture-6
 
 (define* (draw-cube #:key (size 1)
                   texture texture-1 texture-2 texture-3 texture-4 texture-5 texture-6

-                  color color-1 color-2 color-3 color-4 color-5 color-6)
+                  color-1 color-2 color-3 color-4 color-5 color-6)

   (let ((-size (- size)))
     (progn-textures
      (glNormal3f 0 0 1)
   (let ((-size (- size)))
     (progn-textures
      (glNormal3f 0 0 1)

-     (draw-quad (list -size size size) (list size size size) (list size -size size) (list -size -size size) #:texture (or texture-1 texture) #:color (or color-1 color))
+     (with-color color-1 (draw-quad (list -size size size) (list size size size) (list size -size size) (list -size -size size) #:texture (or texture-1 texture)))

      (glNormal3f 0 0 -1)
      (glNormal3f 0 0 -1)

-     (draw-quad (list -size -size -size) (list size -size -size) (list size size -size) (list -size size -size) #:texture (or texture-2 texture) #:color (or color-2 color))
+     (with-color color-2 (draw-quad (list -size -size -size) (list size -size -size) (list size size -size) (list -size size -size) #:texture (or texture-2 texture)))

      (glNormal3f 0 1 0)
      (glNormal3f 0 1 0)

-     (draw-quad (list size size size) (list -size size size) (list -size size -size) (list size size -size) #:texture (or texture-3 texture) #:color (or color-3 color))
+     (with-color color-3 (draw-quad (list size size size) (list -size size size) (list -size size -size) (list size size -size) #:texture (or texture-3 texture)))

      (glNormal3f 0 -1 0)
      (glNormal3f 0 -1 0)

-     (draw-quad (list -size -size size) (list size -size size) (list size -size -size) (list -size -size -size) #:texture (or texture-4 texture) #:color (or color-4 color))
+     (with-color color-4 (draw-quad (list -size -size size) (list size -size size) (list size -size -size) (list -size -size -size) #:texture (or texture-4 texture)))

      (glNormal3f 1 0 0)
      (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-5 texture) #:color (or color-5 color))
+     (with-color color-5 (draw-quad (list size -size -size) (list size -size size) (list size size size) (list size size -size) #:texture (or texture-5 texture)))

      (glNormal3f -1 0 0)
      (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)))))
+     (with-color color-6 (draw-quad (list -size -size size) (list -size -size -size) (list -size size -size) (list -size size size) #:texture (or texture-6 texture))))))

 
 (define* (gtranslate x y #:optional (z 0))
   (glTranslatef x y z))
 
 (define* (gtranslate x y #:optional (z 0))
   (glTranslatef x y z))


@@ -395,13 +394,6 @@
   (glLoadIdentity)
   (cond ((3d-mode?) (camera-look))))
 
   (glLoadIdentity)
   (cond ((3d-mode?) (camera-look))))
 

-(define-macro (glmatrix-block . code)
-  `(let ((result #f))
-     (glPushMatrix)
-     (set! result (begin ,@code))
-     (glPopMatrix)
-     result))
-

 
 ;;; Lights
 
 
 ;;; Lights
 


@@ -410,7 +402,7 @@
 ;;   (and light (glLightfv id GL_DIFFUSE (car light) (cadr light) (caddr light) (cadddr light)))
 ;;   (and light position (glLightfv GL_POSITION (car position) (cadr position) (caddr position) (cadddr position)))
 ;;   (and ambient (glLightfv id GL_AMBIENT (car ambient) (cadr ambient) (caddr ambient) (cadddr ambient)))
 ;;   (and light (glLightfv id GL_DIFFUSE (car light) (cadr light) (caddr light) (cadddr light)))
 ;;   (and light position (glLightfv GL_POSITION (car position) (cadr position) (caddr position) (cadddr position)))
 ;;   (and ambient (glLightfv id GL_AMBIENT (car ambient) (cadr ambient) (caddr ambient) (cadddr ambient)))

-;;   (and turn-on (glEnable id))
+;;   (and turn-on (gl-enable id))

 ;;   id)
 
 
 ;;   id)
 
 


@@ -452,12 +444,10 @@
 
 (define mesh-type
   (make-record-type "mesh" 
 
 (define mesh-type
   (make-record-type "mesh" 

-                   '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!)
+                   '(draw translate turn rotate color inner-properties inner-property properties properties-set! property property-set!)

                    (lambda (record port)
                      (format port "#<mesh: ~a" (mesh-inner-property record 'type))
                    (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))))
 
                                (mesh-properties record))
                      (display ">" port))))
 


@@ -469,10 +459,14 @@
    (let ((px 0) (py 0) (pz 0)
         (ax 0) (ay 0) (az 0)
         (rx 0) (ry 0) (rz 0)
    (let ((px 0) (py 0) (pz 0)
         (ax 0) (ay 0) (az 0)
         (rx 0) (ry 0) (rz 0)

+        (color #f)

         (properties '()))
      (let ((inner-properties
            (lambda ()
         (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)))))
+             `((type . ,type) (color . ,color)
+               (x . ,px) (y . ,py) (z . ,pz)
+               (ax . ,ax) (ay . ,ay) (az . ,az)
+               (rx . ,rx) (ry . ,ry) (rz . ,rz)))))

        (list
        (lambda ()
          "draw"
        (list
        (lambda ()
          "draw"


@@ -480,7 +474,7 @@
           (grotate ax ay az)
           (gtranslate px py pz)
           (grotate rx ry rz)
           (grotate ax ay az)
           (gtranslate px py pz)
           (grotate rx ry rz)

-          (proc properties)))
+          (with-color color (proc properties))))

        (lambda (x y z)
          "translate"
          (set! px (+ px x))
        (lambda (x y z)
          "translate"
          (set! px (+ px x))


@@ -496,6 +490,9 @@
          (set! rx (+ rx x))
          (set! ry (+ ry y))
          (set! rz (+ rz z)))
          (set! rx (+ rx x))
          (set! ry (+ ry y))
          (set! rz (+ rz z)))

+       (lambda (c)
+         "color"
+         (set! color c))

        (lambda ()
          "inner-properties"
          (inner-properties))
        (lambda ()
          "inner-properties"
          (inner-properties))


@@ -554,23 +551,61 @@
             (list 0 0 (car params))))
   mesh)
 
             (list 0 0 (car params))))
   mesh)
 

+(define (color mesh c)
+  (((record-accessor mesh-type 'color) mesh) c)
+  mesh)
+
+
+;;; Advanced meshes
+
+(define (mesh-join . meshes)
+  (make-mesh
+   'joined-meshes
+   (lambda (props)
+     (for-each (lambda (m) (glmatrix-block (mesh-draw m))) meshes))))
+

 
 ;;; Primitives
 
 
 ;;; 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
        (let ((m (make-mesh

-                ',name
+                ',type

                 (lambda (props)
                 (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))))
 
         m))))
 

+(define-macro (define-primitive header . body)
+  `(define ,(car header) (primitive ,header ,@body)))
+
+
+;;; Primitives definition
+
+(define-primitive (square size #:key texture)
+  (draw-square size #:texture texture))
+
+(define-primitive (rectangle width height #:key texture texture-coord)
+  (draw-rectangle width height #:texture texture #: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))
                  (module-export! (current-module) (list sym))))
 
 (module-map (lambda (sym var)
              (if (not (eq? sym '%module-public-interface))
                  (module-export! (current-module) (list sym))))

-           (current-module))
+           (current-module))
\ No newline at end of file