summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.dir-locals.el20
-rw-r--r--Makefile.am1
-rwxr-xr-xexamples/2048/2048.scm140
-rw-r--r--examples/animation.scm23
-rw-r--r--examples/font.scm39
-rw-r--r--examples/joystick.scm34
-rw-r--r--examples/life.scm53
-rw-r--r--examples/mines/mines.scm86
-rw-r--r--examples/simple.scm21
-rw-r--r--examples/tilemap.scm19
-rw-r--r--sly.scm4
-rw-r--r--sly/game.scm18
-rw-r--r--sly/render.scm373
-rw-r--r--sly/render/camera.scm127
-rw-r--r--sly/render/font.scm10
-rw-r--r--sly/render/shader.scm79
-rw-r--r--sly/render/sprite.scm54
-rw-r--r--sly/render/texture.scm10
-rw-r--r--sly/render/tile-map.scm21
-rw-r--r--sly/render/viewport.scm92
20 files changed, 797 insertions, 427 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 0000000..57fd98f
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,20 @@
+((scheme-mode
+ .
+ ((eval . (put 'call-with-transform-excursion 'scheme-indent-function 1))
+ (eval . (put 'with-transform-excursion 'scheme-indent-function 1))
+ (eval . (put 'graphics-model-view-excursion 'scheme-indent-function 1))
+ (eval . (put 'graphics-projection-excursion 'scheme-indent-function 1))
+ (eval . (put 'graphics-uniform-excursion 'scheme-indent-function 2))
+ (eval . (put 'graphics-mesh-excursion 'scheme-indent-function 1))
+ (eval . (put 'with-blend-mode 'scheme-indent-function 1))
+ (eval . (put 'with-depth-test 'scheme-indent-function 1))
+ (eval . (put 'with-texture 'scheme-indent-function 1))
+ (eval . (put 'with-shader 'scheme-indent-function 1))
+ (eval . (put 'with-mesh 'scheme-indent-function 1))
+ (eval . (put 'with-framebuffer 'scheme-indent-function 1))
+ (eval . (put 'with-viewport 'scheme-indent-function 1))
+ (eval . (put 'with-projection-mul 'scheme-indent-function 1))
+ (eval . (put 'with-model-view-mul 'scheme-indent-function 1))
+ (eval . (put 'with-camera 'scheme-indent-function 1))
+ (eval . (put 'with-color 'scheme-indent-function 1))
+ (eval . (put 'uniform-let 'scheme-indent-function 1)))))
diff --git a/Makefile.am b/Makefile.am
index f7aa9cf..a4d6ec5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -55,6 +55,7 @@ SOURCES = \
sly/render/sprite.scm \
sly/render/tileset.scm \
sly/render/tile-map.scm \
+ sly/render/viewport.scm \
sly/render.scm \
sly/render/model.scm \
sly/render/scene.scm \
diff --git a/examples/2048/2048.scm b/examples/2048/2048.scm
index 97922de..05eb78b 100755
--- a/examples/2048/2048.scm
+++ b/examples/2048/2048.scm
@@ -33,11 +33,10 @@
(sly math transform)
(sly math tween)
(sly math vector)
+ (sly render)
(sly render camera)
(sly render color)
(sly render font)
- (sly render model)
- (sly render scene)
(sly render sprite)
(sly render texture)
(sly input keyboard)
@@ -310,26 +309,29 @@
(define (tile-text-color n)
(assoc-ref (assoc-ref tile-properties n) 'text-color))
-(define tile-sprite (make-sprite tile-texture #:anchor (vector2 0 0)))
+(define tile-sprite
+ (make-sprite tile-texture #:anchor (vector2 0 0)))
(define tile-label-cache
(map (lambda (n)
- (cons n (label font (number->string n) #:anchor 'center)))
+ (cons n (make-label font (number->string n) #:anchor 'center)))
'(2 4 8 16 32 64 128 256 512 1024 2048)))
-(define (make-tile x y n)
- (let* ((w (texture-width tile-texture))
- (h (texture-height tile-texture))
- (label (assoc-ref tile-label-cache n))
- (label-color (tile-text-color n))
- (bg-color (tile-bg-color n))
- (tile (model-group (model-paint bg-color tile-sprite)
- (if (zero? n)
- null-model
- (chain label
- (model-paint label-color)
- (model-move (vector2 (/ w 2) (/ h 2))))))))
- (model-move (vector2 (* x w) (* y h)) tile)))
+(define (render-tile x y n)
+ (let ((w (texture-width tile-texture))
+ (h (texture-height tile-texture))
+ (label (assoc-ref tile-label-cache n))
+ (label-color (tile-text-color n))
+ (bg-color (tile-bg-color n)))
+ (move (vector2 (* x w) (* y h))
+ (render-begin
+ (with-color bg-color
+ (render-sprite tile-sprite))
+ (if (zero? n)
+ render-nothing
+ (with-color label-color
+ (move (vector2 (/ w 2) (/ h 2))
+ (render-sprite label))))))))
(define window-width 640)
(define window-height 480)
@@ -343,29 +345,33 @@
(define (enumerate-board board)
(enumerate (map (cut enumerate <>) board)))
+(define (render-board board)
+ (list->renderer
+ (append-map
+ (match-lambda
+ ((y (row ...))
+ (map (match-lambda
+ ((x n)
+ (render-tile x y n)))
+ row)))
+ (enumerate-board board))))
+
(define-signal tiles
- (signal-map (lambda (board)
- (list->model
- (append-map
- (match-lambda
- ((y (row ...))
- (map (match-lambda
- ((x n)
- (make-tile x y n)))
- row)))
- (enumerate-board board))))
- board))
+ (signal-map render-board board))
(define play-again-font (load-default-font 16))
+(define (render-label font text anchor)
+ (with-color black
+ (render-sprite
+ (make-label font text #:anchor anchor))))
+
(define-signal status-message
- (let ((play-again (model-paint black (label play-again-font
- "Press N to play again"
- #:anchor 'top-center)))
- (game-over (model-paint black (label font "GAME OVER"
- #:anchor 'bottom-center)))
- (you-win (model-paint black (label font "YOU WIN!"
- #:anchor 'bottom-center))))
+ (let ((play-again (render-label play-again-font
+ "Press N to play again"
+ 'top-center))
+ (game-over (render-label font "GAME OVER" 'bottom-center))
+ (you-win (render-label font "YOU WIN!" 'bottom-center)))
(signal-map
(lambda (board)
(let ((message (cond
@@ -373,10 +379,10 @@
((board-win? board) you-win)
(else #f))))
(if message
- (model-move (vector2 (/ board-width 2)
- (/ board-height 2))
- (model-group message play-again))
- null-model)))
+ (move (vector2 (/ board-width 2)
+ (/ board-height 2))
+ (render-begin message play-again))
+ render-nothing)))
board)))
(define instruction-font (load-default-font 16))
@@ -385,11 +391,12 @@
"Use the arrow keys to join the numbers and get to the 2048 tile!")
(define-signal instructions
- (chain (label instruction-font instruction-text
- #:anchor 'top-center)
- (model-paint text-color-1)
- (model-move (vector2 (/ board-width 2)
- (- window-height (vy center-pos))))))
+ (with-color text-color-1
+ (move (vector2 (/ board-width 2)
+ (- window-height (vy center-pos)))
+ (render-sprite
+ (make-label instruction-font instruction-text
+ #:anchor 'top-center)))))
(define score-header-font (load-default-font 14))
(define score-font (load-default-font 22))
@@ -401,18 +408,19 @@
(tween vlerp ease-linear from to duration)))
(color-tween (tween color-lerp ease-linear
transparent text-color-1 duration))
- (header (label score-header-font text #:anchor 'top-center)))
+ (header (make-label score-header-font text #:anchor 'top-center)))
(signal-let* ((score (signal-drop-repeats score))
(timer (signal-drop (lambda (t) (> t duration))
0 (signal-since 1 score))))
- (let ((score (label score-font (number->string score)
- #:anchor 'center)))
- (model-move (vector2 x (- window-height 28))
- (model-group
- (model-paint text-color-1 header)
- (chain score
- (model-paint (color-tween timer))
- (model-move (position-tween timer)))))))))
+ (let ((score (make-label score-font (number->string score)
+ #:anchor 'center)))
+ (move (vector2 x (- window-height 28))
+ (render-begin
+ (with-color text-color-1
+ (render-sprite header))
+ (move (position-tween timer)
+ (with-color (color-tween timer)
+ (render-sprite score)))))))))
(define-signal score
(score-label "SCORE" (signal-map 2048-score 2048-state) (/ board-width 4)))
@@ -421,20 +429,26 @@
(score-label "BEST" (signal-map 2048-best-score 2048-state)
(- board-width (/ board-width 4))))
-(define-signal 2048-model
- (signal-map (cut model-move center-pos <>)
- (signal-map model-group
- instructions tiles score best-score status-message)))
+(define-signal 2048-view
+ (signal-let ((instructions instructions)
+ (tiles tiles)
+ (score score)
+ (best-score best-score)
+ (status-message status-message))
+ (move center-pos
+ (render-begin
+ instructions
+ tiles
+ score
+ best-score
+ status-message))))
(define camera
- (let ((viewport (make-viewport (make-rect 0 0 640 480)
- #:clear-color background)))
- (orthographic-camera window-width window-height
- #:viewport viewport)))
+ (2d-camera #:area (make-rect 0 0 640 480) #:clear-color background))
(define-signal 2048-scene
- (signal-let ((model 2048-model))
- (make-scene camera model)))
+ (signal-let ((view 2048-view))
+ (with-camera camera view)))
;;;
;;; Initialization
diff --git a/examples/animation.scm b/examples/animation.scm
index 5dc9166..8aaff2e 100644
--- a/examples/animation.scm
+++ b/examples/animation.scm
@@ -15,25 +15,29 @@
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
-(use-modules (sly game)
+(use-modules (sly utils)
+ (sly game)
(sly window)
(sly signal)
(sly math)
+ (sly math rect)
(sly math tween)
(sly math vector)
+ (sly render)
(sly render camera)
- (sly render model)
(sly render sprite)
- (sly render tileset)
- (sly render scene))
+ (sly render tileset))
(load "common.scm")
+(define sprite* (memoize make-sprite))
+(define move* (memoize move))
+
(define walk-cycle
(let ((tiles (load-tileset "images/princess.png" 64 64)))
(list->vector
(map (lambda (id)
- (sprite (tileset-ref tiles id)))
+ (sprite* (tileset-ref tiles id)))
'(19 20 21 22 23 24 25 26)))))
(define position-tween
@@ -46,13 +50,14 @@
(tween (compose floor lerp) (compose ease-linear ease-loop)
0 frame-count (* frame-count frame-rate))))
-(define camera (orthographic-camera 640 480))
+(define camera (2d-camera #:area (make-rect 0 0 640 480)))
(define-signal scene
(signal-let ((time (signal-timer)))
- (let* ((frame (vector-ref walk-cycle (frame-tween time)))
- (model (model-move (position-tween time) frame)))
- (make-scene camera model))))
+ (let* ((frame (vector-ref walk-cycle (frame-tween time))))
+ (with-camera camera
+ (move* (position-tween time)
+ (render-sprite frame))))))
(with-window (make-window #:title "Animation")
(run-game-loop scene))
diff --git a/examples/font.scm b/examples/font.scm
index 4d481d3..64d32e0 100644
--- a/examples/font.scm
+++ b/examples/font.scm
@@ -20,39 +20,44 @@
(sly signal)
(sly window)
(sly math vector)
+ (sly render)
(sly render camera)
(sly render color)
(sly render font)
- (sly render model)
- (sly render scene)
+ (sly render sprite)
+ (sly render texture)
(sly input mouse))
(load "common.scm")
(define font (load-default-font 18))
-(define-signal message-label
- (model-move (vector2 320 240)
- (label font "The quick brown fox jumped over the lazy dog."
- #:anchor 'center)))
+(define camera (2d-camera #:area (make-rect 0 0 640 480)))
-(define-signal fps-label
+(define-signal render-message
+ (move (vector2 320 240)
+ (render-sprite
+ (make-label font "The quick brown fox jumped over the lazy dog."
+ #:anchor 'center))))
+
+(define-signal render-fps
(signal-let ((fps fps))
(let ((text (format #f "FPS: ~d" fps)))
- (model-move (vector2 0 480) (label font text)))))
+ (move (vector2 0 480)
+ (render-sprite (make-label font text))))))
-(define-signal mouse-label
- (signal-let ((pos (signal-throttle 5 mouse-position)))
+(define-signal render-mouse
+ (signal-let ((pos (signal-throttle 10 mouse-position)))
(let ((text (format #f "Mouse: (~d, ~d)" (vx pos) (vy pos))))
- (model-move (vector2 0 460) (label font text)))))
-
-(define-signal model
- (signal-map model-group message-label fps-label mouse-label))
-
-(define camera (orthographic-camera 640 480))
+ (move (vector2 0 460)
+ (render-sprite (make-label font text))))))
(define-signal scene
- (signal-map (lambda (model) (make-scene camera model)) model))
+ (signal-let ((message render-message)
+ (fps render-fps)
+ (mouse render-mouse))
+ (with-camera camera
+ (render-begin message fps mouse))))
(with-window (make-window #:title "Fonts")
(run-game-loop scene))
diff --git a/examples/joystick.scm b/examples/joystick.scm
index a191de5..661b18e 100644
--- a/examples/joystick.scm
+++ b/examples/joystick.scm
@@ -1,5 +1,6 @@
;;; Sly
;;; Copyright (C) 2014 Jordan Russell <jordan.likes.curry@gmail.com>
+;;; Copyright (C) 2015 David Thompson <davet@gnu.org>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
@@ -17,21 +18,21 @@
;;; Commentary:
;;
-;; Joystick example code
+;; Joystick example code.
;;
;;; Code:
(use-modules (sly game)
(sly signal)
(sly window)
+ (sly math rect)
(sly math vector)
(sly input joystick)
+ (sly render)
(sly render camera)
- (sly render model)
(sly render sprite)
(sly render texture)
- (sly render font)
- (sly render scene))
+ (sly render font))
(load "common.scm")
@@ -42,7 +43,10 @@
(define resolution (vector2 640 480))
-(define player (load-sprite "images/p1_front.png"))
+(define player-texture
+ (load-texture "images/p1_front.png"))
+
+(define player (make-sprite player-texture))
(define-signal player-position
(signal-fold v+ (vector2 320 240)
@@ -56,7 +60,8 @@
(define-signal caption
(signal-map (lambda (text)
- (model-move (vector2 -76 -90) (label font text)))
+ (move (vector2 -76 -90)
+ (render-sprite (make-label font text))))
(signal-merge
(make-signal "Press a button")
(button-caption-signal "Hello there" 0)
@@ -64,15 +69,20 @@
(button-caption-signal "This is the other caption" 2)
(button-caption-signal "This is the other other caption" 3))))
-(define-signal model
- (signal-map (lambda (position caption)
- (model-move position (model-group player caption)))
- player-position caption))
+(define-signal view
+ (signal-let ((position player-position)
+ (caption caption))
+ (move position
+ (render-begin
+ (render-sprite player)
+ caption))))
-(define camera (orthographic-camera (vx resolution) (vy resolution)))
+(define camera
+ (2d-camera #:area (make-rect (vector2 0 0) resolution)))
(define-signal scene
- (signal-map (lambda (model) (make-scene camera model)) model))
+ (signal-let ((view view))
+ (with-camera camera view)))
(add-hook! joystick-axis-hook
(lambda (which axis value)
diff --git a/examples/life.scm b/examples/life.scm
index 2842690..2d4e30a 100644
--- a/examples/life.scm
+++ b/examples/life.scm
@@ -1,6 +1,6 @@
;;; Life, Sly edition
;;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
-;;; Copyright (C) 2014 David Thompson <davet@gnu.org>
+;;; Copyright (C) 2014, 2015 David Thompson <davet@gnu.org>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
@@ -30,11 +30,10 @@
(sly math rect)
(sly math transform)
(sly math vector)
+ (sly render)
(sly render camera)
- (sly render model)
(sly render sprite)
(sly render color)
- (sly render scene)
(sly input mouse))
;;;
@@ -68,15 +67,17 @@
(define tile-size 32)
(define window-res (vector2 448 480))
+(define alive-texture
+ (load-texture "mines/images/tile-down.png"))
+
+(define empty-texture
+ (load-texture "mines/images/tile-up.png"))
+
(define sprite-cell-alive
- (load-sprite
- "mines/images/tile-down.png"
- #:anchor 'bottom-left))
+ (make-sprite alive-texture #:anchor 'bottom-left))
(define sprite-cell-empty
- (load-sprite
- "mines/images/tile-up.png"
- #:anchor 'bottom-left))
+ (make-sprite empty-texture #:anchor 'bottom-left))
;;;
;;; State
@@ -106,10 +107,7 @@
;; Give a heartbeat indicating it's time to run an evolution on the board
;; (if the simulation is running)
(define-signal time-to-evolve
- (signal-map
- (lambda _
- 'evolve)
- (signal-every 20)))
+ (signal-constant 'evolve (signal-every 20)))
(define (tile-on-board? x y board-size)
"Is the tile on the board?"
@@ -295,17 +293,18 @@ If there is no neighbor on an edge, the board wraps around"
(define-signal tiles-view
(signal-let ((board board)
(board-size board-size))
- (list->model
+ (list->renderer
(enumerate-map
(lambda (row row-count)
- (list->model
+ (list->renderer
(enumerate-map
(lambda (tile-alive col-count)
- (model-move (tile-pos row-count col-count
- board-size tile-size)
- (if tile-alive
- sprite-cell-alive
- sprite-cell-empty)))
+ (move (tile-pos row-count col-count
+ board-size tile-size)
+ (render-sprite
+ (if tile-alive
+ sprite-cell-alive
+ sprite-cell-empty))))
(vlist->list row))))
;; FIXME:
;; This slows things down more than it should have to
@@ -314,17 +313,13 @@ If there is no neighbor on an edge, the board wraps around"
(define-signal camera
(signal-let ((running? simulation-running?))
- (orthographic-camera
- (vx window-res) (vy window-res)
- #:viewport (make-viewport (make-rect (vector2 0 0) window-res)
- #:clear-color (if running?
- tango-dark-chameleon
- tango-dark-scarlet-red)))))
+ (2d-camera #:area (make-rect (vector2 0 0) window-res)
+ #:clear-color (if running?
+ tango-dark-chameleon
+ tango-dark-scarlet-red))))
(define-signal scene
- (signal-let ((model tiles-view)
- (camera camera))
- (make-scene camera model)))
+ (signal-map with-camera camera tiles-view))
;;;
;;; Initialization
diff --git a/examples/mines/mines.scm b/examples/mines/mines.scm
index 3a9ee7d..0b55d8b 100644
--- a/examples/mines/mines.scm
+++ b/examples/mines/mines.scm
@@ -34,12 +34,12 @@
(sly math rect)
(sly math transform)
(sly math vector)
+ (sly render)
(sly render camera)
(sly render color)
(sly render font)
- (sly render model)
(sly render sprite)
- (sly render scene)
+ (sly render texture)
(sly input keyboard)
(sly input mouse))
@@ -296,9 +296,11 @@
(define sprites
(map (match-lambda
((key . config)
- (cons key (load-sprite
- (string-append "images/" (assoc-ref config 'name) ".png")
- #:anchor (assoc-ref config 'anchor)))))
+ (let ((sprite (load-sprite (string-append "images/"
+ (assoc-ref config 'name)
+ ".png")
+ #:anchor (assoc-ref config 'anchor))))
+ (cons key sprite))))
'((1 . ((name . "1-mine")
(anchor . center)))
(2 . ((name . "2-mines")
@@ -348,57 +350,55 @@
(else #f))
sprite-ref))
-(define draw-tile
- (let ((offset (translate (vector2 (/ tile-size 2) (/ tile-size 2)))))
+(define render-tile
+ (let ((offset (vector2 (/ tile-size 2) (/ tile-size 2))))
(lambda (tile)
- (model-group (tile-base-sprite tile)
- (let ((overlay (tile-overlay-sprite tile)))
- (if overlay
- (model-place offset overlay)
- null-model))))))
+ (render-begin
+ (render-sprite (tile-base-sprite tile))
+ (let ((overlay (tile-overlay-sprite tile)))
+ (if overlay
+ (move offset (render-sprite overlay))
+ render-nothing))))))
(define-signal board-view
(signal-let ((board board))
- (define (draw-column tile x)
- (model-move (vector2 (* x tile-size) 0)
- (draw-tile tile)))
+ (define (render-column tile x)
+ (move (vector2 (* x tile-size) 0)
+ (render-tile tile)))
- (define (draw-row row y)
- (chain (enumerate-map draw-column row)
- (list->model)
- (model-move (vector2 0 (* y tile-size)))))
+ (define (render-row row y)
+ (move (vector2 0 (* y tile-size))
+ (list->renderer (enumerate-map render-column row))))
- (list->model (enumerate-map draw-row board))))
+ (list->renderer (enumerate-map render-row board))))
-(define-signal status-message
- (signal-let ((board board))
- (define (make-message message)
- (label font message #:anchor 'center))
+(define (render-message message)
+ (move (vector2 (/ (vx resolution) 2)
+ (- (vy resolution) 64))
+ (render-sprite
+ (make-label font message #:anchor 'center))))
- (model-move
- (vector2 (/ (vx resolution) 2) (- (vy resolution) 64))
- (list->model
+(define-signal status-message
+ (let ((game-over (render-message "GAME OVER - Press N to play again"))
+ (you-win (render-message "YOU WIN! - Press N to play again")))
+ (signal-let ((board board))
(cond
- ((board-lose? board)
- (list (make-message "GAME OVER - Press N to play again")))
- ((board-win? board)
- (list (make-message "YOU WIN! - Press N to play again")))
- (else '()))))))
-
-(define-signal model
- (signal-let ((view board-view)
- (status status-message)
- (center center-position))
- (model-group status (model-move center view))))
+ ((board-lose? board) game-over)
+ ((board-win? board) you-win)
+ (else render-nothing)))))
(define camera
- (orthographic-camera
- (vx resolution) (vy resolution)
- #:viewport (make-viewport (make-rect (vector2 0 0) resolution)
- #:clear-color tango-dark-plum)))
+ (2d-camera #:area (make-rect (vector2 0 0) resolution)
+ #:clear-color tango-dark-plum))
(define-signal scene
- (signal-map (lambda (model) (make-scene camera model)) model))
+ (signal-let ((view board-view)
+ (status status-message)
+ (center center-position))
+ (with-camera camera
+ (render-begin
+ status
+ (move center view)))))
;;;
;;; Initialization
diff --git a/examples/simple.scm b/examples/simple.scm
index e4de293..0f3760b 100644
--- a/examples/simple.scm
+++ b/examples/simple.scm
@@ -1,5 +1,5 @@
;;; Sly
-;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>
+;;; Copyright (C) 2013, 2014, 2015 David Thompson <dthompson2@worcester.edu>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
@@ -19,22 +19,23 @@
(sly window)
(sly utils)
(sly signal)
+ (sly math rect)
(sly math vector)
+ (sly render)
(sly render camera)
- (sly render model)
- (sly render sprite)
(sly render color)
- (sly render scene))
+ (sly render shader)
+ (sly render sprite)
+ (sly render texture))
(load "common.scm")
-(define model
- (model-move (vector2 320 240)
- (load-sprite "images/p1_front.png")))
-
-(define camera (orthographic-camera 640 480))
+(define sprite (load-sprite "images/p1_front.png"))
-(define-signal scene (make-scene camera model))
+(define-signal scene
+ (with-camera (2d-camera #:area (make-rect 0 0 640 480))
+ (move (vector2 320 240)
+ (render-sprite sprite))))
(with-window (make-window #:title "Simple Sprite Demo")
(run-game-loop scene))
diff --git a/examples/tilemap.scm b/examples/tilemap.scm
index 7c32b11..2e6bdf9 100644
--- a/examples/tilemap.scm
+++ b/examples/tilemap.scm
@@ -24,16 +24,15 @@
(sly window)
(sly signal)
(sly utils)
+ (sly render)
(sly render camera)
(sly render color)
- (sly render model)
(sly render mesh)
(sly render shader)
(sly render sprite)
(sly render texture)
(sly render tileset)
(sly render tile-map)
- (sly render scene)
(sly math vector)
(sly math tween)
(sly input keyboard))
@@ -90,16 +89,16 @@
(193 225 225 226 65 65 65 65 65 65 65 65 65 65 65 65 65 65 65 65)
(225 225 176 242 65 65 65 65 65 65 65 65 65 65 65 65 65 65 65 65))))
-(define model
- (model-move (v- (vector2 320 240)
- (v* (vector2 tile-width tile-height)
- (vector2 10 15/2)))
- (list->model (compile-tile-layer map-tiles 32 32))))
+(define render
+ (move (v- (vector2 320 240)
+ (v* (vector2 tile-width tile-height)
+ (vector2 10 15/2)))
+ (list->renderer (compile-tile-layer map-tiles 32 32))))
-(define camera
- (orthographic-camera 640 480))
+(define camera (2d-camera #:area (make-rect 0 0 640 480)))
-(define-signal scene (make-scene camera model))
+(define-signal scene
+ (with-camera camera render))
(with-window (make-window #:title "Tilemap")
(run-game-loop scene))
diff --git a/sly.scm b/sly.scm
index b92536a..2c54dfa 100644
--- a/sly.scm
+++ b/sly.scm
@@ -35,18 +35,16 @@
(sly window)
(sly repl)
(sly utils)
+ (sly render)
(sly render color)
(sly render font)
(sly render sprite)
(sly render texture)
- (sly render model)
(sly render camera)
- (sly render scene)
(sly input keyboard)
(sly input mouse)
(sly math)
(sly math rect)
- (sly math transform)
(sly math vector)))
(for-each (let ((i (module-public-interface (current-module))))
diff --git a/sly/game.scm b/sly/game.scm
index 7e4a79c..ef92e90 100644
--- a/sly/game.scm
+++ b/sly/game.scm
@@ -35,7 +35,6 @@
#:use-module (sly math vector)
#:use-module (sly window)
#:use-module (sly render)
- #:use-module (sly render scene)
#:export (draw-hook
after-game-loop-error-hook
run-game-loop
@@ -67,13 +66,13 @@ for the given STACK and error KEY with additional arguments ARGS."
(tick-rate 60)
(max-ticks-per-frame 4))
"Run the game loop. SCENE is a signal which contains the current
-scene to render. FRAME-RATE specifies the optimal number of frames to
-draw SCENE per second. TICK-RATE specifies the optimal game logic
-updates per second. Both FRAME-RATE and TICK-RATE are 60 by default.
-MAX-TICKS-PER-FRAME is the maximum number of times the game loop will
-update game state in a single frame. When this upper bound is reached
-due to poor performance, the game will start to slow down instead of
-becoming completely unresponsive and possibly crashing."
+scene renderer procedure. FRAME-RATE specifies the optimal number of
+frames to draw SCENE per second. TICK-RATE specifies the optimal game
+logic updates per second. Both FRAME-RATE and TICK-RATE are 60 by
+default. MAX-TICKS-PER-FRAME is the maximum number of times the game
+loop will update game state in a single frame. When this upper bound
+is reached due to poor performance, the game will start to slow down
+instead of becoming completely unresponsive and possibly crashing."
(let ((tick-interval (interval tick-rate))
(frame-interval (interval frame-rate))
(gfx (make-graphics)))
@@ -84,8 +83,7 @@ becoming completely unresponsive and possibly crashing."
(gl-viewport 0 0 (vx size) (vy size)))
(gl-clear (clear-buffer-mask color-buffer depth-buffer))
(run-hook draw-hook dt alpha)
- (with-graphics gfx
- (draw-scene (signal-ref scene) gfx))
+ (with-graphics gfx ((signal-ref scene) gfx))
(SDL:gl-swap-buffers))
(define (update lag)
diff --git a/sly/render.scm b/sly/render.scm
index 6ff7bb9..215629f 100644
--- a/sly/render.scm
+++ b/sly/render.scm
@@ -22,6 +22,7 @@
;;; Code:
(define-module (sly render)
+ #:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 q)
@@ -31,13 +32,14 @@
#:use-module (gl enums)
#:use-module (gl low-level)
#:use-module (sly wrappers gl)
- #:use-module (sly math transform)
+ #:use-module ((sly math transform) #:prefix t:)
+ #:use-module (sly render color)
#:use-module (sly render shader)
#:use-module (sly render texture)
#:use-module (sly render utils)
#:use-module (sly render mesh)
#:use-module (sly render framebuffer)
- #:use-module (sly render camera)
+ #:use-module (sly render viewport)
#:export (make-graphics
graphics?
graphics-blend-mode
@@ -57,23 +59,65 @@
graphics-model-view-transform
graphics-model-view-mul!
graphics-model-view-identity!
- with-model-view-excursion
+ graphics-model-view-excursion
graphics-projection-transform
graphics-projection-mul!
graphics-projection-identity!
- with-projection-excursion
+ graphics-projection-excursion
with-graphics
- with-graphics-excursion))
+ with-graphics-excursion
+
+ render-lift
+ render-lift1
+ render-nothing
+ list->renderer
+ render-begin
+ blend-mode-excursion
+ depth-test-excursion
+ texture-excursion
+ shader-excursion
+ mesh-excursion
+ framebuffer-excursion
+ viewport-excursion
+ projection-excursion
+ model-view-excursion
+ set-blend-mode
+ set-depth-test
+ set-texture
+ set-shader
+ set-mesh
+ set-framebuffer
+ set-viewport
+ projection-mul
+ projection-identity
+ model-view-mul
+ model-view-identity
+ with-blend-mode
+ with-depth-test
+ with-texture
+ with-shader
+ with-mesh
+ with-framebuffer
+ with-viewport
+ with-projection-mul
+ with-model-view-mul
+ move
+ scale
+ rotate-z
+ clear-screen
+ uniform-let
+ with-color
+ render-mesh))
;;;
;;; Transformation matrix stack.
;;;
(define (make-null-transform)
- (make-transform 0 0 0 0
- 0 0 0 0
- 0 0 0 0
- 0 0 0 0))
+ (t:make-transform 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0
+ 0 0 0 0))
(define (make-transform-stack size)
(let ((stack (make-q)))
@@ -81,8 +125,8 @@
stack))
(define (copy-transform! src dest)
- (bytevector-copy! (transform-matrix src) 0
- (transform-matrix dest) 0
+ (bytevector-copy! (t:transform-matrix src) 0
+ (t:transform-matrix dest) 0
64))
(define (call-with-transform-excursion stack thunk)
@@ -99,18 +143,18 @@
(let ((dest (q-front stack)))
(call-with-transform-excursion stack
(lambda ()
- (transform*! dest (q-front stack) t)))))
+ (t:transform*! dest (q-front stack) t)))))
(define (stack-transform-identity! stack)
- (copy-transform! identity-transform (q-front stack)))
+ (copy-transform! t:identity-transform (q-front stack)))
;;;
;;; Graphics context.
;;;
(define-record-type <graphics>
- (%make-graphics blend-mode depth-test? texture shader
- mesh framebuffer viewport projection model-view)
+ (%make-graphics blend-mode depth-test? texture shader mesh framebuffer
+ viewport projection model-view uniforms)
graphics?
(blend-mode graphics-blend-mode %set-graphics-blend-mode!)
(depth-test? graphics-depth-test? %set-graphics-depth-test!)
@@ -120,13 +164,47 @@
(framebuffer graphics-framebuffer %set-graphics-framebuffer!)
(viewport graphics-viewport %set-graphics-viewport!)
(projection graphics-projection)
- (model-view graphics-model-view))
+ (model-view graphics-model-view)
+ (uniforms graphics-uniforms set-graphics-uniforms!))
+
+(define (graphics-uniform-ref gfx uniform)
+ (hashq-ref (graphics-uniforms gfx) uniform))
+
+(define (graphics-uniform-set! gfx uniform value)
+ (uniform-set! (graphics-shader gfx) uniform value)
+ (hashq-set! (graphics-uniforms gfx) uniform value))
+
+(define (graphics-uniform-excursion gfx uniforms proc)
+ (define (set-uniforms uniforms)
+ (for-each (match-lambda
+ ((name value)
+ (graphics-uniform-set! gfx name value)))
+ uniforms))
+
+ (let* ((old (map (match-lambda
+ ((name _)
+ (list name (graphics-uniform-ref gfx name))))
+ uniforms)))
+ (set-uniforms uniforms)
+ (proc gfx)
+ (set-uniforms old)))
+
+(define (switch-shader gfx shader)
+ (%set-graphics-shader! gfx shader)
+ (hash-clear! (graphics-uniforms gfx))
+ (for-each (lambda (uniform)
+ (graphics-uniform-set! gfx
+ (uniform-name uniform)
+ (uniform-default uniform)))
+ (shader-program-uniforms shader)))
(define (make-context-switcher getter setter switch)
(lambda* (gfx x #:optional force)
(when (or force (not (equal? (getter gfx) x)))
- (setter gfx x)
- (switch x))))
+ ;; It's important that we change OpenGL context first, because
+ ;; the setter procedure may do things that depend on it.
+ (switch x)
+ (setter gfx x))))
(define set-graphics-blend-mode!
(make-context-switcher graphics-blend-mode
@@ -145,7 +223,7 @@
(define set-graphics-shader!
(make-context-switcher graphics-shader
- %set-graphics-shader!
+ switch-shader
apply-shader-program))
(define set-graphics-mesh!
@@ -163,21 +241,30 @@
%set-graphics-viewport!
apply-viewport))
+(define (draw-graphics-mesh! graphics)
+ (let ((mesh (graphics-mesh graphics)))
+ (glDrawElements (begin-mode triangles)
+ (mesh-length mesh)
+ (data-type unsigned-int)
+ %null-pointer)))
+
(define* (make-graphics #:optional (transform-stack-size 32))
(%make-graphics #f #f #f #f #f #f #f
(make-transform-stack transform-stack-size)
- (make-transform-stack transform-stack-size)))
+ (make-transform-stack transform-stack-size)
+ (make-hash-table)))
(define (graphics-reset! gfx)
- (set-graphics-blend-mode! gfx #f #t)
- (set-graphics-depth-test! gfx #f #t)
- (set-graphics-texture! gfx null-texture #t)
- (set-graphics-shader! gfx null-shader-program #t)
- (set-graphics-mesh! gfx null-mesh #t)
- (set-graphics-framebuffer! gfx null-framebuffer #t)
- (set-graphics-viewport! gfx null-viewport #t)
- (stack-transform-identity! (graphics-projection gfx))
- (stack-transform-identity! (graphics-model-view gfx)))
+ (let ((shader (load-default-shader)))
+ (set-graphics-blend-mode! gfx default-blend-mode #t)
+ (set-graphics-depth-test! gfx #f #t)
+ (set-graphics-texture! gfx null-texture #t)
+ (set-graphics-shader! gfx shader #t)
+ (set-graphics-mesh! gfx null-mesh #t)
+ (set-graphics-framebuffer! gfx null-framebuffer #t)
+ (set-graphics-viewport! gfx null-viewport #t)
+ (stack-transform-identity! (graphics-projection gfx))
+ (stack-transform-identity! (graphics-model-view gfx))))
(define-syntax-rule (with-graphics gfx body ...)
(begin
@@ -194,10 +281,9 @@
(define (graphics-model-view-identity! gfx)
(stack-transform-identity! (graphics-model-view gfx)))
-;; emacs: (put 'with-model-view-excursion 'scheme-indent-function 1)
-(define-syntax-rule (with-model-view-excursion gfx body ...)
+(define (graphics-model-view-excursion gfx proc)
(call-with-transform-excursion (graphics-model-view gfx)
- (lambda () body ...)))
+ (lambda () (proc gfx))))
(define (graphics-projection-transform gfx)
(q-front (graphics-projection gfx)))
@@ -208,20 +294,211 @@
(define (graphics-projection-identity! gfx)
(stack-transform-identity! (graphics-projection gfx)))
-;; emacs: (put 'with-projection-excursion 'scheme-indent-function 1)
-(define-syntax-rule (with-projection-excursion gfx body ...)
+(define (graphics-projection-excursion gfx proc)
(call-with-transform-excursion (graphics-projection gfx)
- (lambda () body ...)))
-
-(define-syntax-rule (with-graphics-excursion gfx body ...)
- (match gfx
- (($ <graphics> blend-mode depth-test? texture shader mesh
- viewport framebuffer _ _)
- body ...
- (set-graphics-blend-mode! gfx blend-mode)
- (set-graphics-depth-test! gfx depth-test?)
- (set-graphics-texture! gfx texture)
- (set-graphics-shader! gfx shader)
- (set-graphics-mesh! gfx mesh)
- (set-graphics-framebuffer! gfx framebuffer)
- (set-graphics-viewport! gfx viewport))))
+ (lambda () (proc gfx))))
+
+(define (make-excursion getter setter)
+ (lambda (gfx proc)
+ (let ((old (getter gfx)))
+ (dynamic-wind
+ (const #t)
+ (lambda () (proc gfx))
+ (lambda ()
+ (setter gfx old))))))
+
+(define graphics-blend-mode-excursion
+ (make-excursion graphics-blend-mode set-graphics-blend-mode!))
+
+(define graphics-depth-test-excursion
+ (make-excursion graphics-depth-test? set-graphics-depth-test!))
+
+(define graphics-texture-excursion
+ (make-excursion graphics-texture set-graphics-texture!))
+
+(define graphics-shader-excursion
+ (make-excursion graphics-shader set-graphics-shader!))
+
+(define graphics-mesh-excursion
+ (make-excursion graphics-mesh set-graphics-mesh!))
+
+(define graphics-framebuffer-excursion
+ (make-excursion graphics-framebuffer set-graphics-framebuffer!))
+
+(define graphics-viewport-excursion
+ (make-excursion graphics-viewport set-graphics-viewport!))
+
+;;;
+;;; Render Combinators
+;;;
+
+(define (render-lift proc)
+ "Lift PROC, a procedure whose first argument is the graphics
+context, into the rendering monad."
+ (lambda args
+ (lambda (gfx)
+ (apply proc gfx args))))
+
+(define (render-lift1 proc)
+ "Lift PROC, a procedure that accepts two arguments whose first
+argument is a graphics context, into the rendering monad."
+ (lambda (arg)
+ (lambda (gfx)
+ (proc gfx arg))))
+
+(define (render-nothing gfx)
+ "Render nothing at all."
+ *unspecified*)
+
+(define (list->renderer renderers)
+ "Create a new renderer that applies RENDERERS in order."
+ (lambda (gfx)
+ (for-each (lambda (render) (render gfx)) renderers)))
+
+(define (render-begin . renderers)
+ "Create a new renderer that applies RENDERERS in order."
+ (list->renderer renderers))
+
+(define blend-mode-excursion
+ (render-lift1 graphics-blend-mode-excursion))
+
+(define depth-test-excursion
+ (render-lift1 graphics-depth-test-excursion))
+
+(define texture-excursion
+ (render-lift1 graphics-texture-excursion))
+
+(define shader-excursion
+ (render-lift1 graphics-shader-excursion))
+
+(define mesh-excursion
+ (render-lift1 graphics-mesh-excursion))
+
+(define framebuffer-excursion
+ (render-lift1 graphics-framebuffer-excursion))
+
+(define viewport-excursion
+ (render-lift1 graphics-viewport-excursion))
+
+(define projection-excursion
+ (render-lift1 graphics-projection-excursion))
+
+(define model-view-excursion
+ (render-lift1 graphics-model-view-excursion))
+
+(define set-blend-mode
+ (render-lift1 set-graphics-blend-mode!))
+
+(define set-depth-test
+ (render-lift1 set-graphics-depth-test!))
+
+(define set-texture
+ (render-lift1 set-graphics-texture!))
+
+(define set-shader
+ (render-lift1 set-graphics-shader!))
+
+(define set-mesh
+ (render-lift1 set-graphics-shader!))
+
+(define set-framebuffer
+ (render-lift1 set-graphics-framebuffer!))
+
+(define set-viewport
+ (render-lift1 set-graphics-viewport!))
+
+(define projection-mul
+ (render-lift1 graphics-projection-mul!))
+
+(define projection-identity
+ (render-lift1 graphics-projection-identity!))
+
+(define model-view-mul
+ (render-lift1 graphics-model-view-mul!))
+
+(define model-view-identity
+ (render-lift1 graphics-model-view-identity!))
+
+(define (with-blend-mode blend-mode renderer)
+ (blend-mode-excursion
+ (render-begin (set-blend-mode blend-mode) renderer)))
+
+(define (with-depth-test depth-test renderer)
+ (depth-test-excursion
+ (render-begin (set-depth-test depth-test) renderer)))
+
+(define (with-texture texture renderer)
+ (texture-excursion
+ (render-begin (set-texture texture) renderer)))
+
+(define (with-shader shader renderer)
+ (shader-excursion
+ (render-begin (set-shader shader) renderer)))
+
+(define (with-mesh mesh renderer)
+ (mesh-excursion
+ (render-begin (set-mesh mesh) renderer)))
+
+(define (with-framebuffer framebuffer renderer)
+ (framebuffer-excursion
+ (render-begin (set-framebuffer framebuffer) renderer)))
+
+(define (with-viewport viewport renderer)
+ (viewport-excursion
+ (render-begin (set-viewport viewport) renderer)))
+
+(define (with-projection-mul transform renderer)
+ (projection-excursion
+ (render-begin (projection-mul transform) renderer)))
+
+(define (with-model-view-mul transform renderer)
+ (model-view-excursion
+ (render-begin (model-view-mul transform) renderer)))
+
+(define (move v renderer)
+ "Create a new renderer that moves the scene by the vector V and
+applies RENDERER."
+ (with-model-view-mul (t:translate v) renderer))
+
+(define (scale s renderer)
+ "Create a new renderer that scales the scene by S and applies
+RENDERER."
+ (with-model-view-mul (t:scale s) renderer))
+
+(define (rotate-z theta renderer)
+ "Create a new renderer that rotates the scene by THETA about the Z
+axis and applies RENDERER."
+ (with-model-view-mul (t:rotate-z theta) renderer))
+
+(define (clear-screen gfx)
+ "Clear the current viewport bound to GFX."
+ (clear-viewport (graphics-viewport gfx)))
+
+(define-syntax-rule (uniform-let ((uniform value) ...) renderer ...)
+ "Bind each UNIFORM to its respective VALUE in the curently bound
+shader program, then apply each RENDERER."
+ (lambda (gfx)
+ (graphics-uniform-excursion gfx `((uniform ,value) ...)
+ (lambda (gfx)
+ (renderer gfx) ...))))
+
+(define (with-color color renderer)
+ "Create a new renderer that sets the 'color' uniform variable to
+COLOR and applies RENDERER."
+ (uniform-let ((color color))
+ renderer))
+
+(define (render-mesh mesh)
+ "Create a new renderer that render MESH to the framebuffer."
+ (lambda (gfx)
+ (graphics-model-view-excursion gfx
+ (lambda (gfx)
+ (graphics-model-view-mul! gfx (graphics-projection-transform gfx))
+ (graphics-mesh-excursion gfx
+ (lambda (gfx)
+ (set-graphics-mesh! gfx mesh)
+ (graphics-uniform-excursion gfx
+ `((mvp ,(graphics-model-view-transform gfx))
+ (texture? ,(not (texture-null?
+ (graphics-texture gfx)))))
+ draw-graphics-mesh!)))))))
diff --git a/sly/render/camera.scm b/sly/render/camera.scm
index 9de7ae6..d943896 100644
--- a/sly/render/camera.scm
+++ b/sly/render/camera.scm
@@ -1,5 +1,5 @@
;;; Sly
-;;; Copyright (C) 2014 David Thompson <davet@gnu.org>
+;;; Copyright (C) 2014, 2015 David Thompson <davet@gnu.org>
;;;
;;; Sly is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
@@ -17,7 +17,7 @@
;;; Commentary:
;;
-;; Cameras and viewports.
+;; Cameras.
;;
;;; Code:
@@ -29,94 +29,53 @@
#:use-module (gl enums)
#:use-module (sly wrappers gl)
#:use-module (sly utils)
+ #:use-module (sly render)
#:use-module (sly render color)
+ #:use-module (sly render viewport)
#:use-module (sly math rect)
#:use-module (sly math transform)
- #:export (make-viewport
- viewport?
- viewport-area
- viewport-clear-color
- viewport-clear-flags
- null-viewport
- %standard-clear-flags
- apply-viewport
- clear-viewport
- make-camera camera?
- camera-location camera-projection camera-viewport
- orthographic-camera))
-
-;;;
-;;; Viewport
-;;;
-
-(define-record-type <viewport>
- (%make-viewport area clear-color clear-flags)
- viewport?
- (area viewport-area)
- (clear-color viewport-clear-color)
- (clear-flags viewport-clear-flags))
-
-(define %standard-clear-flags '(color-buffer depth-buffer))
-
-(define* (make-viewport area #:optional #:key (clear-color black)
- (clear-flags %standard-clear-flags))
- "Create a viewport that covers the rectangle AREA of the window.
-Fill the viewport with CLEAR-COLOR when clearing the screen. Clear
-the buffers denoted by the list of symbols in CLEAR-FLAGS. Possible
-values for CLEAR-FLAGS are 'color-buffer', 'depth-buffer',
-'accum-buffer', and 'stencil-buffer'."
- (%make-viewport area clear-color clear-flags))
-
-(define null-viewport (make-viewport (make-rect 0 0 0 0)))
-
-(define clear-buffer-mask
- (memoize
- (lambda (flags)
- (apply logior
- ;; Map symbols to OpenGL constants.
- (map (match-lambda
- ('depth-buffer 256)
- ('accum-buffer 512)
- ('stencil-buffer 1024)
- ('color-buffer 16384))
- flags)))))
-
-(define (apply-viewport viewport)
- "Set the OpenGL state for VIEWPORT. Clip rendering to the viewport
-area, set the clear color, and clear necessary buffers."
- (gl-enable (enable-cap scissor-test))
- (match (viewport-area viewport)
- (($ <rect> x y width height)
- (gl-viewport x y width height)
- (gl-scissor x y width height)))
- (match (viewport-clear-color viewport)
- (($ <color> r g b a)
- (gl-clear-color r g b a))))
-
-(define (clear-viewport viewport)
- "Clear the relevant OpenGL buffers VIEWPORT."
- (gl-clear (clear-buffer-mask (viewport-clear-flags viewport))))
-
-;;;
-;;; Camera
-;;;
+ #:use-module (sly math vector)
+ #:export (make-camera
+ camera?
+ camera-projection
+ camera-location
+ camera-viewport
+ with-camera
+ 2d-camera))
(define-record-type <camera>
- (make-camera location projection viewport)
+ (make-camera projection location viewport)
camera?
- (location camera-location)
(projection camera-projection)
+ (location camera-location)
(viewport camera-viewport))
-(define* (orthographic-camera width height
- #:optional #:key
- (z-near 0) (z-far 1)
- (viewport (make-viewport
- (make-rect 0 0 width height))))
- "Create a camera object that uses an orthographic (2D) projection of
-size WIDTH x HEIGHT. Optionally, z-axis clipping planes Z-NEAR and
-Z-FAR can be specified, but default to 0 and 1, respectively. By
-default, the camera's VIEWPORT is WIDTH x HEIGHT, which is convenient if
-the dimensions are measured in pixels."
- (let ((projection (orthographic-projection 0 width height 0 z-near z-far)))
- (make-camera identity-transform projection viewport)))
+(define (with-camera camera renderer)
+ (projection-excursion
+ (render-begin
+ projection-identity
+ (projection-mul (camera-projection camera))
+ (move (camera-location camera)
+ (with-viewport (camera-viewport camera)
+ (render-begin
+ clear-screen
+ renderer))))))
+
+(define* (2d-camera #:key (z-near 0) (z-far 1) (area (make-rect 0 0 640 480))
+ (clear-color black) (clear-flags %standard-clear-flags)
+ (location (vector2 0 0)))
+ "Create a camera that uses an orthographic (2D) projection that
+spans AREA in the framebuffer. By default, this area is (0, 0)
+-> (640, 480) pixels. Z-axis clipping planes Z-NEAR and Z-FAR may be
+specified but default to 0 and 1, respectively. CLEAR-COLOR specifies
+the background color used when clearing the screen. Black is used by
+default. CLEAR-FLAGS specifies the buffers that are cleared when the
+camera is applied. The color and depth buffers are cleared by
+default. LOCATION specifies the position of the camera in the scene.
+The origin is used as the default location."
+ (let ((viewport (make-viewport area #:clear-color clear-color
+ #:clear-flags clear-flags))
+ (projection (orthographic-projection 0 (rect-width area)
+ (rect-height area) 0
+ z-near z-far)))
+ (make-camera projection location viewport)))
diff --git a/sly/render/font.scm b/sly/render/font.scm
index dff74a2..dace505 100644
--- a/sly/render/font.scm
+++ b/sly/render/font.scm
@@ -33,7 +33,6 @@
#:use-module (sly wrappers gl)
#:use-module (sly render color)
#:use-module (sly config)
- #:use-module (sly render mesh)
#:use-module (sly render sprite)
#:use-module (sly render texture)
#:export (enable-fonts
@@ -41,7 +40,7 @@
load-default-font
font?
font-point-size
- make-label label))
+ make-label))
;;;
;;; Font
@@ -95,9 +94,8 @@ HEIGHT, 32 bit color bytevector."
;; Need to flip pixels so that origin is on the bottom-left.
(bytevector->texture pixels width height 'linear 'linear)))
-(define* (make-label font text #:optional #:key
- (anchor 'top-left))
+(define* (make-label font text #:key (anchor 'top-left))
+ "Create a sprite that displays TEXT rendered using FONT. ANCHOR
+defines the sprite's origin, which is 'top-left' by default."
(let ((texture (render-text font text)))
(make-sprite texture #:anchor anchor)))
-
-(define label make-label)
diff --git a/sly/render/shader.scm b/sly/render/shader.scm
index 392ebc5..cb3828d 100644
--- a/sly/render/shader.scm
+++ b/sly/render/shader.scm
@@ -44,13 +44,14 @@
shader-type
shader-id
make-shader-program
+ shader-program?
load-shader-program
vertex-position-location
vertex-texture-location
shader-program-uniform-location
shader-program-attribute-location
shader-program-id
- shader-program?
+ shader-program-uniforms
shader-program-linked?
null-shader-program
apply-shader-program
@@ -58,6 +59,10 @@
load-default-shader
%uniform-setters
register-uniform-setter!
+ uniform?
+ uniform-name
+ uniform-gl-name
+ uniform-default
uniform-set!
uniforms))
@@ -182,10 +187,12 @@ in the file FILENAME."
;;;
(define-record-type <uniform>
- (make-uniform name location)
+ (make-uniform name gl-name location default)
uniform?
(name uniform-name)
- (location uniform-location))
+ (gl-name uniform-gl-name)
+ (location uniform-location)
+ (default uniform-default))
(define-record-type <attribute>
(make-attribute name location)
@@ -203,14 +210,13 @@ in the file FILENAME."
(define vertex-position-location 0)
(define vertex-texture-location 1)
-(define (shader-program-uniform-location shader-program uniform-name)
- (let ((uniform (find (match-lambda
- (($ <uniform> name _)
- (string=? uniform-name name)))
+(define (shader-program-uniform-location shader-program name)
+ (let ((uniform (find (lambda (uniform)
+ (eq? (uniform-name uniform) name))
(shader-program-uniforms shader-program))))
(if uniform
(uniform-location uniform)
- (error "Uniform not found: " uniform-name))))
+ (error "Uniform not found: " name))))
(define (shader-program-attribute-location shader-program attribute-name)
(let ((attribute (find (match-lambda
@@ -238,11 +244,13 @@ VERTEX-SHADER and FRAGMENT-SHADER."
vertex-shader fragment-shader))
(let ((id (glCreateProgram))
(shaders (list vertex-shader fragment-shader)))
- (define (string->uniform uniform-name)
- (let ((location (glGetUniformLocation id uniform-name)))
- (if (= location -1)
- (error "Uniform not found: " uniform-name)
- (make-uniform uniform-name location))))
+ (define build-uniform
+ (match-lambda
+ ((name gl-name default)
+ (let ((location (glGetUniformLocation id gl-name)))
+ (if (= location -1)
+ (error "Uniform not found: " gl-name)
+ (make-uniform name gl-name location default))))))
(define (string->attribute attribute-name)
(let ((location (glGetAttribLocation id attribute-name)))
@@ -266,7 +274,7 @@ VERTEX-SHADER and FRAGMENT-SHADER."
(for-each (lambda (shader)
(glDetachShader id (shader-id shader)))
shaders)
- (let* ((uniforms (map string->uniform uniforms))
+ (let* ((uniforms (map build-uniform uniforms))
(attributes (map string->attribute attributes))
(shader-program (%make-shader-program id uniforms attributes)))
(shader-program-guardian shader-program)
@@ -297,17 +305,6 @@ VERTEX-SHADER and FRAGMENT-SHADER."
(glUseProgram 0)
return-value))))
-(define load-default-shader
- (memoize
- (lambda ()
- (load-shader-program
- (string-append %pkgdatadir
- "/shaders/default-vertex.glsl")
- (string-append %pkgdatadir
- "/shaders/default-fragment.glsl")
- '("mvp" "color" "use_texture")
- '("position" "tex")))))
-
;;;
;;; Uniforms
;;;
@@ -377,19 +374,19 @@ within SHADER-PROGRAM."
((uniform-setter-proc setter) location value)
(error "Not a valid uniform data type" value))))
-;; Bind values to uniform variables within the current shader program
-;; via a let-style syntax. The types of the given values must be
-;; accounted for in the %uniform-setters list. This macro simply sets
-;; uniform values and does not restore the previous values after
-;; evaluating the body of the form.
-;;
-;; emacs: (put 'uniforms 'scheme-indent-function 1)
-(define-syntax uniforms
- (syntax-rules ()
- ((_ () body ...)
- (begin body ...))
- ((_ ((name value) ...) body ...)
- (begin
- (uniform-set! (current-shader-program) 'name value)
- ...
- body ...))))
+;;;
+;;; Built-in Shaders
+;;;
+
+(define load-default-shader
+ (memoize
+ (lambda ()
+ (load-shader-program
+ (string-append %pkgdatadir
+ "/shaders/default-vertex.glsl")
+ (string-append %pkgdatadir
+ "/shaders/default-fragment.glsl")
+ `((mvp "mvp" ,identity-transform)
+ (color "color" ,white)
+ (texture? "use_texture" #f))
+ '("position" "tex")))))
diff --git a/sly/render/sprite.scm b/sly/render/sprite.scm
index d0ba059..c0ad5bb 100644
--- a/sly/render/sprite.scm
+++ b/sly/render/sprite.scm
@@ -24,29 +24,35 @@
(define-module (sly render sprite)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-9)
#:use-module (gl)
- #:use-module (gl contrib packed-struct)
- #:use-module ((sdl sdl) #:prefix SDL:)
- #:use-module (sly render color)
- #:use-module (sly config)
#:use-module (sly agenda)
#:use-module (sly utils)
- #:use-module (sly math)
+ #:use-module (sly render)
+ #:use-module (sly render color)
#:use-module (sly render mesh)
- #:use-module (sly render model)
#:use-module (sly render texture)
+ #:use-module (sly render utils)
#:use-module (sly math vector)
- #:export (make-sprite sprite load-sprite))
+ #:export (make-sprite
+ load-sprite
+ sprite?
+ sprite-texture
+ sprite-mesh
+ render-sprite))
-;;;
-;;; Sprites
-;;;
+(define-record-type <sprite>
+ (%make-sprite texture mesh)
+ sprite?
+ (texture sprite-texture)
+ (mesh sprite-mesh))
-(define* (make-sprite texture #:optional #:key
- (anchor 'center))
- "Return a 2D rectangular mesh that displays the image TEXTURE. The
-size of the mesh is the size of TEXTURE, in pixels."
+(define* (make-sprite texture #:key (anchor 'center))
+ "Create a sprite that displays the image in TEXTURE. The size of
+the mesh is the size of TEXTURE in pixels. ANCHOR defines the origin
+of the sprite. By default, the anchor is 'center', which puts the
+origin in the middle of the sprite. See 'anchor-texture' for more
+anchoring options."
(let* ((anchor (anchor-texture texture anchor))
(x1 (- (floor (vx anchor))))
(y1 (- (floor (vy anchor))))
@@ -67,12 +73,16 @@ size of the mesh is the size of TEXTURE, in pixels."
(vector2 s2 t1)
(vector2 s2 t2)
(vector2 s1 t2)))))
- (make-model #:texture texture
- #:mesh mesh
- #:depth-test? #f)))
+ (%make-sprite texture mesh)))
-(define sprite make-sprite)
+(define* (load-sprite file #:key (anchor 'center))
+ "Create a sprite from the texture in FILE whose origin is defined by
+ANCHOR. The default anchor is 'center'."
+ (make-sprite (load-texture file) #:anchor anchor))
-(define* (load-sprite file-name #:key (anchor 'center))
- "Return a sprite mesh for the texture loaded from FILE-NAME."
- (make-sprite (load-texture file-name) #:anchor anchor))
+(define* (render-sprite sprite)
+ "Create a renderer that draws a 2D rectangular mesh that displays
+the image TEXTURE. The size of the mesh is the size of TEXTURE in
+pixels."
+ (with-texture (sprite-texture sprite)
+ (render-mesh (sprite-mesh sprite))))
diff --git a/sly/render/texture.scm b/sly/render/texture.scm
index df786b6..ef8c3ea 100644
--- a/sly/render/texture.scm
+++ b/sly/render/texture.scm
@@ -53,8 +53,7 @@
texture-vertex
pack-texture-vertices
draw-texture-vertices
- apply-texture
- with-texture))
+ apply-texture))
;;;
;;; Textures
@@ -229,13 +228,6 @@ vector to be returned."
(glBindTexture (texture-target texture-2d)
(texture-id texture)))
-(define-syntax-rule (with-texture texture body ...)
- (begin
- (apply-texture texture)
- body
- ...
- (glBindTexture (texture-target texture-2d) 0)))
-
(define (draw-texture-vertices texture vertices size)
(let ((pointer-type (tex-coord-pointer-type float)))
(gl-enable-client-state (enable-cap vertex-array))
diff --git a/sly/render/tile-map.scm b/sly/render/tile-map.scm
index 8e8cd0f..594aa14 100644
--- a/sly/render/tile-map.scm
+++ b/sly/render/tile-map.scm
@@ -26,20 +26,18 @@
#:use-module (ice-9 vlist)
#:use-module (sly utils)
#:use-module (sly math vector)
+ #:use-module (sly render)
#:use-module (sly render mesh)
- #:use-module (sly render model)
#:use-module (sly render shader)
#:use-module (sly render texture)
#:use-module (sly render tileset)
#:export (compile-tile-layer))
-(define* (compile-tile-layer tiles tile-width tile-height
- #:key (shader (load-default-shader)))
+(define* (compile-tile-layer tiles tile-width tile-height)
"Compile the two-dimensional vlist TILES into a list of models for
efficient rendering. The resulting map spaces each tile by TILE-WIDTH
-and TILE-HEIGHT. The compiled models all use the given SHADER when
-rendered. TILES is assumed to be rectangular, with each row having
-equal elements."
+and TILE-HEIGHT. TILES is assumed to be rectangular, with each row
+having equal elements."
(define (make-tile-vertices x y tile)
(let* ((x1 (* x tile-width))
(y1 (* y tile-height))
@@ -121,9 +119,10 @@ equal elements."
(map (match-lambda
((texture (indices positions textures))
- (make-model #:mesh (build-mesh (list->vector (offset-indices indices))
- (list->vector positions)
- (list->vector textures))
- #:texture texture
- #:shader shader)))
+ (render-begin
+ (with-texture texture
+ (render-mesh
+ (build-mesh (list->vector (offset-indices indices))
+ (list->vector positions)
+ (list->vector textures)))))))
vertices))
diff --git a/sly/render/viewport.scm b/sly/render/viewport.scm
new file mode 100644
index 0000000..054646e
--- /dev/null
+++ b/sly/render/viewport.scm
@@ -0,0 +1,92 @@
+;;; Sly
+;;; Copyright (C) 2014, 2015 David Thompson <davet@gnu.org>
+;;;
+;;; Sly is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Sly is distributed in the hope that it will be useful, but WITHOUT
+;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+;;; License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Viewports.
+;;
+;;; Code:
+
+(define-module (sly render viewport)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module (gl)
+ #:use-module (gl low-level)
+ #:use-module (sly wrappers gl)
+ #:use-module (sly math rect)
+ #:use-module (sly utils)
+ #:use-module (sly render color)
+ #:export (make-viewport
+ viewport?
+ viewport-area
+ viewport-clear-color
+ viewport-clear-flags
+ null-viewport
+ %standard-clear-flags
+ apply-viewport
+ clear-viewport))
+;;;
+;;; Viewport
+;;;
+
+(define-record-type <viewport>
+ (%make-viewport area clear-color clear-flags)
+ viewport?
+ (area viewport-area)
+ (clear-color viewport-clear-color)
+ (clear-flags viewport-clear-flags))
+
+(define %standard-clear-flags '(color-buffer depth-buffer))
+
+(define* (make-viewport area #:optional #:key (clear-color black)
+ (clear-flags %standard-clear-flags))
+ "Create a viewport that covers the rectangle AREA of the window.
+Fill the viewport with CLEAR-COLOR when clearing the screen. Clear
+the buffers denoted by the list of symbols in CLEAR-FLAGS. Possible
+values for CLEAR-FLAGS are 'color-buffer', 'depth-buffer',
+'accum-buffer', and 'stencil-buffer'."
+ (%make-viewport area clear-color clear-flags))
+
+(define null-viewport (make-viewport (make-rect 0 0 0 0)))
+
+(define clear-buffer-mask
+ (memoize
+ (lambda (flags)
+ (apply logior
+ ;; Map symbols to OpenGL constants.
+ (map (match-lambda
+ ('depth-buffer 256)
+ ('accum-buffer 512)
+ ('stencil-buffer 1024)
+ ('color-buffer 16384))
+ flags)))))
+
+(define (apply-viewport viewport)
+ "Set the OpenGL state for VIEWPORT. Clip rendering to the viewport
+area, set the clear color, and clear necessary buffers."
+ (gl-enable (enable-cap scissor-test))
+ (match (viewport-area viewport)
+ (($ <rect> x y width height)
+ (gl-viewport x y width height)
+ (gl-scissor x y width height)))
+ (match (viewport-clear-color viewport)
+ (($ <color> r g b a)
+ (gl-clear-color r g b a))))
+
+(define (clear-viewport viewport)
+ "Clear the relevant OpenGL buffers VIEWPORT."
+ (gl-clear (clear-buffer-mask (viewport-clear-flags viewport))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-22 17:30:33 +0000