path: root/engine/shell.scm

;;; Lisp Game Jam 2018
;;; 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 (engine shell)
  #:use-module (chickadee)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render)
  #:use-module (chickadee render font)
  #:use-module (chickadee render framebuffer)
  #:use-module (chickadee render sprite)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (engine assets)
  #:use-module (engine node)
  #:use-module (engine node-2d)
  #:use-module (oop goops)
  #:use-module (sdl2)
  #:use-module (srfi srfi-26)
  #:use-module (system repl command)
  #:use-module (system repl coop-server)
  #:use-module (system repl debug)
  #:use-module (system repl repl)
  #:export (make-shell
            current-scene
            switch-scene))

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

(define %scale-factor 2)
(define %height (* %scale-factor 240))
(define %width (* %scale-factor 320))

(define-class <shell> (<node>)
  (debug? #:allocation #:virtual
          #:accessor debug?
          #:slot-ref (lambda (shell)
                       (visible? (child-ref shell 'debug-overlay)))
          #:slot-set! (lambda (shell show?)
                        (set! (visible? (child-ref shell 'debug-overlay))
                              show?)))
  (repl #:accessor repl #:init-form #f)
  (repl-debug #:accessor repl-debug #:init-form #f)
  (repl-debugging? #:accessor repl-debugging? #:init-form #f)
  (current-scene #:accessor current-scene #:init-form #f
                 #:init-keyword #:current-scene)
  (reset #:getter reset-thunk #:init-form #f #:init-keyword #:reset)
  (framebuffer #:getter framebuffer
               #:init-form (make-framebuffer %width %height
                                             #:min-filter 'nearest
                                             #:mag-filter 'nearest))
  (fb-region #:getter fb-region
             #:init-form (make-rect 0.0 0.0
                                    (* %scale-factor %width)
                                    (* %scale-factor %height)))
  (projection #:getter projection
              #:init-form (orthographic-projection 0
                                                   (/ %width %scale-factor)
                                                   (/ %height %scale-factor) 0 0 1))
  (frame-start-time #:accessor frame-start-time)
  (avg-frame-time #:accessor avg-frame-time #:init-value 0.0)
  (eval-prompt #:accessor eval-prompt
               #:init-form (make <node-2d>
                             #:name 'eval-prompt
                             #:children
                             (list
                              (make <label>
                                #:name 'prompt
                                #:font shell-font
                                #:text ">"
                                #:position (vec2 0.0 0.0))
                              (make <label>
                                #:name 'source
                                #:font shell-font
                                #:text "(+ 1 2 3)"
                                #:position (vec2 16.0 0.0))))))

(define (error-string stack key args)
  (call-with-output-string
   (lambda (port)
     (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
       (print-exception port frame key args)))))

(define-method (handle-error stack key args)
  (let* ((shell (root-node))
         (tag (and (pair? (fluid-ref %stacks))
                   (cdr (fluid-ref %stacks))))
         (stack (narrow-stack->vector
                 stack
                 ;; Take the stack from the given frame, cutting 0
                 ;; frames.
                 0
                 ;; Narrow the end of the stack to the most recent
                 ;; start-stack.
                 tag
                 ;; And one more frame, because %start-stack
                 ;; invoking the start-stack thunk has its own frame
                 ;; too.
                 0 (and tag 1))))
    (set! (repl-debug shell)
          (make-debug stack 0 (error-string stack key args)))
    (set! (repl-debugging? shell) #t)
    (while (repl-debugging? shell)
      (poll-coop-repl-server (repl shell)))))

;(add-hook! error-hook handle-error)

(define-meta-command ((debug-game chickadee) repl)
  "debug-game
Enter a debugger for the current game loop error."
  (let ((shell (root-node)))
    (format #t "~a~%" (debug-error-message (repl-debug shell)))
    (format #t "Entering a new prompt.  ")
    (format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n")
    (start-repl #:debug (repl-debug shell))
    (set! (repl-debugging? shell) #f)))

(define-method (before-draw)
  (set! (frame-start-time (root-node)) (sdl-ticks)))

(define-method (after-draw)
  (let ((end (sdl-ticks))
        (start (frame-start-time (root-node)))
        (last (avg-frame-time (root-node))))
    (set! (avg-frame-time (root-node))
          (+ (* (- end start) 0.1) (* last 0.9)))))

(add-hook! before-draw-hook before-draw)
(add-hook! after-draw-hook after-draw)

(define (switch-scene shell new-scene)
  (detach (current-scene shell))
  (set! (current-scene shell) new-scene)
  (attach shell new-scene))

(define-method (fps (shell <shell>))
  (exact->inexact (/ 1000 (avg-frame-time shell))))

(define-method (populate (shell <shell>))
  (list
   (make <node-2d>
     #:name 'debug-overlay
     #:visible? #f
     #:children
     (list
      (make <label>
        #:name 'fps-label
        #:font shell-font
        #:text "0.0"
        #:position (vec2 0.0 232.0))))))

(define-method (on-start (shell <shell>))
  (set! (repl shell) (spawn-coop-repl-server)))

(define-method (on-enter (shell <shell>))
  (attach shell (current-scene shell))
  (script
   (forever
    (sleep 60)
    (set! (text (child-ref shell '(debug-overlay fps-label)))
          (format #f "~1,2f" (fps shell))))))

(define (reset-game)
  (switch-scene (root-node) ((reset-thunk (root-node)))))

(define-method (on-quit (shell <shell>))
  (abort-game))

(define-method (toggle-debug-mode (shell <shell>))
  (set! (debug? shell) (not (debug? shell))))

(define-method (toggle-eval-prompt (shell <shell>))
  (let ((eval-prompt (eval-prompt shell)))
    (if (active? eval-prompt)
        (detach eval-prompt)
        (attach (child-ref shell 'debug-overlay)
                eval-prompt))))

(define-method (on-key-press (shell <shell>) key mods repeat?)
  (match mods
    ((or ('left-control) ('right-control) ('caps-lock))
     (match key
       ('d
        (toggle-debug-mode shell)
        #f)
       ('q (abort-game))
       ('r
        (reset-game)
        #f)
       (_ #t)))
    ((or ('left-alt) ('right-alt))
     (match key
       ('x
        (if (debug? shell)
            (begin
              (toggle-eval-prompt shell)
              #f)
            #t))
       (_ #t)))
    (_ #t)))

(define-method (update (shell <shell>) dt)
  (poll-coop-repl-server (repl shell))
  (reload-modified-assets))

(define %origin (vec2 0.0 0.0))

(define-method (draw (shell <shell>) alpha)
  (draw-sprite (framebuffer-texture (framebuffer shell))
               %origin
               #:rect (fb-region shell)))

(define-method (draw/children (shell <shell>) alpha)
  ;; Render children before self so that we populate the framebuffer.
  (with-framebuffer (framebuffer shell)
    (with-projection (projection shell)
      (each-child (cut draw/children <> alpha) shell)))
  (draw shell alpha))

(define (make-shell initial-scene-thunk)
  (watch-asset-directory "assets")
  (make <shell> #:name 'shell #:current-scene (initial-scene-thunk)
        #:reset initial-scene-thunk))