summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--README.org7
-rwxr-xr-xexamples/2048/2048.scm72
-rw-r--r--examples/animation.scm13
-rw-r--r--examples/font.scm15
-rw-r--r--examples/joystick.scm9
-rw-r--r--examples/mines/mines.scm23
-rw-r--r--examples/simple.scm13
-rw-r--r--examples/tilemap.scm11
-rw-r--r--sly/render/group.scm137
-rw-r--r--sly/render/model.scm122
11 files changed, 171 insertions, 252 deletions
diff --git a/Makefile.am b/Makefile.am
index 59b59a9..f9bc879 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -49,7 +49,6 @@ SOURCES = \
sly/render/framebuffer.scm \
sly/render/mesh.scm \
sly/render/model.scm \
- sly/render/group.scm \
sly/render/texture.scm \
sly/render/shader.scm \
sly/render/shape.scm \
diff --git a/README.org b/README.org
index 7316c06..c534276 100644
--- a/README.org
+++ b/README.org
@@ -33,16 +33,15 @@
(sly window)
(sly math vector)
(sly render camera)
- (sly render group)
+ (sly render model)
(sly render sprite))
(define scene
- (group-move (vector2 320 240)
- (group (load-sprite "gnu.png"))))
+ (move (vector2 320 240) (load-sprite "gnu.png")))
(define camera (orthographic-camera 640 480))
- (add-hook! draw-hook (lambda _ (draw-group scene camera)))
+ (add-hook! draw-hook (lambda _ (draw-model scene camera)))
(with-window (make-window #:title "Hello, world!")
(start-game-loop))
diff --git a/examples/2048/2048.scm b/examples/2048/2048.scm
index 73cb5f6..7bffe0b 100755
--- a/examples/2048/2048.scm
+++ b/examples/2048/2048.scm
@@ -37,7 +37,6 @@
(sly render color)
(sly render context)
(sly render font)
- (sly render group)
(sly render model)
(sly render sprite)
(sly render texture)
@@ -324,14 +323,15 @@
(label (assoc-ref tile-label-cache n))
(label-color (tile-text-color n))
(bg-color (tile-bg-color n)))
- (group-move (vector2 (* x w) (* y h))
- (make-group
- (cons (model-paint bg-color tile-sprite)
- (if (zero? n)
- '()
- (list (group-move (vector2 (/ w 2) (/ h 2))
- (group (model-paint label-color
- label))))))))))
+ (move (vector2 (* x w) (* y h))
+ (group*
+ (cons (paint bg-color tile-sprite)
+ (if (zero? n)
+ '()
+ (list (move (vector2 (/ w 2) (/ h 2))
+ (group
+ (paint label-color
+ label))))))))))
(define window-width 640)
(define window-height 480)
@@ -347,7 +347,7 @@
(define-signal tiles
(signal-map (lambda (board)
- (make-group
+ (group*
(append-map
(match-lambda
((y (row ...))
@@ -361,24 +361,24 @@
(define play-again-font (load-default-font 16))
(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 (paint black (label play-again-font
+ "Press N to play again"
+ #:anchor 'top-center)))
+ (game-over (paint black (label font "GAME OVER"
+ #:anchor 'bottom-center)))
+ (you-win (paint black (label font "YOU WIN!"
+ #:anchor 'bottom-center))))
(signal-map
(lambda (board)
(let ((message (cond
((board-lose? board) game-over)
((board-win? board) you-win)
(else #f))))
- (group-move (vector2 (/ board-width 2)
- (/ board-height 2))
- (make-group (if message
- (list message play-again)
- '())))))
+ (move (vector2 (/ board-width 2)
+ (/ board-height 2))
+ (group* (if message
+ (list message play-again)
+ '())))))
board)))
(define instruction-font (load-default-font 16))
@@ -387,11 +387,11 @@
"Use the arrow keys to join the numbers and get to the 2048 tile!")
(define-signal instructions
- (group-move (vector2 (/ board-width 2) (- window-height (vy center-pos)))
- (group
- (model-paint text-color-1
- (label instruction-font instruction-text
- #:anchor 'top-center)))))
+ (move (vector2 (/ board-width 2) (- window-height (vy center-pos)))
+ (group
+ (paint text-color-1
+ (label instruction-font instruction-text
+ #:anchor 'top-center)))))
(define score-header-font (load-default-font 14))
(define score-font (load-default-font 22))
@@ -408,13 +408,13 @@
(signal-map (lambda (score timer)
(let ((score (label score-font (number->string score)
#:anchor 'center)))
- (group-move (vector2 x (- window-height 28))
- (group
- (model-paint text-color-1 header)
- (group-move (position-tween timer)
- (group
- (model-paint (color-tween timer)
- score)))))))
+ (move (vector2 x (- window-height 28))
+ (group
+ (paint text-color-1 header)
+ (move (position-tween timer)
+ (group
+ (paint (color-tween timer)
+ score)))))))
score
(signal-drop (lambda (t) (> t duration))
0 (signal-since 1 score)))))
@@ -427,7 +427,7 @@
(- board-width (/ board-width 4))))
(define-signal 2048-scene
- (signal-map (cut group-move center-pos <>)
+ (signal-map (cut move center-pos <>)
(signal-map group instructions tiles score
best-score status-message)))
@@ -438,7 +438,7 @@
(define (draw-2048 dt alpha)
(signal-let ((scene 2048-scene))
- (draw-group scene camera)))
+ (draw-model scene camera)))
;;;
;;; Initialization
diff --git a/examples/animation.scm b/examples/animation.scm
index cc84c27..ef736d2 100644
--- a/examples/animation.scm
+++ b/examples/animation.scm
@@ -22,7 +22,7 @@
(sly math tween)
(sly math vector)
(sly render camera)
- (sly render group)
+ (sly render model)
(sly render sprite)
(sly render tileset))
@@ -45,18 +45,15 @@
(tween (compose floor lerp) (compose ease-linear ease-loop)
0 frame-count (* frame-count frame-rate))))
-(define-signal timer
- (signal-fold + 0 (signal-every 1)))
-
(define-signal scene
(signal-map (lambda (time)
- (group-move (position-tween time)
- (group (vector-ref walk-cycle (frame-tween time)))))
- timer))
+ (move (position-tween time)
+ (vector-ref walk-cycle (frame-tween time))))
+ (signal-timer)))
(define camera (orthographic-camera 640 480))
-(add-hook! draw-hook (lambda _ (draw-group (signal-ref scene) camera)))
+(add-hook! draw-hook (lambda _ (draw-model (signal-ref scene) camera)))
(with-window (make-window #:title "Animation")
(start-game-loop))
diff --git a/examples/font.scm b/examples/font.scm
index 177879e..b3fcfc3 100644
--- a/examples/font.scm
+++ b/examples/font.scm
@@ -24,7 +24,7 @@
(sly render color)
(sly render font)
(sly render model)
- (sly render group)
+ (sly render model)
(sly input mouse))
(load "common.scm")
@@ -34,21 +34,20 @@
(define font (load-default-font 18))
(define-signal message-label
- (group-move (vector2 320 240)
- (group
- (label font "The quick brown fox jumped over the lazy dog."
- #:anchor 'center))))
+ (move (vector2 320 240)
+ (label font "The quick brown fox jumped over the lazy dog."
+ #:anchor 'center)))
(define-signal fps-label
(signal-map (lambda (fps)
(let ((text (format #f "FPS: ~d" fps)))
- (group-move (vector2 0 480) (group (label font text)))))
+ (move (vector2 0 480) (label font text))))
fps))
(define-signal mouse-label
(signal-map (lambda (p)
(let ((text (format #f "Mouse: (~d, ~d)" (vx p) (vy p))))
- (group-move (vector2 0 460) (group (label font text)))))
+ (move (vector2 0 460) (label font text))))
(signal-throttle 5 mouse-position)))
(define-signal scene
@@ -56,7 +55,7 @@
(define camera (orthographic-camera 640 480))
-(add-hook! draw-hook (lambda _ (draw-group (signal-ref scene) camera)))
+(add-hook! draw-hook (lambda _ (draw-model (signal-ref scene) camera)))
(with-window (make-window #:title "Fonts")
(start-game-loop))
diff --git a/examples/joystick.scm b/examples/joystick.scm
index 57955c9..7aa83c7 100644
--- a/examples/joystick.scm
+++ b/examples/joystick.scm
@@ -28,7 +28,6 @@
(sly input joystick)
(sly render camera)
(sly render model)
- (sly render group)
(sly render sprite)
(sly render texture)
(sly render font))
@@ -56,8 +55,7 @@
(define-signal caption
(signal-map (lambda (text)
- (group-move (vector2 -76 -90)
- (group (label font text))))
+ (move (vector2 -76 -90) (label font text)))
(signal-merge
(make-signal "Press a button")
(button-caption-signal "Hello there" 0)
@@ -67,13 +65,12 @@
(define-signal scene
(signal-map (lambda (position caption)
- (group-move position
- (group player caption)))
+ (move position (group player caption)))
player-position caption))
(define camera (orthographic-camera (vx resolution) (vy resolution)))
-(add-hook! draw-hook (lambda _ (draw-group (signal-ref scene) camera)))
+(add-hook! draw-hook (lambda _ (draw-model (signal-ref scene) camera)))
(add-hook! joystick-axis-hook
(lambda (which axis value)
diff --git a/examples/mines/mines.scm b/examples/mines/mines.scm
index 97d77b0..663e146 100644
--- a/examples/mines/mines.scm
+++ b/examples/mines/mines.scm
@@ -37,7 +37,6 @@
(sly render camera)
(sly render color)
(sly render font)
- (sly render group)
(sly render model)
(sly render sprite)
(sly input keyboard)
@@ -332,24 +331,24 @@
(lambda (tile)
;; A tile may or may not have an overlay, so we do a little
;; quasiquoting magic to build the right list.
- (make-group
+ (group*
`(,(tile-base-sprite tile)
,@(let ((overlay (tile-overlay-sprite tile)))
(if overlay
- (list (group-place offset (group overlay)))
+ (list (place offset (group overlay)))
'())))))))
(define-signal board-view
(signal-map (lambda (board)
(define (draw-column tile x)
- (group-move (vector2 (* x tile-size) 0)
- (draw-tile tile)))
+ (move (vector2 (* x tile-size) 0)
+ (draw-tile tile)))
(define (draw-row row y)
- (group-move (vector2 0 (* y tile-size))
- (make-group (enumerate-map draw-column row))))
+ (move (vector2 0 (* y tile-size))
+ (group* (enumerate-map draw-column row))))
- (make-group (enumerate-map draw-row board)))
+ (group* (enumerate-map draw-row board)))
board))
(define-signal status-message
@@ -357,9 +356,9 @@
(define (make-message message)
(label font message #:anchor 'center))
- (group-move
+ (move
(vector2 (/ (vx resolution) 2) (- (vy resolution) 64))
- (make-group
+ (group*
(cond
((board-lose? board)
(list (make-message "GAME OVER - Press N to play again")))
@@ -372,7 +371,7 @@
(signal-map (lambda (board-view status center-position)
(group
status
- (group-move center-position board-view)))
+ (move center-position board-view)))
board-view status-message center-position))
(define camera
@@ -382,7 +381,7 @@
#:clear-color tango-dark-plum)))
(define (draw-scene dt alpha)
- (draw-group (signal-ref scene) camera))
+ (draw-model (signal-ref scene) camera))
;;;
;;; Initialization
diff --git a/examples/simple.scm b/examples/simple.scm
index 9560f6f..1596cfe 100644
--- a/examples/simple.scm
+++ b/examples/simple.scm
@@ -17,20 +17,23 @@
(use-modules (sly game)
(sly window)
+ (sly utils)
(sly math vector)
(sly render camera)
- (sly render group)
- (sly render sprite))
+ (sly render model)
+ (sly render sprite)
+ (sly render color))
(load "common.scm")
(define scene
- (group-move (vector2 320 240)
- (group (load-sprite "images/p1_front.png"))))
+ (chain (load-sprite "images/p1_front.png")
+ (paint red)
+ (move (vector2 320 240))))
(define camera (orthographic-camera 640 480))
-(add-hook! draw-hook (lambda _ (draw-group scene camera)))
+(add-hook! draw-hook (lambda _ (draw-model scene camera)))
(with-window (make-window #:title "Simple Sprite Demo")
(start-game-loop))
diff --git a/examples/tilemap.scm b/examples/tilemap.scm
index 1615c88..5e54bde 100644
--- a/examples/tilemap.scm
+++ b/examples/tilemap.scm
@@ -26,7 +26,6 @@
(sly utils)
(sly render camera)
(sly render color)
- (sly render group)
(sly render model)
(sly render mesh)
(sly render shader)
@@ -91,15 +90,15 @@
(225 225 176 242 65 65 65 65 65 65 65 65 65 65 65 65 65 65 65 65))))
(define scene
- (group-move (v- (vector2 320 240)
- (v* (vector2 tile-width tile-height)
- (vector2 10 15/2)))
- (apply group (compile-tile-layer map-tiles 32 32))))
+ (move (v- (vector2 320 240)
+ (v* (vector2 tile-width tile-height)
+ (vector2 10 15/2)))
+ (group* (compile-tile-layer map-tiles 32 32))))
(define camera
(orthographic-camera 640 480))
-(add-hook! draw-hook (lambda _ (draw-group scene camera)))
+(add-hook! draw-hook (lambda _ (draw-model scene camera)))
(with-window (make-window #:title "Tilemap")
(start-game-loop))
diff --git a/sly/render/group.scm b/sly/render/group.scm
deleted file mode 100644
index 9cfc062..0000000
--- a/sly/render/group.scm
+++ /dev/null
@@ -1,137 +0,0 @@
-;;; Sly
-;;; Copyright (C) 2014 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:
-;;
-;; Hierarchy of renderable objects using a directed acyclic graph
-;; structure.
-;;
-;;; Code:
-
-(define-module (sly render group)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-9)
- #:use-module (sly math transform)
- #:use-module (sly render shader)
- #:use-module (sly render texture)
- #:use-module (sly render utils)
- #:use-module (sly render camera)
- #:use-module (sly render context)
- #:use-module (sly render model)
- #:export (make-group group
- group?
- group-transform group-visible? group-children
- draw-group
- group-move group-place group-show))
-
-;;;
-;;; Group
-;;;
-
-;; The composite object of the scene graph. Groups have zero or more
-;; children, which may be groups or models.
-(define-record-type <group>
- (%make-group transform visible? children)
- group?
- (transform group-transform)
- (visible? group-visible?)
- (children group-children))
-
-(define* (make-group children #:optional #:key (transform identity-transform)
- (visible? #t))
- "Create a new group containing CHILDREN in which each child is
-rendered relative to TRANSFORM. The VISIBLE? flag determines whether
-or not to render child nodes."
- (%make-group transform visible? children))
-
-(define (%draw-group group parent-transform view context)
- (match group
- (($ <group> transform visible? children)
- (when visible?
- (with-temp-transform context world-transform
- (transform*! world-transform transform parent-transform)
- (for-each (lambda (child)
- (let ((draw (match child
- ((? group? group) %draw-group)
- ((? model? model) draw-model))))
- (draw child world-transform view context)))
- children))))))
-
-(define (set-transform-identity! t)
- (let ((matrix (transform-matrix t)))
- (array-set! matrix 1 0 0)
- (array-set! matrix 0 0 1)
- (array-set! matrix 0 0 2)
- (array-set! matrix 0 0 3)
- (array-set! matrix 0 1 0)
- (array-set! matrix 1 1 1)
- (array-set! matrix 0 1 2)
- (array-set! matrix 0 1 3)
- (array-set! matrix 0 2 0)
- (array-set! matrix 0 2 1)
- (array-set! matrix 1 2 2)
- (array-set! matrix 0 2 3)
- (array-set! matrix 0 3 0)
- (array-set! matrix 0 3 1)
- (array-set! matrix 0 3 2)
- (array-set! matrix 1 3 3)))
-
-(define draw-group
- (let ((context (make-render-context)))
- (lambda* (group camera #:optional (context context))
- "Draw the scene defined by GROUP as viewed by CAMERA, with the given
-render CONTEXT."
- (with-render-context context
- (with-temp-transform context view
- (transform*! view
- (camera-location camera)
- (camera-projection camera))
- (with-temp-transform context base-transform
- (set-transform-identity! base-transform)
- (apply-viewport (camera-viewport camera))
- (%draw-group group base-transform view context)))))))
-
-;;;
-;;; Utility Procedures
-;;;
-
-(define (group . children)
- "Create a new group containing the list of CHILDREN."
- (make-group children))
-
-(define (group-move position group)
- "Create a new group in which the list of CHILDREN are translated by
-the vector POSITION."
- (match group
- (($ <group> transform visible? children)
- (%make-group (transform* transform (translate position))
- visible? children))))
-
-(define (group-place transform group)
- "Create a new group in which the tranformation matrices of the
-CHILDREN are multiplied by TRANSFORM."
- (match group
- (($ <group> original-transform visible? children)
- (%make-group (transform* original-transform transform)
- visible? children))))
-
-(define (group-show visible? group)
- "Create a new group in which the visibility of the list of
-CHILDREN is determined by the VISIBLE? flag."
- (match group
- (($ <group> transform _ children)
- (%make-group transform visible? children))))
diff --git a/sly/render/model.scm b/sly/render/model.scm
index b42dd64..01c1223 100644
--- a/sly/render/model.scm
+++ b/sly/render/model.scm
@@ -40,29 +40,35 @@
#:use-module (sly render mesh)
#:export (make-model model model-inherit
model?
- model-mesh model-texture model-shader model-color
- model-blend-mode model-depth-test?
+ model-mesh model-transform model-texture model-shader model-color
+ model-blend-mode model-depth-test? model-children
draw-model
- model-paint model-blend))
+ paint blend group group* move place))
;; Representation of a single OpenGL render call.
(define-record-type <model>
- (%make-model mesh texture shader color blend-mode depth-test?)
+ (%make-model mesh transform texture shader color blend-mode
+ depth-test? children)
model?
(mesh model-mesh)
+ (transform model-transform)
(texture model-texture)
(shader model-shader)
(color model-color)
(blend-mode model-blend-mode)
- (depth-test? model-depth-test?))
+ (depth-test? model-depth-test?)
+ (children model-children))
-(define* (make-model #:optional #:key (mesh #f) (texture #f) (shader #f)
- (color white) (blend-mode default-blend-mode)
- (depth-test? #t))
+(define* (make-model #:optional #:key (mesh null-mesh)
+ (transform identity-transform) (texture null-texture)
+ (shader (load-default-shader)) (color white)
+ (blend-mode default-blend-mode) (depth-test? #t)
+ (children '()))
"Create a new model from MESH and the given rendering state. When
rendering, TEXTURE and SHADER are bound, BLEND-MODE and DEPTH-TEST?
are set, and the COLOR uniform variable is set."
- (%make-model mesh texture shader color blend-mode depth-test?))
+ (%make-model mesh transform texture shader color blend-mode
+ depth-test? children))
(define model make-model)
@@ -90,35 +96,93 @@ changing the fields specified in KWARGS."
(struct-ref original index))))
fields field-indices))))))
-(define (draw-model model world-transform view context)
- "Render MODEL by applying its transform (multiplied by VIEW), texture,
+(define (set-transform-identity! t)
+ (let ((matrix (transform-matrix t)))
+ (array-set! matrix 1 0 0)
+ (array-set! matrix 0 0 1)
+ (array-set! matrix 0 0 2)
+ (array-set! matrix 0 0 3)
+ (array-set! matrix 0 1 0)
+ (array-set! matrix 1 1 1)
+ (array-set! matrix 0 1 2)
+ (array-set! matrix 0 1 3)
+ (array-set! matrix 0 2 0)
+ (array-set! matrix 0 2 1)
+ (array-set! matrix 1 2 2)
+ (array-set! matrix 0 2 3)
+ (array-set! matrix 0 3 0)
+ (array-set! matrix 0 3 1)
+ (array-set! matrix 0 3 2)
+ (array-set! matrix 1 3 3)))
+
+(define draw-model
+ (let ((context (make-render-context)))
+ (lambda* (model camera #:optional (context context))
+ "Render MODEL by applying its transform (multiplied by VIEW), texture,
shader, vertex array, uniforms, blend mode, etc. to the render
CONTEXT."
- (match model
- (($ <model> mesh texture shader color blend-mode depth-test?)
- (with-temp-transform context mvp
- (transform*! mvp world-transform view)
- (set-render-context-depth-test?! context depth-test?)
- (set-render-context-blend-mode! context blend-mode)
- (set-render-context-shader! context shader)
- (set-render-context-mesh! context mesh)
- (set-render-context-texture! context texture)
- ;; TODO: Support user-defined uniforms.
- (uniform-set! shader "mvp" mvp)
- (uniform-set! shader "color" color)
- (glDrawElements (begin-mode triangles)
- (mesh-length mesh)
- (data-type unsigned-int)
- %null-pointer)))))
+ (define (iter model world-transform view context)
+ (match model
+ (($ <model> mesh transform texture shader color blend-mode
+ depth-test? children)
+ (with-temp-transform context new-transform
+ (transform*! new-transform transform world-transform)
+ (with-temp-transform context mvp
+ (transform*! mvp new-transform view)
+ (set-render-context-depth-test?! context depth-test?)
+ (set-render-context-blend-mode! context blend-mode)
+ (set-render-context-shader! context shader)
+ (set-render-context-mesh! context mesh)
+ (set-render-context-texture! context texture)
+ ;; TODO: Support user-defined uniforms.
+ (uniform-set! shader "mvp" mvp)
+ (uniform-set! shader "color" color)
+ (glDrawElements (begin-mode triangles)
+ (mesh-length mesh)
+ (data-type unsigned-int)
+ %null-pointer))
+ (for-each (lambda (child)
+ (iter child new-transform view context))
+ children)))))
+
+ (with-render-context context
+ (with-temp-transform context view
+ (transform*! view
+ (camera-location camera)
+ (camera-projection camera))
+ (with-temp-transform context base-transform
+ (set-transform-identity! base-transform)
+ (apply-viewport (camera-viewport camera))
+ (iter model base-transform view context)))))))
;;;
;;; Utility Procedures
;;;
-(define (model-paint color model)
+(define (paint color model)
"Create a copy of MODEL, but with a new COLOR."
(model-inherit model #:color color))
-(define (model-blend blend-mode model)
+(define (blend blend-mode model)
"Create a copy of MODEL, but with a new BLEND-MODE."
(model-inherit model #:blend-mode blend-mode))
+
+(define (group . children)
+ "Create a new group containing the list of CHILDREN."
+ (make-model #:children children))
+
+(define (group* children)
+ "Create a new group containing the list of CHILDREN."
+ (make-model #:children children))
+
+(define (move position model)
+ "Create a new group in which the list of CHILDREN are translated by
+the vector POSITION."
+ (model-inherit model #:transform (transform* (model-transform model)
+ (translate position))))
+
+(define (place transform model)
+ "Create a new group in which the tranformation matrices of the
+CHILDREN are multiplied by TRANSFORM."
+ (model-inherit model #:transform (transform* (model-transform model)
+ transform)))