]> git.jsancho.org Git - gacela.git/blob - gacela/image.scm
Merge tag '0.6' into develop
[gacela.git] / gacela / image.scm
1 ;;; Gacela, a GNU Guile extension for fast games development
2 ;;; Copyright (C) 2016 by Javier Sancho Fernandez <jsf at jsancho dot org>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation, either version 3 of the License, or
7 ;;; (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16
17
18 (define-module (gacela image)
19   #:use-module (gacela scene)
20   #:use-module (gacela game)
21   #:use-module ((sdl2) #:prefix sdl2:)
22   #:use-module ((sdl2 image) #:prefix sdl2:)
23   #:use-module ((sdl2 render) #:prefix sdl2:)
24   #:use-module ((sdl2 surface) #:prefix sdl2:)
25   #:use-module (gl)
26   #:export (image
27             move
28             scale
29             over))
30
31 (define (calculate proc-or-value)
32   (if (procedure? proc-or-value)
33       (proc-or-value)
34       proc-or-value))
35
36 (define (image filename)
37   (make-scene
38    "image"
39    (let ((image (sdl2:load-image filename))
40          (texture #f)
41          (w/2 0)
42          (h/2 0))
43      (lambda ()
44        (when (not texture)
45          (set! texture (sdl2:surface->texture %sdl-renderer image))
46          (set! w/2 (/ (sdl2:surface-width image) 2))
47          (set! h/2 (/ (sdl2:surface-height image) 2)))
48        (gl-enable (oes-framebuffer-object texture-2d))
49        (sdl2:bind-texture texture)
50        (gl-enable (oes-framebuffer-object blend))
51        (set-gl-blend-function (blending-factor-src src-alpha)
52                               (blending-factor-dest one-minus-src-alpha))
53        (gl-begin (begin-mode quads)
54          (gl-texture-coordinates 0 0)
55          (gl-vertex (- w/2) h/2 0)
56          (gl-texture-coordinates 1 0)
57          (gl-vertex w/2 h/2 0)
58          (gl-texture-coordinates 1 1)
59          (gl-vertex w/2 (- h/2) 0)
60          (gl-texture-coordinates 0 1)
61          (gl-vertex (- w/2) (- h/2) 0))
62        (gl-disable (oes-framebuffer-object blend))
63        (gl-disable (oes-framebuffer-object texture-2d))))))
64
65 (define* (move scene x y #:optional (z 0))
66   (make-scene
67    "move"
68    (lambda ()
69      (gl-translate (calculate x)
70                    (calculate y)
71                    (calculate z))
72      (display-scene scene))))
73
74 (define* (scale scene x #:optional (y x) (z y))
75   (make-scene
76    "scale"
77    (lambda ()
78      (gl-scale (calculate x)
79                (calculate y)
80                (calculate z))
81      (display-scene scene))))
82
83 (define (over . scenes)
84   (make-scene
85    "over"
86    (lambda ()
87      (let display ((sc scenes))
88        (cond ((not (null? sc))
89               (with-gl-push-matrix
90                (display-scene (car sc)))
91               (display (cdr sc))))))))