path: root/scenes/game.scm

;;; The Inevitable Game
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;;
;;; 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 (scenes game)
  #:use-module (chickadee input keyboard)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render color)
  #:use-module (chickadee render font)
  #:use-module (chickadee render shapes)
  #:use-module (chickadee render texture)
  #:use-module (chickadee render tiled)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (engine assets)
  #:use-module (engine node)
  #:use-module (engine node-2d)
  #:use-module (engine scene)
  #:use-module (oop goops)
  #:export (game))

(use-modules (chickadee)
;             (chickadee render sprite)
             (chickadee scripting))


(define %width 320)
(define %height 240)
(define %game-over #f)


(define-class <character> (<node-2d>)
  (velocity #:getter velocity #:init-form (vec2 0.0 0.0))
  (walk-speed #:accessor walk-speed #:init-form 0.8)
  (direction #:accessor direction #:init-form '(idle))
  (hitbox #:getter hitbox #:init-form (make-rect 8.0 0.0 16.0 16.0)))

(define-class <stats> (<node-2d>)
  (player #:accessor player #:init-form #f #:init-keyword #:player))

(define-method (walk (character <character>) directions . rest)
  (unless (equal? (direction character) directions)
    (let ((sprite (child-ref character 'sprite))
          (speed  (if (member 'stop rest) 0.0 (walk-speed character))))
      (change-animation sprite (last directions))
      (for-each (lambda (dir)
                  (case dir
                    ((right)
                     (set-vec2-x! (velocity character) speed))
                    ((left)
                     (set-vec2-x! (velocity character) (* -1.0 speed)))
                    ((up)
                     (set-vec2-y! (velocity character) speed))
                    ((down)
                     (set-vec2-y! (velocity character) (* -1.0 speed)))
                    ((idle)
                     (set-vec2-x! (velocity character) 0.0)
                     (set-vec2-y! (velocity character) 0.0)
                     (change-animation sprite (case (last (direction character))
                                                ((right) 'idle-right)
                                                ((left)  'idle-left)
                                                ((up)    'idle-back)
                                                ((down)  'idle-front))))))
                directions)
      (set! (direction character) directions))))

(define-class <player> (<character>)
  (previous-key-presses #:accessor previous-key-presses #:init-form (list))
  (lifetime #:accessor lifetime #:init-form 100)
  (happiness #:accessor happiness #:init-form 50)
  (weight #:accessor weight #:init-form 50)
  (music #:accessor music #:init-form 50)
  (career #:accessor career #:init-form 50)
  (curiosity #:accessor curiosity #:init-form 50))

(define (load-atlas file-name tile-width tile-height)
  (split-texture (load-image file-name) tile-width tile-height))

(define-asset player-atlas
  (load-atlas "assets/images/lorenzo.png" 32 32))

(define-method (populate (player <player>))
  (list
   (make <animated-sprite>
     #:name 'sprite
     #:atlas player-atlas
     #:animations '((idle-right . #(8 8 8 8 8 7 7 7 7 7))
                    (idle-left  . #(0 0 0 0 0 15 15 15 15 15))
                    (idle-front . #(24 24 24 24 24 32 32 32 32 32))
                    (idle-back  . #(16))
                    (left       . #(1 35 2 35))
                    (right      . #(9 34 10 34))
                    (up         . #(17 16 18 16))
                    (down       . #(25 24 26 24)))
     #:current-animation 'idle-front
     #:frame-duration 10)))


(define-class <reaper> (<character>)
  (talking #:accessor talking #:init-form #f))

(define-asset reaper-atlas
  (load-atlas "assets/images/reaper.png" 32 32))

(define-method (populate (reaper <reaper>))
  (list
   (make <animated-sprite>
     #:name 'sprite
     #:atlas reaper-atlas
     #:animations '((idle  . #(0 0 0 1 1 1 9 1 1 1 8 8 8 8 8 8 5 4 4 4 0 0 0 3 3))
                    (pause . #(4 4 4 4 4 4 4 5))
                    (talk  . #(0 3 2 7 5 4 6 5 3 2 2 2 4 4 0 0 0)))
     #:current-animation 'idle
     #:frame-duration 20)))


(define-asset test-map (load-tile-map "assets/maps/01.tmx"))

(define-class <game> (<scene>)
  (tile-map #:accessor tile-map #:init-form test-map)
  (collision-hitbox #:getter collision-hitbox #:init-form (make-rect 0.0 0.0 0.0 0.0)))

(define-class <top-layer> (<node-2d>)
  (tile-map #:accessor tile-map #:init-form test-map))

(define-asset game-font
  (load-tile-font "assets/fonts/bubblemad_8x8.png" 8 8
                  " !\"©_%❤'()*+,-./0123456789:←<=>?@abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))

;; TODO: hack :(
;; TODO: It's ugly to use the global variable %player here, but
;; (player stats) below always returns #f.
(define %player #f)

(define-method (populate (game <game>))
  (let ((player (make <player>
                  #:name 'player
                  #:position (vec2 620.0 1100.0)
                  #:children
                  ;; Simple player shadow.  This should better be done
                  ;; with a single ellipse shader.
                  (let ((color (make-color 0 0 0 0.2)))
                    (map (lambda (n x w)
                           (make <filled-rect>
                             #:region (make-rect 0.0 0.0 w 1.0)
                             #:position (vec2 x (- 2 n))
                             #:color color))
                         ;; position in the stack
                         (iota 5)
                         ;; x offsets
                         (list 12 10 8 10 12)
                         ;; widths
                         (list 8 12 16 12 8))))))
    (set! %player player)
    (list (make <reaper>
            #:name 'reaper
            #:position (vec2 720.0 1100.0)
            #:children
            ;; Simple shadow.  This should better be done with a
            ;; single ellipse shader.
            (let ((color (make-color 0 0 0 0.2)))
              (map (lambda (n x w)
                     (make <filled-rect>
                       #:region (make-rect 0.0 0.0 w 1.0)
                       #:position (vec2 (+ 3 x) (- 2 n))
                       #:color color))
                   ;; position in the stack
                   (iota 5)
                   ;; x offsets
                   (list 12 10 8 10 12)
                   ;; widths
                   (list 12 16 20 16 12))))
          (make <filled-rect>
            #:name 'hit
            #:region (make-rect 0.0 0.0 0.0 0.0)
            #:position (vec2 0 0)
            #:color (transparency 0.2))
          player
          (make <top-layer>
            #:name 'top-layer
            #:position (vec2 0.0 0.0))
          (make <stats>
            #:name 'stats #:player player
            #:position (vec2 10.0 (- %height 10.0))))))

(define* (collides? player game #:key (layer "collision"))
  (let* ((pos (position player))
         (offset (origin game))
         (player-hitbox (hitbox player))
         (hitbox (collision-hitbox game))
         (hit-vis (region (child-ref game 'hit))))
    (set-rect-x! hitbox (+ (- (vec2-x offset)) (vec2-x pos) (rect-x player-hitbox)))
    (set-rect-y! hitbox (+ (- (vec2-y offset)) (vec2-y pos) (rect-y player-hitbox)))
    (set-rect-width! hitbox (rect-width player-hitbox))
    (set-rect-height! hitbox (rect-height player-hitbox))

    ;; TODO: memoize objects and shapes as they don't change.
    (any (lambda (obj)
           (let* ((r-wrong (map-object-shape obj))
                  ;; TODO: chickadee parses the object layer
                  ;; incorrectly, so all objects are flipped vertically.
                  (r (make-rect (rect-x r-wrong)
                                (- (rect-y r-wrong) (rect-height r-wrong))
                                (rect-width r-wrong)
                                (rect-height r-wrong))))
             (if (rect-intersects? hitbox r)
                 (begin
                   (set-rect-x! hit-vis (+ (rect-x r) (vec2-x offset)))
                   (set-rect-y! hit-vis (+ (rect-y r) (vec2-y offset)))
                   (set-rect-width! hit-vis (rect-width r))
                   (set-rect-height! hit-vis (rect-height r))
                   #t)
                 #f)))
         (object-layer-objects
          (tile-map-layer-ref (asset-ref (tile-map game)) layer)))))

(define-method (update (game <game>) dt)
  (let ((player (child-ref game 'player)))
    ;; Stop any motion in a direction when the matching key has just
    ;; been released.
    (let ((released (filter key-released? (previous-key-presses player))))
      (unless (null? released)
        (walk player released 'stop)))

    ;; React to current key presses
    (let ((active (fold (lambda (direction acc)
                          (if (key-pressed? direction)
                              (cons direction acc)
                              acc))
                        '()
                        '(left right up down))))
      (if (null? active)
          (walk player '(idle))
          (walk player active))
      (set! (previous-key-presses player) active))

    ;; Only move when the new position does not result in a collision.
    (let* ((pos (position player))
           (vel (velocity player)))
      (vec2-add! pos vel)
      (when (collides? player game #:layer "collision")
        (vec2-sub! pos vel))

      ;; TODO: express this on the map instead?
      ;; (when (> (vec2-x pos) 294.0)
      ;;   (set-vec2-x! pos 294.0))
      ;; (when (< (vec2-x pos) -6.0)
      ;;   (set-vec2-x! pos -6.0))
      ;; (when (> (vec2-y pos) (- %height 32.0))
      ;;   (set-vec2-y! pos (- %height 32.0)))
      ;; (when (< (vec2-y pos) 0.0)
      ;;   (set-vec2-y! pos 0.0))

      ;; Keep the player in the centre
      (move-to game
               (- 0 (vec2-x pos))
               (- 0 (vec2-y pos)))
      (move-to (child-ref game 'top-layer)
               (- 0 (vec2-x pos))
               (- 0 (vec2-y pos))))))

(define-method (draw (stats <stats>) alpha)
  (let* ((pos (position stats))
         (x (vec2-x pos))
         (y (vec2-y pos))
         (step 5)
         (thickness 2)
         (properties (list lifetime
                           happiness
                           weight
                           music
                           career
                           curiosity))
         ;; FIXME
         (player %player;(player stats)
          ))
    (for-each (lambda (property index)
                (let* ((value (property player))
                       (start (vec2 x (- y (* step index))))
                       (end-y (- y (* step index)))
                       (end   (vec2 (+ x 100) end-y)))
                  (draw-line start end
                             #:thickness thickness #:color red)
                  (when (> value 0)
                    (draw-line start (vec2 (+ x value) end-y)
                               #:thickness thickness #:color green))))
              properties
              (iota (length properties)))))

(define-method (draw (game <game>) alpha)
  (draw-tile-map (asset-ref (tile-map game))
                 #:position (position game)
                 #:layers (list 0 1 2 3)))

(define-method (draw (top-layer <top-layer>) alpha)
  (draw-tile-map (asset-ref (tile-map top-layer))
                 #:position (position top-layer)
                 ;; NOTE: this is the 5th tile layer; object layers
                 ;; are ignored.
                 #:layers (list 4)))


(define (decrease-lifetime)
  (let ((current-lifetime (lifetime %player)))
    (if (< current-lifetime 0)
        (set! %game-over 'old-age)
        (set! (lifetime %player) (- current-lifetime 1)))))

(define (game)
  (let ((game (make <game>
                #:origin (vec2 (- (/ %width 2))
                               (- (/ %height 2))))))
    (with-agenda (agenda game)
                 (schedule-every 120 decrease-lifetime))
    game))