diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | README.org | 7 | ||||
| -rwxr-xr-x | examples/2048/2048.scm | 72 | ||||
| -rw-r--r-- | examples/animation.scm | 13 | ||||
| -rw-r--r-- | examples/font.scm | 15 | ||||
| -rw-r--r-- | examples/joystick.scm | 9 | ||||
| -rw-r--r-- | examples/mines/mines.scm | 23 | ||||
| -rw-r--r-- | examples/simple.scm | 13 | ||||
| -rw-r--r-- | examples/tilemap.scm | 11 | ||||
| -rw-r--r-- | sly/render/group.scm | 137 | ||||
| -rw-r--r-- | sly/render/model.scm | 122 |
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 \ @@ -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))) |