path: root/lisparuga/node-2d.scm

;;; Lisparuga
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Lisparuga 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.
;;;
;;; Lisparuga 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 Lisparuga.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; 2D game nodes.
;;
;;; Code:

(define-module (lisparuga node-2d)
  #:use-module (chickadee math bezier)
  #:use-module (chickadee math easings)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render)
  #:use-module (chickadee render color)
  #:use-module (chickadee render font)
  #:use-module (chickadee render framebuffer)
  #:use-module (chickadee render particles)
  #:use-module (chickadee render shapes)
  #:use-module (chickadee render sprite)
  #:use-module (chickadee render texture)
  #:use-module (chickadee render tiled)
  #:use-module (chickadee render viewport)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (sdl2 video)
  #:use-module (lisparuga asset)
  #:use-module (lisparuga kernel)
  #:use-module (lisparuga node)
  #:use-module (lisparuga scene)
  #:export (<camera-2d>
            target
            offset
            position
            width
            height

            <view-2d>
            camera
            area

            <canvas>
            views

            <scene-2d>

            <node-2d>
            origin
            position
            rotation
            scale
            skew
            local-matrix
            world-matrix
            dirty!
            pivot
            move-by
            move-to
            teleport
            rotate-by
            rotate-to
            scale-by
            scale-to
            follow-bezier-path

            <sprite>
            texture
            texcoords
            source-rect
            blend-mode
            tint

            <atlas-sprite>
            atlas
            index

            <animation>
            frames
            frame-duration

            <animated-sprite>
            animations
            frame-duration
            current-animation
            start-time
            change-animation

            <sprite-batch>
            batch

            <filled-rect>
            region
            color

            <label>
            font
            text

            <tile-map>
            tile-map
            layers

            <particles>
            particles))


;;;
;;; 2D Camera
;;;

;; Cameras define a view into the scene.  They are attached to a 2D
;; node and follow it around.

