;;; The Inevitable Game ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2018 David Thompson ;;; ;;; 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 ;;; . (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 (engine shell) #:use-module (oop goops) ;; Game modules #:use-module ((scenes death) #:select (death)) #:use-module (characters) #:use-module (characters lorenzo) #:use-module (characters reaper) #:use-module (utils) #:use-module (config) #:export (game)) (use-modules (chickadee) (chickadee scripting)) (define-class () (object #:accessor object #:init-form #f #:init-keyword #:object)) (define-asset test-map (load-tile-map "assets/maps/01.tmx")) (define-class () (status #:accessor status #:init-form 'playing) (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 () (tile-map #:accessor tile-map #:init-form test-map)) (define-asset game-font (load-font "assets/fonts/good_neighbors_starling.xml")) (define (start-position game name) "Look up the start position for an object with the given NAME in the map's object layer." (let ((positions (filter (lambda (obj) (eq? 'start-position (map-object-type obj))) (object-layer-objects (tile-map-layer-ref (asset-ref (tile-map game)) "positions")))) (offset (origin game))) (or (and=> (find (lambda (obj) (equal? (map-object-name obj) name)) positions) (lambda (obj) (let ((shape (map-object-shape obj))) (vec2 (+ (vec2-x offset) (rect-x shape)) (+ (vec2-y offset) (rect-y shape)))))) (vec2 0.0 0.0)))) (define-method (populate (game )) (let ((player (lorenzo #:position (start-position game "player")))) (list (reaper (start-position game "reaper")) (make #:name 'hit #:region (make-rect 0.0 0.0 0.0 0.0) #:position (vec2 0 0) #:color (transparency 0.2)) player (make #:name 'top-layer #:position (vec2 0.0 0.0)) (make #:name 'stats #:object player #:position (vec2 10.0 (- %height 10.0)))))) (define-method (collides? (player ) (game ) layer) (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)) obj) #f))) (object-layer-objects (tile-map-layer-ref (asset-ref (tile-map game)) layer))))) (define-method (update (game ) dt) ;; Keep the player in the centre (let* ((player (child-ref game 'player)) (pos (position player))) (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))) (or (and=> (talking? player) ;; Use arrow keys to select a message, hit action key to ;; confirm the selection. (lambda (who) ;; Render the player messages in the selected order. (unless (speaking? who) (let ((bubble (child-ref (parent (parent player)) 'text-bubble)) (messages (accepted-messages who))) (clear-messages bubble) (fold (lambda (message n lines) (match message ((message text . flags) (when (zero? n) (attach bubble (make #:name 'dialog-selection-indicator #:region (make-rect 0.0 0.0 5 10) #:position (vec2 0 65) #:color region))) (+ lines (render-text bubble text #:suffix message #:y-offset (+ (* n %message-margin) (* lines %line-height))))))) 0 messages (iota (length messages))))) ;; Always end on #T to avoid passing through to the ;; motion branch. #t)) ;; React to current key presses with motion. We don't use the ;; on-key-press handler here, because it does not seem to behave ;; right when two keys are pressed at the same time (e.g. left ;; and up). (begin ;; 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))) ;; Detect newly pressed keys. (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)) ;; Update player position and respond to position-dependent ;; events. (let* ((pos (position player)) (vel (velocity player))) (vec2-add! pos vel) ;; Reset when the new position is invalid. (when (collides? player game "collision") (vec2-sub! pos vel))))))) (define-method (on-key-press (game ) key modifiers repeat?) (let ((player (child-ref game 'player))) (when (eq? key 'q) (switch-scene (root-node) (death))) (let ((who (talking? player))) (cond ((and (not who) (eq? 'space key)) (handle-action player)) ((and who (not repeat?)) (handle-talking player key)))))) (define (handle-action player) "Check if the PLAYER is on any region of the map where an action can be executed; if so, perform the action." (let ((game (parent player))) (and=> (collides? player game "actions") (lambda (obj) (match (map-object-name obj) ("enter-house" (teleport player 560.0 1800.0) ;; TODO: change music? (pause-music)) ("exit-house" (teleport player 620.0 1100.0) (resume-music)) ("talk-to-reaper" (start-talking player (child-ref game 'reaper))) (_ #t)))))) (define (handle-talking player key) (define who (talking? player)) ;; Use arrow keys to select a message, hit action key to ;; confirm the selection. (match (cond ((wants-to-stop-talking? player) '()) ((assoc-ref (resume-messages player) (name who)) => list) (else (accepted-messages who))) ;; Nothing more to say, so just wait for the action key to ;; be hit to dismiss the dialogue. (() (when (eq? 'space key) (set! (speaking? who) #f) ; TODO? (stop-talking player))) ((and ((and (message text . flags) selected) . rest) messages) (cond ;; Select previous message ((eq? 'up key) (set! (accepted-messages who) (append (list (last messages)) (drop-right messages 1))) (set! (selecting-message? player) 'up)) ;; Select next message ((eq? 'down key) (set! (accepted-messages who) (append rest (list selected))) (set! (selecting-message? player) 'down)) ;; Submit selected message. ((and (eq? 'space key) (not (speaking? who))) ;; Delete remembered resume point if it exists, because we want ;; to only use them once. (when (assoc-ref (resume-messages player) (name who)) (set! (resume-messages player) (acons (name who) #f (resume-messages player)))) (and=> (member #:resume flags) (match-lambda ((#:resume (and (message text) pair)) (set! (resume-messages player) (acons (name who) pair (resume-messages player))) (set! (accepted-messages who) (list message)) (set! (wants-to-stop-talking? player) #t)))) (talk player who message)) ;; Dismiss character's text. ((and (eq? 'space key) (speaking? who)) (set! (speaking? who) #f)))) (_ (pk 'this-should-never-happen #t)))) (define-method (talk (player ) (who ) message) "Send MESSAGE to WHO and display the response." (let ((bubble (child-ref (parent (parent player)) 'text-bubble))) (match (assoc-ref (conversations who) message) ((text next) (set! (speaking? who) #t) (set! (talking? player) who) ;; Clear any shown messages. (clear-messages bubble) ;; Display new message. (render-text bubble text) ;; Record continuations. (set! (accepted-messages who) next)) ;; This should never happen, because there should always be a ;; conversation matching a message. (oops (pk 'oops #t))))) (define-method (start-talking (player ) (who )) (unless (equal? (talking? player) who) (let ((bubble (child-ref (parent (parent player)) 'text-bubble))) (clear-messages bubble) (set! (visible? bubble) #t)) (set! (talking? player) who))) (define-method (stop-talking (player )) (when (talking? player) (set! (visible? (child-ref (parent (parent player)) 'text-bubble)) #f) (set! (talking? player) #f) (set! (wants-to-stop-talking? player) #f))) (define* (render-text bubble text #:key (y-offset 0) (suffix '-text)) "Fill the bubble with lines of text. Return the number of lines." (let ((lines (arrange-text text (asset-ref game-font) #:margin 4.0))) (for-each (lambda (line i) (attach bubble (make