Initial commit.

1 files changed, 236 insertions, 0 deletions

diff --git a/engine/shell.scm b/engine/shell.scm
new file mode 100644
index 0000000..12f6699
--- /dev/null
+++ b/engine/shell.scm
@@ -0,0 +1,236 @@
+;;; 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 %height 240)
+(define %width 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 (* 2 %width) (* 2 %height)))
+  (projection #:getter projection
+              #:init-form (orthographic-projection 0 %width %height 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))