diff options
Diffstat (limited to 'renderer.scm')
| -rw-r--r-- | renderer.scm | 140 |
1 files changed, 140 insertions, 0 deletions
diff --git a/renderer.scm b/renderer.scm index 28c7079..e7daf11 100644 --- a/renderer.scm +++ b/renderer.scm @@ -3,12 +3,72 @@ (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 @@ -85,6 +145,19 @@ (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) @@ -98,4 +171,71 @@ (let ((tileset (tilemap-tileset 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-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) + (when (> (entity-ref e #:attack-timer 0) 0) + (let* ((px (inexact->exact (floor (entity-ref e #:x 0)))) + (py (inexact->exact (floor (entity-ref e #:y 0)))) + (pw (inexact->exact (floor (entity-ref e #:width 0)))) + (ph (inexact->exact (floor (entity-ref e #:height 0)))) + (facing (entity-ref e #:facing 1)) + (ax (if (> facing 0) (+ px pw) (- px tw)))) + (set! (sdl2:render-draw-color renderer) +debug-attack-color+) + (sdl2:render-fill-rect! renderer + (sdl2:make-rect (- ax cx) (- py cy) tw ph))))) + ((eq? type 'enemy) + (set! (sdl2:render-draw-color renderer) +debug-enemy-color+) + (sdl2:render-fill-rect! renderer rect) + (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)))) + (eh (inexact->exact (floor (entity-ref e #:height 0)))) + (facing (entity-ref e #:facing 1)) + (ax (if (> facing 0) (+ ex tw) (- 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)))))))) + (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 |