render: Add SDL_RenderDrawLine binding.
[guile-sdl2.git] / sdl2 / render.scm
1 ;;; guile-sdl2 --- FFI bindings for SDL2
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; This file is part of guile-sdl2.
5 ;;;
6 ;;; Guile-sdl2 is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation; either version 3 of the
9 ;;; License, or (at your option) any later version.
10 ;;;
11 ;;; Guile-sdl2 is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with guile-sdl2. If not, see
18 ;;; <http://www.gnu.org/licenses/>.
19
20 ;;; Commentary:
21 ;;
22 ;; SDL 2D accelerated rendering.
23 ;;
24 ;;; Code:
25
26 (define-module (sdl2 render)
27 #:use-module (ice-9 format)
28 #:use-module (ice-9 match)
29 #:use-module (system foreign)
30 #:use-module (sdl2)
31 #:use-module ((sdl2 bindings) #:prefix ffi:)
32 #:export (make-renderer
33 renderer?
34 delete-renderer!
35 call-with-renderer
36 clear-renderer
37 present-renderer
38 render-copy
39 set-render-draw-color
40 render-draw-line
41
42 surface->texture))
43
44 \f
45 ;;;
46 ;;; Renderer
47 ;;;
48
49 (define-wrapped-pointer-type <renderer>
50 renderer?
51 wrap-renderer unwrap-renderer
52 (lambda (context port)
53 (format port "#<renderer ~x>"
54 (pointer-address (unwrap-renderer context)))))
55
56 (define (renderer-flags->bitmask flags)
57 (apply logior
58 (map (match-lambda
59 ('software ffi:SDL_RENDERER_SOFTWARE)
60 ('accelerated ffi:SDL_RENDERER_ACCELERATED)
61 ('vsync ffi:SDL_RENDERER_PRESENTVSYNC)
62 ('texture ffi:SDL_RENDERER_TARGETTEXTURE))
63 flags)))
64
65 (define* (make-renderer window #:optional (flags '(accelerated vsync)))
66 "Return a new renderer for WINDOW created with the options specified
67 in FLAGS, a list of symbols. The valid symbols that may appear in
68 FLAGS are:
69
70 * software, to use a software renderer fallback
71 * accelerated, to use hardware acceleration
72 * vsync, to synchronize rendering with the monitor's refresh rate
73 * texture, for render to texture support"
74 (let ((ptr (ffi:sdl-create-renderer ((@@ (sdl2 video) unwrap-window)
75 window)
76 -1 ; pick driver automatically
77 (renderer-flags->bitmask flags))))
78 (if (null-pointer? ptr)
79 (sdl-error "make-renderer" "failed to create renderer")
80 (wrap-renderer ptr))))
81
82 (define (delete-renderer! renderer)
83 "Delete the rendering context RENDERER."
84 (ffi:sdl-destroy-renderer (unwrap-renderer renderer)))
85
86 (define (call-with-renderer renderer proc)
87 "Call PROC, passing it RENDERER and closing RENDERER upon exit of
88 PROC."
89 (dynamic-wind
90 (const #t)
91 (lambda ()
92 (proc renderer))
93 (lambda ()
94 (delete-renderer! renderer))))
95
96 (define (clear-renderer renderer)
97 "Clear the rendering target RENDERER with the current drawing
98 color."
99 (unless (zero? (ffi:sdl-render-clear (unwrap-renderer renderer)))
100 (sdl-error "clear-renderer!" "failed to clear renderer")))
101
102 (define (present-renderer renderer)
103 "Display RENDERER."
104 (ffi:sdl-render-present (unwrap-renderer renderer)))
105
106 (define (set-render-draw-color renderer r g b a)
107 "Set draw color of RENDERER."
108 (ffi:sdl-set-render-draw-color (unwrap-renderer renderer) r g b a))
109
110 (define (render-draw-line renderer x1 y1 x2 y2)
111 "Draw line on RENDERER."
112 (ffi:sdl-render-draw-line (unwrap-renderer renderer) x1 y1 x2 y2))
113
114 \f
115 ;;;
116 ;;; Texture
117 ;;;
118
119 (define-wrapped-pointer-type <texture>
120 texture?
121 wrap-texture unwrap-texture
122 (lambda (context port)
123 (format port "#<texture ~x>"
124 (pointer-address (unwrap-texture context)))))
125
126 (define (surface->texture renderer surface)
127 "Convert SURFACE to a texture suitable for RENDERER."
128 (let ((ptr (ffi:sdl-create-texture-from-surface
129 (unwrap-renderer renderer)
130 ((@@ (sdl2 surface) unwrap-surface) surface))))
131 (if (null-pointer? ptr)
132 (sdl-error "surface->texture" "failed to convert surface to texture")
133 (wrap-texture ptr))))
134
135
136 (define* (render-copy renderer texture
137 #:key (angle 0) srcrect dstrect center)
138 "Copy TEXTURE to the rendering target of RENDERER."
139 (let ((result (ffi:sdl-render-copy-ex
140 (unwrap-renderer renderer)
141 (unwrap-texture texture)
142 (if srcrect
143 (make-c-struct ffi:sdl-rect srcrect)
144 %null-pointer)
145 (if dstrect
146 (make-c-struct ffi:sdl-rect dstrect)
147 %null-pointer)
148 angle
149 (if center
150 (make-c-struct ffi:sdl-point center)
151 %null-pointer)
152 0)))
153 (unless (zero? result)
154 (sdl-error "render-copy" "failed to copy texture"))))