(define-class <camera-2d> ()
  (target #:accessor target #:init-form #f #:init-keyword #:target)
  (offset #:getter offset #:init-form #v(0.0 0.0) #:init-keyword #:offset)
  (position #:getter position #:init-form #v(0.0 0.0))
  (last-position #:getter last-position #:init-form #v(0.0 0.0))
  (width #:getter width #:init-keyword #:width)
  (height #:getter height #:init-keyword #:height)
  (projection-matrix #:accessor projection-matrix)
  ;; Combined projection/view matrix
  (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4))
  (framebuffer #:accessor framebuffer))

(define-method (initialize (camera <camera-2d>) initargs)
  (next-method)
  ;; Initialize framebuffer and orthographic projection matrix based
  ;; on the resolution of the camera.
  (set! (framebuffer camera)
        (make-framebuffer (width camera)
                          (height camera)
                          #:min-filter 'nearest
                          #:mag-filter 'nearest))
  (set! (projection-matrix camera)
        (orthographic-projection 0 (width camera) (height camera) 0 0 1)))

;; This method can be overridden by subclasses to create custom camera
;; movement.
(define-method (follow-target (camera <camera-2d>) dt)
  (let ((pos (position camera))
        (target-pos (position (target camera)))
        (offset (offset camera)))
    (set-vec2-x! pos (- (vec2-x offset) (vec2-x target-pos)))
    (set-vec2-y! pos (- (vec2-y offset) (vec2-y target-pos)))))

(define-method (update (camera <camera-2d>) dt)
  (when (target camera)
    (let ((pos (position camera))
          (last-pos (last-position camera))
          (m (view-matrix camera)))
      (vec2-copy! pos last-pos)
      (follow-target camera dt)
      (unless (and (= (vec2-x pos) (vec2-x last-pos))
                   (= (vec2-y pos) (vec2-y last-pos)))
        (matrix4-translate! m pos)
        (matrix4-mult! m m (projection-matrix camera))))))

(define-syntax-rule (with-camera camera body ...)
  (with-framebuffer (framebuffer camera)
    (clear-screen)
    (with-projection (if (target camera)
                         (view-matrix camera)
                         (projection-matrix camera))
      body ...)))



;;;
;;; 2D View
;;;

;; Views render the output of a camera to a portion of the game
;; window.

(define-class <view-2d> ()
  (camera #:accessor camera #:init-keyword #:camera)
  (area #:getter area #:init-keyword #:area)
  (clear-color #:getter clear-color #:init-keyword #:clear-color
               #:init-value tango-light-sky-blue)
  (viewport #:accessor viewport)
  (projection-matrix #:accessor projection-matrix)
  (sprite-rect #:accessor sprite-rect))

(define-method (initialize (view <view-2d>) initargs)
  (next-method)
  (let* ((area (area view))
         (x (rect-x area))
         (y (rect-y area))
         (w (rect-width area))
         (h (rect-height area)))
    (set! (viewport view)
      (make-viewport (inexact->exact x)
                     (inexact->exact y)
                     (inexact->exact w)
                     (inexact->exact h)
                     #:clear-color (clear-color view)))
    (set! (sprite-rect view) (make-rect 0.0 0.0 w h))
    (set! (projection-matrix view) (orthographic-projection 0 w h 0 0 1))))

(define %identity-matrix (make-identity-matrix4))

(define-method (render (view <view-2d>))
  (with-viewport (viewport view)
    (with-projection (projection-matrix view)
      (draw-sprite* (framebuffer-texture (framebuffer (camera view)))
                    (sprite-rect view)
                    %identity-matrix))))


;;;
;;; 2D Canvas
;;;

;; The canvas is the root of a 2D scene.  It handles rendering one or
;; more views.

(define (make-default-views)
  (match (window-size (window (current-kernel)))
    ((width height)
     (list
      (make <view-2d>
        #:camera (make <camera-2d>
                   #:width width
                   #:height height)
        #:area (make-rect 0 0 width height))))))

(define-class <canvas> (<node>)
  (views #:accessor views #:init-thunk make-default-views
         #:init-keyword #:views))

(define-method (update (canvas <canvas>) dt)
  (for-each (lambda (view)
              (update (camera view) dt))
            (views canvas)))

(define-method (render-tree (canvas <canvas>) alpha)
  ;; Draw scene from the viewpoint of each camera.
  (for-each (lambda (view)
              (with-camera (camera view)
                           (for-each (lambda (child)
                                       (render-tree child alpha))
                                     (children canvas))))
            (views canvas))
  (render canvas alpha))

(define-method (render (canvas <canvas>) alpha)
  (for-each render (views canvas)))


;;;
;;; 2D Scene
;;;

(define-class <scene-2d> (<scene> <canvas>))


;;;
;;; 2D Game Node
;;;

(define-class <node-2d> (<node>)
  (origin #:getter origin #:init-form #v(0.0 0.0) #:init-keyword #:origin)
  (position #:getter position #:init-form #v(0.0 0.0) #:init-keyword #:position)
  (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation)
  (scale #:getter scale #:init-form #v(1.0 1.0) #:init-keyword #:scale)
  (skew #:getter skew #:init-form #v(0.0 0.0) #:init-keyword #:skew)
  ;; Some extra position vectors for defeating "temporal aliasing"
  ;; when rendering.
  (last-position #:getter last-position #:init-form #v(0.0 0.0))
  (render-position #:getter render-position #:init-form #v(0.0 0.0))
  ;; Lazily computed transformation matrices.
  (local-matrix #:getter local-matrix #:init-form (make-identity-matrix4))
  (world-matrix #:getter world-matrix #:init-form (make-identity-matrix4))
  (dirty-matrix? #:accessor dirty-matrix? #:init-form #t))

(define-method (dirty! (node <node-2d>))
  (set! (dirty-matrix? node) #t))

(define-method (compute-matrices! (node <node-2d>))
  (let ((local (local-matrix node))
        (world (world-matrix node)))
    (matrix4-2d-transform! local
                           #:origin (origin node)
                           #:position (render-position node)
                           #:rotation (rotation node)
                           #:scale (scale node)
                           #:skew (skew node))
    ;; Compute world matrix by multiplying by the parent node's
    ;; matrix, if there is a 2D parent node, that is.
    (if (and (parent node) (is-a? (parent node) <node-2d>))
        (matrix4-mult! world local (world-matrix (parent node)))
        (begin
          (matrix4-identity! world)
          (matrix4-mult! world world local)))))

;; Animation helpers

(define-method (pivot (node <node-2d>) x y)
  "Change origin of NODE to (X, Y)."
  (let ((o (origin node)))
    (set-vec2-x! o x)
    (set-vec2-y! o y)
    (dirty! node)))

(define-method (move-to (node <node-2d>) x y)
  (let ((p (position node)))
    (set-vec2-x! p x)
    (set-vec2-y! p y)
    (dirty! node)))

(define-method (move-to (node <node-2d>) x y duration ease)
  (let ((p (position node)))
    (move-by node (- x (vec2-x p)) (- y (vec2-y p)) duration ease)))

(define-method (move-to (node <node-2d>) x y duration)
  (move-to node x y duration smoothstep))

(define-method (move-by (node <node-2d>) dx dy)
  (let ((p (position node)))
    (move-to node (+ (vec2-x p) dx) (+ (vec2-y p) dy))))

(define-method (move-by (node <node-2d>) dx dy duration ease)
  (let* ((p (position node))
         (start-x (vec2-x p))
         (start-y (vec2-y p)))
    (tween duration 0.0 1.0
           (lambda (n)
             (move-to node
                      (+ start-x (* dx n))
                      (+ start-y (* dy n))))
           #:ease ease)))

(define-method (move-by (node <node-2d>) dx dy duration)
  (move-by node dx dy duration smoothstep))

(define-method (teleport (node <node-2d>) x y)
  (move-to node x y)
  (let ((lp (last-position node)))
    (set-vec2-x! lp x)
    (set-vec2-y! lp y)))

(define-method (rotate-to (node <node-2d>) theta)
  (set! (rotation node) theta)
  (dirty! node))

(define-method (rotate-to (node <node-2d>) theta duration ease)
  (tween duration (rotation node) theta
         (lambda (r)
           (rotate-to node r))
         #:ease ease))

(define-method (rotate-to (node <node-2d>) theta duration)
  (rotate-to node theta duration smoothstep))

(define-method (rotate-by (node <node-2d>) dtheta)
  (rotate-to node (+ (rotation node) dtheta)))

(define-method (rotate-by (node <node-2d>) dtheta duration ease)
  (rotate-to node (+ (rotation node) dtheta) duration ease))

(define-method (rotate-by (node <node-2d>) dtheta duration)
  (rotate-by node dtheta duration smoothstep))

(define-method (scale-to (node <node-2d>) sx sy)
  (let ((s (scale node)))
    (set-vec2-x! s sx)
    (set-vec2-y! s sy)
    (dirty! node)))

(define-method (scale-to (node <node-2d>) sx sy duration ease)
  (let ((s (scale node)))
    (scale-by node (- sx (vec2-x s)) (- sy (vec2-y s)) duration ease)))

(define-method (scale-to (node <node-2d>) sx sy duration)
  (scale-to node sx sy duration smoothstep))

(define-method (scale-by (node <node-2d>) dsx dsy)
  (let ((s (scale node)))
    (scale-to node (+ (vec2-x s) dsx) (+ (vec2-y s) dsy))))

(define-method (scale-by (node <node-2d>) dsx dsy duration ease)
  (let* ((s (scale node))
         (start-x (vec2-x s))
         (start-y (vec2-y s)))
    (tween duration 0.0 1.0
           (lambda (n)
             (scale-to node
                       (+ start-x (* dsx n))
                       (+ start-y (* dsy n))))
           #:ease ease)))

(define-method (scale-by (node <node-2d>) dsx dsy duration)
  (scale-by node dsx dsy duration smoothstep))

(define-method (follow-bezier-path (node <node-2d>) path duration forward?)
  (let ((p (position node))
        (path (if forward? path (reverse path))))
    (for-each (lambda (bezier)
                (tween duration
                       (if forward? 0.0 1.0)
                       (if forward? 1.0 0.0)
                       (lambda (t)
                         (bezier-curve-point-at! p bezier t)
                         (dirty! node))
                       #:ease linear))
              path)))

(define-method (follow-bezier-path (node <node-2d>) path duration)
  (follow-bezier-path node path duration #t))

;; Events

(define-method (update-tree (node <node-2d>) dt)
  (vec2-copy! (position node) (last-position node))
  (next-method))

(define-method (render-tree (node <node-2d>) alpha)
  (when (visible? node)
    ;; Compute the linearly interpolated rendering position, in the case
    ;; that node has moved since the last update.
    (let ((p (position node))
          (lp (last-position node))
          (rp (render-position node))
          (beta (- 1.0 alpha)))
      (unless (and (= (vec2-x lp) (vec2-x rp))
                   (= (vec2-y lp) (vec2-y rp)))
        (set-vec2-x! rp (+ (* (vec2-x p) alpha) (* (vec2-x lp) beta)))
        (set-vec2-y! rp (+ (* (vec2-y p) alpha) (* (vec2-y lp) beta)))
        (set! (dirty-matrix? node) #t)))
    ;; Recompute dirty matrices.
    (when (dirty-matrix? node)
      (compute-matrices! node)
      (set! (dirty-matrix? node) #f)
      ;; If the parent is dirty, all the children need to be marked as
      ;; dirty, too.
      (for-each (lambda (node)
                  (set! (dirty-matrix? node) #t))
                (children node))))
  (next-method))

(define-method (activate (node <node-2d>))
  (set! (dirty-matrix? node) #t)
  ;; Set the initial last position to the same as the initial position
  ;; to avoid a brief flash where the node appears at (0, 0).
  (vec2-copy! (position node) (last-position node))
  (next-method))


;;;
;;; Base Sprite
;;;

(define-class <base-sprite> (<node-2d>)
  (batch #:accessor batch
         #:init-keyword #:batch
         #:init-form #f)
  (tint #:accessor tint
        #:init-keyword #:tint
        #:init-form white)
  (blend-mode #:accessor blend-mode
              #:init-keyword #:blend-mode
              #:init-form 'alpha))

(define-generic texture)

(define-method (texcoords (sprite <base-sprite>))
  (texture-gl-tex-rect (asset-ref (texture sprite))))

(define-method (source-rect (sprite <base-sprite>))
  (texture-gl-rect (asset-ref (texture sprite))))

(define-method (render (sprite <base-sprite>) alpha)
  (let* ((tex (asset-ref (texture sprite)))
         (rect (source-rect sprite))
         (batch (batch sprite))
         (tint (tint sprite))
         (matrix (world-matrix sprite)))
    (if batch
        (sprite-batch-add* batch rect matrix
                           #:tint tint
                           #:texture-region tex)
        (draw-sprite* tex rect matrix
                      #:tint tint
                      #:texcoords (texcoords sprite)))))


;;;
;;; Static Sprite
;;;

(define-class <sprite> (<base-sprite>)
  (texture #:getter texture #:init-keyword #:texture)
  (texcoords #:init-keyword #:texcoords #:init-form #f)
  (source-rect #:init-keyword #:source-rect #:init-form #f))

(define-method (texcoords (sprite <sprite>))
  (or (slot-ref sprite 'texcoords)
      (next-method)))

(define-method (source-rect (sprite <sprite>))
  (or (slot-ref sprite 'source-rect)
      (next-method)))


;;;
;;; Texture Atlas Sprite
;;;

(define-class <atlas-sprite> (<base-sprite>)
  (atlas #:accessor atlas #:init-keyword #:atlas)
  (index #:accessor index #:init-keyword #:index))

(define-method (texture (sprite <atlas-sprite>))
  (texture-atlas-ref (asset-ref (atlas sprite)) (index sprite)))


;;;
;;; Animated Sprite
;;;

(define-class <animation> ()
  (frames #:getter frames #:init-keyword #:frames)
  (frame-duration #:getter frame-duration #:init-keyword #:frame-duration
                  #:init-form 250))

(define-class <animated-sprite> (<atlas-sprite>)
  (animations #:accessor animations #:init-keyword #:animations)
  (current-animation #:accessor current-animation
                     #:init-keyword #:default-animation
                     #:init-form 'default)
  (start-time #:accessor start-time #:init-form 0))

(define-method (on-enter (sprite <animated-sprite>))
  (update sprite 0))

(define-method (update (sprite <animated-sprite>) dt)
  (let* ((anim (assq-ref (animations sprite) (current-animation sprite)))
         (frame-duration (frame-duration anim))
         (frames (frames anim))
         (anim-duration (* frame-duration (vector-length frames)))
         (time (modulo (- (elapsed-time) (start-time sprite)) anim-duration))
         (frame (vector-ref frames (floor (/ time frame-duration)))))
    (set! (index sprite) frame)
    (next-method)))

(define-method (change-animation (sprite <animated-sprite>) name)
  (set! (current-animation sprite) name)
  (set! (start-time sprite) (elapsed-time)))


;;;
;;; Sprite Batch
;;;

(define-class <sprite-batch> (<node-2d>)
  (batch #:accessor batch #:init-keyword #:batch)
  (blend-mode #:accessor blend-mode
              #:init-keyword #:blend-mode
              #:init-form 'alpha)
  (clear-after-draw? #:accessor clear-after-draw?
                     #:init-keyword #:clear-after-draw?
                     #:init-form #t)
  (batch-matrix #:accessor batch-matrix #:init-thunk make-identity-matrix4))

(define-method (render (sprite-batch <sprite-batch>) alpha)
  (let ((batch (batch sprite-batch)))
    (draw-sprite-batch* batch (batch-matrix sprite-batch)
                        #:blend-mode (blend-mode sprite-batch))
    (when (clear-after-draw? sprite-batch)
      (sprite-batch-clear! batch))))


;;;
;;; Filled Rectangle
;;;

(define-class <filled-rect> (<node-2d>)
  (region #:accessor region #:init-keyword #:region)
  (color #:accessor color #:init-form black #:init-keyword #:color))

(define-method (render (r <filled-rect>) alpha)
  (draw-filled-rect (region r) (color r) #:matrix (world-matrix r)))


;;;
;;; Text
;;;

(define-class <label> (<node-2d>)
  (font #:accessor font #:init-keyword #:font #:init-thunk default-font)
  (text #:accessor text #:init-form "" #:init-keyword #:text)
  (align #:accessor align #:init-value 'left #:init-keyword #:align)
  (vertical-align #:accessor vertical-align #:init-value 'bottom
                  #:init-keyword #:vertical-align))

(define-method (initialize (label <label>) initargs)
  (next-method)
  (realign label))

(define-method ((setter text) (label <label>) s)
  (slot-set! label 'text s)
  (realign label))

(define-method (realign (label <label>))
  (let ((font (asset-ref (font label))))
    (set-vec2! (origin label)
               (match (align label)
                 ('left 0.0)
                 ('right (font-line-width font (text label)))
                 ('center (/ (font-line-width font (text label)) 2.0)))
               (match (vertical-align label)
                 ('bottom 0.0)
                 ('top (font-line-height font))
                 ('center (/ (font-line-height font) 2.0)))))
  (dirty! label))

(define-method (render (label <label>) alpha)
  (draw-text* (asset-ref (font label)) (text label) (world-matrix label)))


;;;
;;; Tiled Map
;;;

(define-class <tile-map> (<node-2d>)
  (tile-map #:accessor tile-map #:init-keyword #:map)
  (layers #:accessor layers #:init-keyword #:layers #:init-form #f))

(define-method (initialize (node <tile-map>) initargs)
  (next-method))

(define-method (render (node <tile-map>) alpha)
  (let ((m (asset-ref (tile-map node))))
    (draw-tile-map* m (world-matrix node) (tile-map-rect m)
                    #:layers (layers node))))


;;;
;;; Particles
;;;

(define-class <particles> (<node-2d>)
  (particles #:accessor particles #:init-keyword #:particles))

(define-method (update (node <particles>) dt)
  (update-particles (particles node)))

(define-method (render (node <particles>) alpha)
  (draw-particles* (particles node) (world-matrix node)))