X-Git-Url: https://git.jsancho.org/?p=gacela.git;a=blobdiff_plain;f=src%2Fvideo.scm;h=1d423bbf9a2a38328e4ea0564cc333c03aeac718;hp=87ba9e0e43e78a42e9cb07784e7bd3f9560806fd;hb=c4a087c6e90ceeec5d9d3c164f51877e02609c8b;hpb=361f23e1a9ef0d905cc879f9a4b0a4832a1d4287 diff --git a/src/video.scm b/src/video.scm index 87ba9e0..1d423bb 100644 --- a/src/video.scm +++ b/src/video.scm @@ -17,12 +17,17 @@ (define-module (gacela video) #:use-module (gacela sdl) - #:use-module (gacela gl) +; #:use-module (gacela gl) + #:use-module (figl gl) + #:use-module (figl glx) + #:use-module (figl glu) #:use-module (gacela ftgl) #:use-module (gacela math) #:use-module (gacela utils) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) + #:use-module (srfi srfi-9) + #:use-module (system foreign) #:export (init-video get-screen-height get-screen-width @@ -47,7 +52,7 @@ get-current-color set-current-color with-color - progn-textures + with-textures draw load-texture load-texture-without-cache @@ -67,9 +72,7 @@ load-font load-font-without-texture render-text) - #:re-export (glPushMatrix - glPopMatrix) - #:export-syntax (glmatrix-block)) + #:re-export (with-gl-push-matrix)) @@ -118,7 +121,7 @@ (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)) @@ -138,14 +141,14 @@ (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) - (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?) @@ -166,24 +169,24 @@ (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)) + (set-gl-hint (hint-target perspective-correction-hint) (hint-mode nicest))) (define (resize-screen-GL width height) - (glViewport 0 0 width height) - (glMatrixMode GL_PROJECTION) - (glLoadIdentity) + (gl-viewport 0 0 width height) + (set-gl-matrix-mode (matrix-mode projection)) + (gl-load-identity) (cond ((3d-mode?) (let ((ratio (if (= height 0) width (/ width height)))) - (gluPerspective 45 ratio 0.1 100))) + (glu-perspective 45 ratio 0.1 100))) (else (let* ((w (/ width 2)) (h (/ height 2))) - (glOrtho (- w) w (- h) h 0 1)))) - (glMatrixMode GL_MODELVIEW) - (glLoadIdentity)) + (gl-ortho (- w) w (- h) h 0 1)))) + (set-gl-matrix-mode (matrix-mode modelview)) + (gl-load-identity)) ;;; Frames per second @@ -211,61 +214,22 @@ (SDL_Delay (- time-per-frame frame-time)))))) -;;; Drawing - -(define current-color '(1 1 1 1)) - -(define (get-current-color) - current-color) - -(define* (set-current-color red green blue #:optional (alpha 1)) - (set! current-color (list red green blue alpha)) - (glColor4f red green blue alpha)) +;;; Textures -(define-macro (with-color color . code) - (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)) - (else `(begin ,@code)))) +(define-record-type + (texture id width height) + texture? + (id texture-id) + (width texture-width set-texture-width) + (height texture-height set-texture-height)) -(define-macro (progn-textures . code) +(define-macro (with-textures . code) `(let ((result #f)) - (glEnable GL_TEXTURE_2D) + (gl-enable (oes-framebuffer-object texture-2d)) (set! result (begin ,@code)) - (glDisable GL_TEXTURE_2D) + (gl-disable (oes-framebuffer-object texture-2d)) result)) -(define (draw . vertexes) - (begin-draw (length vertexes)) - (draw-vertexes vertexes) - (glEnd)) - -(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)))) - -(define (draw-vertexes vertexes) - (cond ((not (null? vertexes)) - (draw-vertex (car vertexes)) - (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)))) - -(define* (simple-draw-vertex x y #:optional (z 0)) - (cond ((3d-mode?) (glVertex3f x y z)) - (else (glVertex2f x y)))) - (define (load-image filename) (let ((image (IMG_Load filename))) (cond (image @@ -289,93 +253,133 @@ (else (let ((zoomx (/ (+ width 0.5) old-width)) (zoomy (/ (+ height 0.5) old-height))) (zoomSurface surface zoomx zoomy 0)))))) -(define* (load-texture-without-cache filename #:key (min-filter GL_LINEAR) (mag-filter GL_LINEAR)) - (progn-textures +(define* (load-texture-without-cache filename #:key (min-filter (texture-min-filter linear)) (mag-filter (texture-mag-filter linear))) + (with-textures (receive (image real-w real-h) (load-image-for-texture filename) (cond (image - (let ((width (surface-w image)) (height (surface-h image)) - (byteorder (if (= SDL_BYTEORDER SDL_LIL_ENDIAN) - (if (= (surface-format-BytesPerPixel image) 3) GL_BGR GL_BGRA) - (if (= (surface-format-BytesPerPixel image) 3) GL_RGB GL_RGBA))) - (texture (car (glGenTextures 1)))) - - (glBindTexture GL_TEXTURE_2D texture) - (glTexImage2D GL_TEXTURE_2D 0 4 width height 0 byteorder GL_UNSIGNED_BYTE (surface-pixels image)) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER min-filter) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER mag-filter) - (set-texture-size! texture real-w real-h) - texture)))))) + (let ((width (surface-w image)) (height (surface-h image)) + (byteorder (if (= SDL_BYTEORDER SDL_LIL_ENDIAN) + (if (= (surface-format-BytesPerPixel image) 3) (ext-bgra bgr-ext) (ext-bgra bgra-ext)) + (if (= (surface-format-BytesPerPixel image) 3) (pixel-format rgb) (pixel-format rgba)))) + (texture-id (gl-generate-texture)) + (image-pointer (make-pointer + (if (> (surface-pixels image) 0) + (surface-pixels image) + (+ ($expt 2 32) (surface-pixels image)))))) + + (gl-bind-texture (oes-framebuffer-object texture-2d) texture-id) + (set-gl-texture-image (oes-framebuffer-object texture-2d) 0 4 0 byteorder (data-type unsigned-byte) image-pointer width height) + (set-gl-texture-parameter (oes-framebuffer-object texture-2d) (texture-parameter-name texture-min-filter) min-filter) + (set-gl-texture-parameter (oes-framebuffer-object texture-2d) (texture-parameter-name texture-mag-filter) mag-filter) + (texture texture-id real-w real-h))))))) (define load-texture (use-cache-with load-texture-without-cache)) -(define (get-texture-properties texture) - `((width . ,(texture-w texture)) (height . ,(texture-h texture)))) + +;;; Drawing + +(define current-color '(1 1 1 1)) + +(define (get-current-color) + current-color) + +(define* (set-current-color red green blue #:optional (alpha 1)) + (set! current-color (list red green blue alpha)) + (gl-color red green blue alpha)) + +(define-macro (with-color color . code) + `(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)) + (else (begin ,@code)))) + +(define (draw . vertexes) + (gl-begin + (let ((number-of-points (length vertexes))) + (cond ((= number-of-points 2) (begin-mode lines)) + ((= number-of-points 3) (begin-mode triangles)) + ((= number-of-points 4) (begin-mode quads)) + ((> number-of-points 4) (begin-mode polygon)))) + (draw-vertexes vertexes))) + +(define (draw-vertexes vertexes) + (cond ((not (null? vertexes)) + (apply draw-vertex (if (list? (caar vertexes)) (car vertexes) (list (car vertexes)))) + (draw-vertexes (cdr vertexes))))) + +(define* (draw-vertex vertex #:key texture-coord) + (cond (texture-coord (apply gl-texture-coordinates texture-coord))) + (apply gl-vertex vertex)) (define* (draw-texture texture #:key (zoom 1) (sprite '((0 0) (1 1)))) (cond (texture - (let ((width (texture-w texture)) - (height (texture-h texture))) + (let ((width (texture-width texture)) + (height (texture-height texture))) (draw-rectangle (* zoom width (- (caadr sprite) (caar sprite))) (* zoom height (- (cadadr sprite) (cadar sprite))) #:texture texture #:texture-coord sprite))))) -(define* (draw-line length #:optional color) +(define* (draw-line length) (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) + (gl-begin + (begin-mode polygon) + (do ((i 0 (1+ i))) + ((>= i 360)) + (let ((a (degrees-to-radians i))) + (draw-vertex (list (* radius (cos a)) (* radius (sin a)))))))) -(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) - (begin-draw 4) - (draw-vertex v1 #:texture-coord (car texture-coord)) - (draw-vertex v2 #:texture-coord (list (caadr texture-coord) (cadar texture-coord))) - (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))) + (with-textures + (gl-bind-texture (oes-framebuffer-object texture-2d) (texture-id texture)) + (draw (list v1 #:texture-coord (car texture-coord)) + (list v2 #:texture-coord (list (caadr texture-coord) (cadar texture-coord))) + (list v3 #:texture-coord (cadr texture-coord)) + (list v4 #:texture-coord (list (caar texture-coord) (cadadr texture-coord)))))) (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 - #: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 - 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) - (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)) - (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)) - (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)) - (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)) - (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)) - (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-textures + (gl-normal 0 0 1) + (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))) + (gl-normal 0 0 -1) + (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))) + (gl-normal 0 1 0) + (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))) + (gl-normal 0 -1 0) + (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))) + (gl-normal 1 0 0) + (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))) + (gl-normal -1 0 0) + (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)) + (gl-translate x y z)) (define (grotate . rot) (cond ((3d-mode?) @@ -384,24 +388,17 @@ (2d-rotate (car (last-pair rot)))))) (define (3d-rotate xrot yrot zrot) - (glRotatef xrot 1 0 0) - (glRotatef yrot 0 1 0) - (glRotatef zrot 0 0 1)) + (gl-rotate xrot 1 0 0) + (gl-rotate yrot 0 1 0) + (gl-rotate zrot 0 0 1)) (define (2d-rotate rot) - (glRotatef rot 0 0 1)) + (gl-rotate rot 0 0 1)) (define (to-origin) - (glLoadIdentity) + (gl-load-identity) (cond ((3d-mode?) (camera-look)))) -(define-macro (glmatrix-block . code) - `(let ((result #f)) - (glPushMatrix) - (set! result (begin ,@code)) - (glPopMatrix) - result)) - ;;; Lights @@ -410,7 +407,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 turn-on (glEnable id)) +;; (and turn-on (gl-enable id)) ;; id) @@ -426,7 +423,7 @@ (cond (up (set! camera-up up)))) (define (camera-look) - (apply gluLookAt (append camera-eye camera-center camera-up))) + (apply glu-look-at (append camera-eye camera-center camera-up))) ;;; Text and fonts @@ -452,7 +449,7 @@ (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 "#