X-Git-Url: https://git.jsancho.org/?p=gacela.git;a=blobdiff_plain;f=src%2Fvideo.scm;h=0b49679605ce0e2082ee15da3cea7b0b8dad442c;hp=3e5553dd816357c6f862bb50af35d2e3592cdd8e;hb=525f2b2cd2b56afe6eca25a67ebb93eed3f69403;hpb=9c14da6c19a2e29a1db346df5c746bfcd2680afb diff --git a/src/video.scm b/src/video.scm index 3e5553d..0b49679 100644 --- a/src/video.scm +++ b/src/video.scm @@ -17,7 +17,9 @@ (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) @@ -67,9 +69,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 +118,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 +138,14 @@ (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) - (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?) @@ -166,9 +166,9 @@ (define (init-gl) - (glShadeModel GL_SMOOTH) + (set-gl-shade-model GL_SMOOTH) (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)) @@ -223,20 +223,20 @@ (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)) - (else `(begin ,@code)))) + (else (begin ,@code)))) (define-macro (progn-textures . code) `(let ((result #f)) - (glEnable GL_TEXTURE_2D) + (gl-enable GL_TEXTURE_2D) (set! result (begin ,@code)) - (glDisable GL_TEXTURE_2D) + (gl-disable GL_TEXTURE_2D) 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)) - ((= 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)) @@ -255,12 +256,8 @@ (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)) @@ -321,14 +318,19 @@ #: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) + (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) @@ -338,46 +340,43 @@ (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)))) -(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 #: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 - 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)) + (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) - (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) - (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) - (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) - (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) - (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* (translate x y #:optional (z 0)) +(define* (gtranslate x y #:optional (z 0)) (glTranslatef x y z)) -(define (rotate . rot) +(define (grotate . rot) (cond ((3d-mode?) (apply 3d-rotate rot)) (else @@ -395,13 +394,6 @@ (glLoadIdentity) (cond ((3d-mode?) (camera-look)))) -(define-macro (glmatrix-block . code) - `(let ((result #f)) - (glPushMatrix) - (set! result (begin ,@code)) - (glPopMatrix) - result)) - ;;; 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 turn-on (glEnable id)) +;; (and turn-on (gl-enable id)) ;; id) @@ -446,3 +438,174 @@ ((not (= (ftglGetFontFaceSize font) (font-size font))) (ftglSetFontFaceSize font (font-size font) 72))) (ftglRenderFont font text FTGL_RENDER_ALL)) + + +;;; Meshes + +(define mesh-type + (make-record-type "mesh" + '(draw translate turn rotate color inner-properties inner-property properties properties-set! property property-set!) + (lambda (record port) + (format port "#" port)))) + +(define mesh? (record-predicate mesh-type)) + +(define* (make-mesh type proc) + (apply + (record-constructor mesh-type) + (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 () + `((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" + (glmatrix-block + (grotate ax ay az) + (gtranslate px py pz) + (grotate rx ry rz) + (with-color color (proc properties)))) + (lambda (x y z) + "translate" + (set! px (+ px x)) + (set! py (+ py y)) + (set! pz (+ pz z))) + (lambda (x y z) + "turn" + (set! ax (+ ax x)) + (set! ay (+ ay y)) + (set! az (+ az z))) + (lambda (x y z) + "rotate" + (set! rx (+ rx x)) + (set! ry (+ ry y)) + (set! rz (+ rz z))) + (lambda (c) + "color" + (set! color c)) + (lambda () + "inner-properties" + (inner-properties)) + (lambda (prop-name) + "inner-property" + (assoc-ref (inner-properties) prop-name)) + (lambda () + "properties" + properties) + (lambda (new-properties) + "properties-set!" + (set! properties new-properties)) + (lambda (prop-name) + "property" + (assoc-ref properties prop-name)) + (lambda (prop-name value) + "property-set!" + (set! properties (assoc-set! properties prop-name value)))))))) + +(define (mesh-draw mesh) + (((record-accessor mesh-type 'draw) mesh))) + +(define (mesh-inner-properties mesh) + (((record-accessor mesh-type 'inner-properties) mesh))) + +(define (mesh-inner-property mesh prop-name) + (((record-accessor mesh-type 'inner-property) mesh) prop-name)) + +(define (mesh-properties mesh) + (((record-accessor mesh-type 'properties) mesh))) + +(define (mesh-properties-set! mesh new-properties) + (((record-accessor mesh-type 'properties-set!) mesh) new-properties)) + +(define (mesh-property mesh prop-name) + (((record-accessor mesh-type 'property) mesh) prop-name)) + +(define (mesh-property-set! mesh prop-name value) + (((record-accessor mesh-type 'property-set!) mesh) prop-name value)) + +(define* (translate mesh x y #:optional (z 0)) + (((record-accessor mesh-type 'translate) mesh) x y z) + mesh) + +(define (turn mesh . params) + (apply ((record-accessor mesh-type 'turn) mesh) + (if (>= (length params) 3) + params + (list 0 0 (car params)))) + mesh) + +(define (rotate mesh . params) + (apply ((record-accessor mesh-type 'rotate) mesh) + (if (>= (length params) 3) + params + (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 + +(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) + (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)))) + (current-module)) \ No newline at end of file