Using guile-figl

[gacela.git] / src / video.scm

diff --git a/src/video.scm b/src/video.scm
index a9db7be0b7e03dce39f93e0c0bb611acbd9331a9..06e263d913c9b29d2b95054cd2183c86c8fde6cf 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 (enable-cap 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)
+  (set-gl-clear-depth 1)
+  (gl-enable (enable-cap depth-test))
+  (set-gl-depth-function (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,11 +166,11 @@
 
 
 (define (init-gl)
 
 
 (define (init-gl)

-  (glShadeModel GL_SMOOTH)
-  (glClearColor 0 0 0 0)
-  (glEnable GL_BLEND)
-  (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
-  (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST))
+  (set-gl-shade-model (shading-model smooth))
+  (set-gl-clear-color 0 0 0 0)
+  (gl-enable (enable-cap blend))
+  (set-gl-blend-function (blending-factor-dest src-alpha) (blending-factor-dest one-minus-src-alpha))
+  (glHint (hint-target perspective-correction-hint) (hint-mode nicest)))

 
 (define (resize-screen-GL width height)
   (glViewport 0 0 width height)
 
 (define (resize-screen-GL width height)
   (glViewport 0 0 width height)


@@ -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 size #:key 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,7 +444,7 @@
 
 (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))
                      (for-each (lambda (x) (format port " ~a" x))
                    (lambda (record port)
                      (format port "#<mesh: ~a" (mesh-inner-property record 'type))
                      (for-each (lambda (x) (format port " ~a" x))


@@ -467,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"


@@ -478,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))


@@ -494,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))


@@ -552,6 +551,10 @@
             (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
 
 
 ;;; Advanced meshes
 


@@ -589,11 +592,14 @@
 
 ;;; Primitives definition
 
 
 ;;; Primitives definition
 

-(define-primitive (square size #:key texture color)
-  (draw-square size #:texture texture #:color color))
+(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 (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))
 
 (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))


@@ -602,4 +608,4 @@
 (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