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-begin (begin-mode quads)
  51          (gl-texture-coordinates 0 0)
  52          (gl-vertex (- w/2) h/2 0)
  53          (gl-texture-coordinates 1 0)
  54          (gl-vertex w/2 h/2 0)
  55          (gl-texture-coordinates 1 1)
  56          (gl-vertex w/2 (- h/2) 0)
  57          (gl-texture-coordinates 0 1)
  58          (gl-vertex (- w/2) (- h/2) 0))
  59        (gl-disable (oes-framebuffer-object texture-2d))))))
  60
  61 (define* (move scene x y #:optional (z 0))
  62   (make-scene
  63    "move"
  64    (lambda ()
  65      (gl-translate (calculate x)
  66                    (calculate y)
  67                    (calculate z))
  68      (display-scene scene))))
  69
  70 (define* (scale scene x #:optional (y x) (z y))
  71   (make-scene
  72    "scale"
  73    (lambda ()
  74      (gl-scale x y z)
  75      (display-scene scene))))
  76
  77 (define (over . scenes)
  78   (make-scene
  79    "over"
  80    (lambda ()
  81      (let display ((sc scenes))
  82        (cond ((not (null? sc))
  83               (with-gl-push-matrix
  84                (display-scene (car sc)))
  85               (display (cdr sc))))))))