From 38eee24832fe6da4f135cae455881ab97953b23a Mon Sep 17 00:00:00 2001 From: Gene Pasquet Date: Sat, 18 Apr 2026 02:47:10 +0100 Subject: Refresh docs and re-indent --- renderer.scm | 497 ++++++++++++++++++++++++++++++----------------------------- 1 file changed, 251 insertions(+), 246 deletions(-) (limited to 'renderer.scm') diff --git a/renderer.scm b/renderer.scm index b6ba238..50ae574 100644 --- a/renderer.scm +++ b/renderer.scm @@ -1,251 +1,256 @@ (module downstroke-renderer - * - (import scheme - (chicken base) - (only srfi-1 iota for-each) - srfi-69 - (prefix sdl2 "sdl2:") - (prefix sdl2-ttf "ttf:") - downstroke-entity - downstroke-tilemap - downstroke-world) - - (import defstruct) - - ;; --- Debug colors --- - - (define +debug-player-color+ (sdl2:make-color 64 128 255)) - (define +debug-enemy-color+ (sdl2:make-color 220 40 40)) - (define +debug-attack-color+ (sdl2:make-color 0 200 80)) - (define +debug-tile-color+ (sdl2:make-color 140 0 220)) - - ;; --- Sprite font data structure --- - - (defstruct sprite-font - tile-size ;; integer: pixel width/height of each glyph tile - spacing ;; integer: pixels between characters - char-map) ;; hash-table: char -> tile-id - - ;; Public constructor for sprite-font - ;; ranges: list of (start-char end-char first-tile-id) triples - (define (make-sprite-font* #!key tile-size (spacing 1) ranges) - (let ((ht (make-hash-table))) - (for-each - (lambda (range) - (let ((start-char (car range)) - (end-char (cadr range)) - (first-tile-id (caddr range))) - (let loop ((ch start-char) (tile-id first-tile-id)) - (when (char<=? ch end-char) - (let ((upcase-ch (char-upcase ch))) - (when (hash-table-exists? ht upcase-ch) - (error "sprite-font: overlapping range at char" upcase-ch)) - (hash-table-set! ht upcase-ch tile-id)) - (loop (integer->char (+ (char->integer ch) 1)) (+ tile-id 1)))))) - ranges) - (make-sprite-font tile-size: tile-size spacing: spacing char-map: ht))) - - ;; Look up char tile-id (always upcase) - (define (sprite-font-char->tile-id font ch) - (hash-table-ref/default (sprite-font-char-map font) (char-upcase ch) #f)) - - ;; Compute pixel width of text - (define (sprite-text-width font text) - (let ((n (string-length text))) - (if (zero? n) 0 - (+ (* n (sprite-font-tile-size font)) - (* (- n 1) (sprite-font-spacing font)))))) - - ;; Draw sprite text using a bitmap font - (define (draw-sprite-text renderer tileset-texture tileset font text x y) - (let ((ts (sprite-font-tile-size font)) - (sp (sprite-font-spacing font))) - (let loop ((i 0) (cx x)) - (when (< i (string-length text)) - (let ((tile-id (sprite-font-char->tile-id font (string-ref text i)))) - (when tile-id - (sdl2:render-copy! renderer tileset-texture - (tile-rect (tileset-tile tileset tile-id)) - (sdl2:make-rect cx y ts ts))) - (loop (+ i 1) (+ cx ts sp))))))) - - ;; --- Pure functions (no SDL2, testable) --- - - ;; Returns (x y w h) as a plain list — testable without SDL2 - (define (entity-screen-coords entity camera) - (list (- (inexact->exact (floor (entity-ref entity #:x 0))) (camera-x camera)) - (- (inexact->exact (floor (entity-ref entity #:y 0))) (camera-y camera)) - (inexact->exact (floor (entity-ref entity #:width 0))) - (inexact->exact (floor (entity-ref entity #:height 0))))) - - ;; Returns sdl2:rect for actual drawing - (define (entity->screen-rect entity camera) - (apply sdl2:make-rect (entity-screen-coords entity camera))) - - ;; Returns flip list based on #:facing field - (define (entity-flip entity) - (if (= (entity-ref entity #:facing 1) -1) '(horizontal) '())) - - ;; --- Tilemap drawing --- - - (define (draw-tile renderer camera tileset tileset-texture tile-id row-num col-num) - (let ((tile (tileset-tile tileset tile-id))) - (sdl2:render-copy! renderer tileset-texture - (tile-rect tile) - (sdl2:make-rect - (- (* col-num (tileset-tilewidth tileset)) (camera-x camera)) - (- (* row-num (tileset-tileheight tileset)) (camera-y camera)) - (tileset-tilewidth tileset) - (tileset-tileheight tileset))))) - - (define (draw-tilemap-rows draw-fn rows row-num) - (unless (null? rows) - (for-each - (cut draw-fn <> row-num <>) - (car rows) - (iota (length (car rows)))) - (draw-tilemap-rows draw-fn (cdr rows) (+ row-num 1)))) - - (define (draw-tilemap renderer camera tileset-texture tilemap) - (let ((map-layers (tilemap-layers tilemap)) - (tileset (tilemap-tileset tilemap))) - (for-each - (lambda (layer) - (draw-tilemap-rows - (cut draw-tile renderer camera tileset tileset-texture <> <> <>) - (layer-map layer) - 0)) - map-layers))) - - ;; --- Entity drawing --- - - ;; #:color is (r g b) or (r g b a); used when no tile sprite is drawn. - (define (draw-entity renderer camera tileset tileset-texture entity) - (if (entity-ref entity #:skip-render #f) - (void) - (let ((tile-id (entity-ref entity #:tile-id #f)) - (color (entity-ref entity #:color #f))) - (cond - ((and tile-id tileset tileset-texture) - (sdl2:render-copy-ex! renderer tileset-texture +* +(import scheme + (chicken base) + (only srfi-1 iota for-each) + srfi-69 + (prefix sdl2 "sdl2:") + (prefix sdl2-ttf "ttf:") + downstroke-entity + downstroke-tilemap + downstroke-world) + +(import defstruct) + +;; --- Debug colors --- + +(define +debug-player-color+ (sdl2:make-color 64 128 255)) +(define +debug-enemy-color+ (sdl2:make-color 220 40 40)) +(define +debug-attack-color+ (sdl2:make-color 0 200 80)) +(define +debug-tile-color+ (sdl2:make-color 140 0 220)) + +;; --- Sprite font data structure --- + +(defstruct sprite-font + tile-size ;; integer: pixel width/height of each glyph tile + spacing ;; integer: pixels between characters + char-map) ;; hash-table: char -> tile-id + +;; Public constructor for sprite-font +;; ranges: list of (start-char end-char first-tile-id) triples +(define (make-sprite-font* #!key tile-size (spacing 1) ranges) + (let ((ht (make-hash-table))) + (for-each + (lambda (range) + (let ((start-char (car range)) + (end-char (cadr range)) + (first-tile-id (caddr range))) + (let loop ((ch start-char) (tile-id first-tile-id)) + (when (char<=? ch end-char) + (let ((upcase-ch (char-upcase ch))) + (when (hash-table-exists? ht upcase-ch) + (error "sprite-font: overlapping range at char" upcase-ch)) + (hash-table-set! ht upcase-ch tile-id)) + (loop (integer->char (+ (char->integer ch) 1)) (+ tile-id 1)))))) + ranges) + (make-sprite-font tile-size: tile-size spacing: spacing char-map: ht))) + +;; Look up char tile-id (always upcase) +(define (sprite-font-char->tile-id font ch) + (hash-table-ref/default (sprite-font-char-map font) (char-upcase ch) #f)) + +;; Compute pixel width of text +(define (sprite-text-width font text) + (let ((n (string-length text))) + (if (zero? n) 0 + (+ (* n (sprite-font-tile-size font)) + (* (- n 1) (sprite-font-spacing font)))))) + +;; Draw sprite text using a bitmap font +(define (draw-sprite-text renderer tileset-texture tileset font text x y) + (let ((ts (sprite-font-tile-size font)) + (sp (sprite-font-spacing font))) + (let loop ((i 0) (cx x)) + (when (< i (string-length text)) + (let ((tile-id (sprite-font-char->tile-id font (string-ref text i)))) + (when tile-id + (sdl2:render-copy! renderer tileset-texture (tile-rect (tileset-tile tileset tile-id)) - (entity->screen-rect entity camera) - 0.0 - #f - (entity-flip entity))) - ((and (list? color) (>= (length color) 3)) - (let ((r (list-ref color 0)) - (g (list-ref color 1)) - (b (list-ref color 2)) - (a (if (>= (length color) 4) (list-ref color 3) 255))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a)) - (sdl2:render-fill-rect! renderer (entity->screen-rect entity camera)))) - (else #f))))) - - (define (draw-entities renderer camera tileset tileset-texture entities) + (sdl2:make-rect cx y ts ts))) + (loop (+ i 1) (+ cx ts sp))))))) + +;; --- Pure functions (no SDL2, testable) --- + +;; Returns (x y w h) as a plain list — testable without SDL2 +(define (entity-screen-coords entity camera) + (list (- (inexact->exact (floor (entity-ref entity #:x 0))) (camera-x camera)) + (- (inexact->exact (floor (entity-ref entity #:y 0))) (camera-y camera)) + (inexact->exact (floor (entity-ref entity #:width 0))) + (inexact->exact (floor (entity-ref entity #:height 0))))) + +;; Returns sdl2:rect for actual drawing +(define (entity->screen-rect entity camera) + (apply sdl2:make-rect (entity-screen-coords entity camera))) + +;; Returns flip list based on #:facing field +(define (entity-flip entity) + (if (= (entity-ref entity #:facing 1) -1) '(horizontal) '())) + +;; --- Tilemap drawing --- + +(define (draw-tile renderer camera tileset tileset-texture tile-id row-num col-num) + (let ((tile (tileset-tile tileset tile-id))) + (sdl2:render-copy! renderer tileset-texture + (tile-rect tile) + (sdl2:make-rect + (- (* col-num (tileset-tilewidth tileset)) (camera-x camera)) + (- (* row-num (tileset-tileheight tileset)) (camera-y camera)) + (tileset-tilewidth tileset) + (tileset-tileheight tileset))))) + +(define (draw-tilemap-rows draw-fn rows row-num) + (unless (null? rows) + (for-each + (cut draw-fn <> row-num <>) + (car rows) + (iota (length (car rows)))) + (draw-tilemap-rows draw-fn (cdr rows) (+ row-num 1)))) + +(define (draw-tilemap renderer camera tileset-texture tilemap) + (let ((map-layers (tilemap-layers tilemap)) + (tileset (tilemap-tileset tilemap))) + (for-each + (lambda (layer) + (draw-tilemap-rows + (cut draw-tile renderer camera tileset tileset-texture <> <> <>) + (layer-map layer) + 0)) + map-layers))) + +;; --- Entity drawing --- + +;; #:color is (r g b) or (r g b a); used when no tile sprite is drawn. +(define (draw-entity renderer camera tileset tileset-texture entity) + (if (entity-ref entity #:skip-render #f) + (void) + (let ((tile-id (entity-ref entity #:tile-id #f)) + (color (entity-ref entity #:color #f))) + (cond + ((and tile-id tileset tileset-texture) + (sdl2:render-copy-ex! renderer tileset-texture + (tile-rect (tileset-tile tileset tile-id)) + (entity->screen-rect entity camera) + 0.0 + #f + (entity-flip entity))) + ((and (list? color) (>= (length color) 3)) + (let ((r (list-ref color 0)) + (g (list-ref color 1)) + (b (list-ref color 2)) + (a (if (>= (length color) 4) (list-ref color 3) 255))) + (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a)) + (sdl2:render-fill-rect! renderer (entity->screen-rect entity camera)))) + (else #f))))) + +(define (draw-entities renderer camera tileset tileset-texture entities) + (for-each + (lambda (e) (draw-entity renderer camera tileset tileset-texture e)) + entities)) + +;; --- Text drawing --- + +(define (draw-ui-text renderer font text color x y) + (let* ((surface (ttf:render-text-solid font text color)) + (texture (sdl2:create-texture-from-surface renderer surface)) + (dims (call-with-values (lambda () (ttf:size-utf8 font text)) cons)) + (w (car dims)) + (h (cdr dims))) + (sdl2:render-copy! renderer texture #f + (sdl2:make-rect x y w h)))) + +;; --- Menu drawing --- + +(define (draw-menu-items renderer font items cursor x y-start y-step + #!key (label-fn identity) (color #f) (prefix "> ") (no-prefix " ")) + (let loop ((i 0) (rest items)) + (unless (null? rest) + (draw-ui-text renderer font + (string-append (if (= i cursor) prefix no-prefix) + (label-fn (car rest))) + (or color (sdl2:make-color 255 255 255)) + x (+ y-start (* i y-step))) + (loop (+ i 1) (cdr rest))))) + +;; --- Scene drawing --- + +(define (render-scene! renderer scene) + (let* ((camera (scene-camera scene)) + (tilemap (scene-tilemap scene)) + (scene-ts (scene-tileset scene)) + (tileset-texture (scene-tileset-texture scene)) + (entities (scene-entities scene)) + ;; Resolve the tileset for rect math independently of the + ;; texture. draw-entity itself guards on the texture, so sprite + ;; entities still fall back to #:color rendering when no texture + ;; is available (instead of being silently dropped). + (tileset (or scene-ts (and tilemap (tilemap-tileset tilemap))))) + (when (and tilemap tileset-texture) + (draw-tilemap renderer camera tileset-texture tilemap)) + (draw-entities renderer camera tileset tileset-texture entities))) + +;; --- Debug drawing --- + +(define (draw-debug-tiles renderer camera tilemap) + (let ((tw (tilemap-tilewidth tilemap)) + (th (tilemap-tileheight tilemap)) + (cx (camera-x camera)) + (cy (camera-y camera))) + (set! (sdl2:render-draw-color renderer) +debug-tile-color+) + (for-each + (lambda (layer) + (let row-loop ((rows (layer-map layer)) (row 0)) + (unless (null? rows) + (let col-loop ((tiles (car rows)) (col 0)) + (unless (null? tiles) + (unless (zero? (car tiles)) + (sdl2:render-fill-rect! renderer + (sdl2:make-rect (- (* col tw) cx) + (- (* row th) cy) + tw th))) + (col-loop (cdr tiles) (+ col 1)))) + (row-loop (cdr rows) (+ row 1))))) + (tilemap-layers tilemap)))) + +(define (draw-attack-hitbox renderer e tw cx cy) + (when (> (entity-ref e #:attack-timer 0) 0) + (let* ((ex (inexact->exact (floor (entity-ref e #:x 0)))) + (ey (inexact->exact (floor (entity-ref e #:y 0)))) + (ew (inexact->exact (floor (entity-ref e #:width 0)))) + (eh (inexact->exact (floor (entity-ref e #:height 0)))) + (facing (entity-ref e #:facing 1)) + (ax (if (> facing 0) (+ ex ew) (- ex tw)))) + (set! (sdl2:render-draw-color renderer) +debug-attack-color+) + (sdl2:render-fill-rect! renderer + (sdl2:make-rect (- ax cx) (- ey cy) tw eh))))) + +(define (draw-debug-entities renderer camera scene) + (let* ((tilemap (scene-tilemap scene)) + ;; Hitbox thickness falls back to the entity's own width when + ;; no tilemap is present (sprite-only scenes). + (tw (and tilemap (tilemap-tilewidth tilemap))) + (cx (camera-x camera)) + (cy (camera-y camera))) (for-each - (lambda (e) (draw-entity renderer camera tileset tileset-texture e)) - entities)) - - ;; --- Text drawing --- - - (define (draw-ui-text renderer font text color x y) - (let* ((surface (ttf:render-text-solid font text color)) - (texture (sdl2:create-texture-from-surface renderer surface)) - (dims (call-with-values (lambda () (ttf:size-utf8 font text)) cons)) - (w (car dims)) - (h (cdr dims))) - (sdl2:render-copy! renderer texture #f - (sdl2:make-rect x y w h)))) - - ;; --- Menu drawing --- - - (define (draw-menu-items renderer font items cursor x y-start y-step - #!key (label-fn identity) (color #f) (prefix "> ") (no-prefix " ")) - (let loop ((i 0) (rest items)) - (unless (null? rest) - (draw-ui-text renderer font - (string-append (if (= i cursor) prefix no-prefix) - (label-fn (car rest))) - (or color (sdl2:make-color 255 255 255)) - x (+ y-start (* i y-step))) - (loop (+ i 1) (cdr rest))))) - - ;; --- Scene drawing --- - - (define (render-scene! renderer scene) - (let* ((camera (scene-camera scene)) - (tilemap (scene-tilemap scene)) - (scene-ts (scene-tileset scene)) - (tileset-texture (scene-tileset-texture scene)) - (entities (scene-entities scene)) - (tileset - (and tileset-texture - (or scene-ts (and tilemap (tilemap-tileset tilemap)))))) - (when tilemap - (draw-tilemap renderer camera tileset-texture tilemap)) - (draw-entities renderer camera tileset tileset-texture entities))) - - ;; --- Debug drawing --- - - (define (draw-debug-tiles renderer camera tilemap) - (let ((tw (tilemap-tilewidth tilemap)) - (th (tilemap-tileheight tilemap)) - (cx (camera-x camera)) - (cy (camera-y camera))) - (set! (sdl2:render-draw-color renderer) +debug-tile-color+) - (for-each - (lambda (layer) - (let row-loop ((rows (layer-map layer)) (row 0)) - (unless (null? rows) - (let col-loop ((tiles (car rows)) (col 0)) - (unless (null? tiles) - (unless (zero? (car tiles)) - (sdl2:render-fill-rect! renderer - (sdl2:make-rect (- (* col tw) cx) - (- (* row th) cy) - tw th))) - (col-loop (cdr tiles) (+ col 1)))) - (row-loop (cdr rows) (+ row 1))))) - (tilemap-layers tilemap)))) - - (define (draw-attack-hitbox renderer e tw cx cy) - (when (> (entity-ref e #:attack-timer 0) 0) - (let* ((ex (inexact->exact (floor (entity-ref e #:x 0)))) - (ey (inexact->exact (floor (entity-ref e #:y 0)))) - (ew (inexact->exact (floor (entity-ref e #:width 0)))) - (eh (inexact->exact (floor (entity-ref e #:height 0)))) - (facing (entity-ref e #:facing 1)) - (ax (if (> facing 0) (+ ex ew) (- ex tw)))) - (set! (sdl2:render-draw-color renderer) +debug-attack-color+) - (sdl2:render-fill-rect! renderer - (sdl2:make-rect (- ax cx) (- ey cy) tw eh))))) - - (define (draw-debug-entities renderer camera scene) - (let* ((tilemap (scene-tilemap scene)) - (tw (tilemap-tilewidth tilemap)) - (cx (camera-x camera)) - (cy (camera-y camera))) - (for-each - (lambda (e) - (let ((type (entity-type e)) - (rect (entity->screen-rect e camera))) - (cond - ((eq? type 'player) - (set! (sdl2:render-draw-color renderer) +debug-player-color+) - (sdl2:render-fill-rect! renderer rect) - (draw-attack-hitbox renderer e tw cx cy)) - ((eq? type 'enemy) - (set! (sdl2:render-draw-color renderer) +debug-enemy-color+) - (sdl2:render-fill-rect! renderer rect) - (draw-attack-hitbox renderer e tw cx cy))))) - (scene-entities scene)))) - - (define (render-debug-scene! renderer scene) - (let ((camera (scene-camera scene)) - (tilemap (scene-tilemap scene))) - (when tilemap - (draw-debug-tiles renderer camera tilemap)) - (draw-debug-entities renderer camera scene))) + (lambda (e) + (let ((type (entity-type e)) + (rect (entity->screen-rect e camera)) + (hit-w (or tw (entity-ref e #:width 0)))) + (cond + ((eq? type 'player) + (set! (sdl2:render-draw-color renderer) +debug-player-color+) + (sdl2:render-fill-rect! renderer rect) + (draw-attack-hitbox renderer e hit-w cx cy)) + ((eq? type 'enemy) + (set! (sdl2:render-draw-color renderer) +debug-enemy-color+) + (sdl2:render-fill-rect! renderer rect) + (draw-attack-hitbox renderer e hit-w cx cy))))) + (scene-entities scene)))) + +(define (render-debug-scene! renderer scene) + (let ((camera (scene-camera scene)) + (tilemap (scene-tilemap scene))) + (when tilemap + (draw-debug-tiles renderer camera tilemap)) + (draw-debug-entities renderer camera scene))) ) ;; end module renderer -- cgit v1.2.3