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

;;; Lisp Game Jam 2018
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;; Copyright © 2021 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This program 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.
;;;
;;; This program 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/>.

(define-module (engine node-2d)
  #:use-module (chickadee)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics font)
  #:use-module (chickadee graphics framebuffer)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics sprite)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 match)
  #:use-module (engine assets)
  #:use-module (engine node)
  #:use-module (oop goops)
  #:export (<camera-2d>
            target
            view-matrix
            projection-matrix
            framebuffer

            <view>
            camera
            area

            <canvas>
            cameras
            views

            <node-2d>
            origin
            position
            rotation
            scale
            z
            render-position
            local-matrix
            world-matrix
            dirty-matrix?
            set-origin
            move
            move-to
            teleport
            rotate
            rotate-to
            zoom
            zoom-to

            <sprite>
            texture
            offset

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

            <filled-rect>
            region
            color

            <label>
            font
            text))


;;;
;;; 2D canvas
;;;

;; 2D scenes are drawn on a canvas. A canvas renders the view of the
;; scene from one or more cameras.  To display the camera output, one
;; or more views are used to display the camera output on a region of
;; the screen.  Cameras follow their target nodes around the scene.

(define-class <camera-2d> ()
  (target #:accessor target #:init-form #f #:init-keyword #:target)
  (offset #:getter offset #:init-form (vec2 0.0 0.0) #:init-keyword #:offset)
  (position #:getter position #:init-form (vec2 0.0 0.0))
  (last-position #:getter last-position #:init-form (vec2 0.0 0.0))
  (projection-matrix #:getter projection-matrix
                     #:init-form (orthographic-projection 0 320 240 0 0 1)
                     #:init-keyword #:projection)
  ;; Combined projection/view matrix
  (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4))
  (framebuffer #:getter framebuffer
               #:init-form (make-framebuffer 320 240
                                             #:min-filter 'nearest
                                             #:mag-filter 'nearest)
               #:init-keyword #:framebuffer))

(define-method (update (camera <camera-2d>))
  (when (target camera)
    (let ((pos (position camera))
          (last-pos (last-position camera))
          (offset (offset camera))
          (target-pos (position (target camera)))
          (m (view-matrix camera)))
      (vec2-copy! pos last-pos)
      ;; TODO: Allow subclasses to define their own camera movement
      (set-vec2-x! pos (- (vec2-x offset) (vec2-x target-pos)))
      (set-vec2-y! pos (- (vec2-y offset) (vec2-y target-pos)))
      (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-method (draw (camera <camera-2d>) node alpha)
  (set-current-camera! camera)
  (with-framebuffer (framebuffer camera)
    (with-projection (if (target camera)
                         (view-matrix camera)
                         (projection-matrix camera))
      (each-child (lambda (child)
                    (draw/children child alpha))
                  node))))

(define-class <view> ()
  (camera #:accessor camera #:init-form #f #:init-keyword #:camera)
  (area #:getter area #:init-form (make-rect 0.0 0.0 320.0 240.0)
        #:init-keyword #:area)
  (matrix #:getter matrix #:init-form (make-identity-matrix4)))

(define-method (draw (view <view>))
  (draw-sprite* (framebuffer-texture (framebuffer (camera view)))
                (area view)
                (matrix view)))

(define-class <canvas> (<node>)
  (cameras #:accessor cameras #:init-form '() #:init-keyword #:cameras)
  (views #:accessor views #:init-form '() #:init-keyword #:views)
  (current-camera #:allocation #:class #:init-form #f))

(define (current-camera)
  (class-slot-ref <canvas> 'current-camera))

(define (set-current-camera! camera)
  (class-slot-set! <canvas> 'current-camera camera))

(define-method (update (canvas <canvas>) dt)
  (for-each update (cameras canvas)))

(define-method (draw/children (canvas <canvas>) alpha)
  ;; Draw children from the viewpoint of each camera.
  (when (visible? canvas)
    (for-each (lambda (camera)
                (draw camera canvas alpha))
              (cameras canvas))
    (set-current-camera! #f)
    (draw canvas alpha)))

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



;;;
;;; 2D nodes
;;;

(define-class <node-2d> (<node>)
  (origin #:getter origin #:init-form (vec2 0.0 0.0)
          #:init-keyword #:origin)
  (position #:getter position #:init-form (vec2 0.0 0.0)
            #:init-keyword #:position)
  (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation)
  (scale #:getter scale #:init-form (vec2 1.0 1.0) #:init-keyword #:scale)
  (skew #:getter skew #:init-form (vec2 0.0 0.0) #:init-keyword #:skew)
  ;; Some extra position vectors for defeating "temporal aliasing"
  ;; when rendering.
  (last-position #:getter last-position #:init-form (vec2 0.0 0.0))
  (render-position #:getter render-position #:init-form (vec2 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 (dirty! node)
  (set! (dirty-matrix? node) #t))

(define-method (set-origin (node <node-2d>) x y)
  (let ((o (origin node)))
    (set-vec2-x! o x)
    (set-vec2-y! o y)
    (dirty! node)))

(define-method (move (node <node-2d>) dx dy)
  (let ((p (position node)))
    (set-vec2-x! p (+ (vec2-x p) dx))
    (set-vec2-y! p (+ (vec2-y p) dy))
    (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 (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 (node <node-2d>) dtheta)
  (set! (rotation node) (+ (rotation node) dtheta))
  (dirty! node))

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

(define-method (zoom (node <node-2d>) dsx dsy)
  (let ((s (scale node)))
    (set-vec2-x! s (+ (vec2-x s) dsx))
    (set-vec2-y! s (+ (vec2-y s) dsy))
    (dirty! node)))

(define-method (zoom (node <node-2d>) ds)
  (zoom node ds ds))

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

(define-method (zoom-to (node <node-2d>) s)
  (zoom-to node s s))

(define (compute-matrices! node)
  (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)))))

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

(define-method (draw/children (node <node-2d>) alpha)
  ;; 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.
    (each-child (lambda (node) (set! (dirty-matrix? node) #t)) node))
  (next-method))

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


;;;
;;; Sprites
;;;

(define-class <sprite> (<node-2d>)
  (texture #:accessor texture #:init-keyword #:texture)
  (tint #:accessor tint #:init-keyword #:tint #:init-form white))

(define-method (draw (sprite <sprite>) alpha)
  (draw-sprite* (asset-ref (texture sprite))
                (texture-gl-rect (texture sprite))
                (world-matrix sprite)
                #:tint (tint sprite)))

(define-class <animated-sprite> (<sprite>)
  (atlas #:accessor atlas #:init-keyword #:atlas)
  (animations #:accessor animations #:init-keyword #:animations)
  (frame-duration #:accessor frame-duration #:init-keyword #:frame-duration)
  (current-animation #:accessor current-animation
                     #:init-keyword #:current-animation)
  (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 sprite))
         (anim-duration (* frame-duration (vector-length anim)))
         (time (modulo (- (agenda-time) (start-time sprite)) anim-duration))
         (frame (vector-ref anim (floor (/ time frame-duration))))
         (texture-region (texture-atlas-ref (asset-ref (atlas sprite)) frame)))
    (set! (texture sprite) texture-region)
    (next-method)))

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


;;;
;;; Shapes
;;;

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

(define-method (draw (r <filled-rect>) alpha)
  (draw-canvas (make-canvas
                (with-style
                 ((fill-color (color r)))
                 (fill
                  (rectangle (vec2 (rect-left (region r))
                                   (rect-bottom (region r)))
                             (rect-width (region r))
                             (rect-height (region r)))))
                ;; TODO: wrong type
                ;#:matrix
                ;(world-matrix r)
                )))


;;;
;;; Text
;;;

(define-class <label> (<node-2d>)
  (font #:accessor font #:init-keyword #:font)
  (text #:accessor text #:init-form "" #:init-keyword #:text))

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