path: root/renderer.scm

(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)
    (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))
           (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-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