diff options
Diffstat (limited to 'chickadee/cli/play.scm')
-rw-r--r-- | chickadee/cli/play.scm | 252 |
1 files changed, 252 insertions, 0 deletions
diff --git a/chickadee/cli/play.scm b/chickadee/cli/play.scm new file mode 100644 index 0000000..c893c27 --- /dev/null +++ b/chickadee/cli/play.scm @@ -0,0 +1,252 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2021 David Thompson <davet@gnu.org> +;;; +;;; Chickadee 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. +;;; +;;; Chickadee 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 (chickadee cli play) + #:declarative? #f + #:use-module (chickadee) + #:use-module (chickadee async-repl) + #:use-module (chickadee cli) + #:use-module (chickadee config) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-37) + #:use-module (system repl command) + #:use-module (system repl debug) + #:use-module (system repl coop-server) + #:use-module (system repl server) + #:export (chickadee-play)) + +(define (display-help-and-exit) + (format #t "Usage: chickadee play [OPTIONS] FILE~% +Play the game defined in FILE.~%") + (display " + --help display this help and exit") + (display " + -t, --title=TITLE set window title to TITLE") + (display " + -w, --width=WIDTH set window width to WIDTH") + (display " + -h, --height=HEIGHT set window height to HEIGHT") + (display " + -f, --fullscreen fullscreen mode") + (display " + -r, --resizable allow window to be resized") + (display " + -u, --update-hz=N set update rate to N times per second") + (display " + --repl start REPL in this terminal") + (display " + --repl-server=[PORT] start REPL server on PORT or 37146 by default") + (newline) + (exit 1)) + +(define %options + (list (option '("help") #f #f + (lambda (opt name arg result) + (display-help-and-exit))) + (option '(#\t "title") #t #f + (lambda (opt name arg result) + (alist-cons 'title arg result))) + (option '(#\w "width") #t #f + (lambda (opt name arg result) + (alist-cons 'width (string->number arg) result))) + (option '(#\h "height") #t #f + (lambda (opt name arg result) + (alist-cons 'height (string->number arg) result))) + (option '(#\f "fullscreen") #f #f + (lambda (opt name arg result) + (alist-cons 'fullscreen? #t result))) + (option '(#\r "resizable") #f #f + (lambda (opt name arg result) + (alist-cons 'resizable? #f result))) + (option '(#\u "update-hz") #t #f + (lambda (opt name arg result) + (alist-cons 'update-hz (string->number arg) result))) + (option '("repl") #f #f + (lambda (opt name arg result) + (alist-cons 'repl #t result))) + (option '("repl-server") #f #t + (lambda (opt name arg result) + (alist-cons 'repl + (if arg + (string->number arg) + 37146) + result))))) + +(define %default-options + '((title . "chickadee") + (width . 640) + (height . 480) + (fullscreen? . #f) + (resizable? . #f) + (update-hz . 60) + (repl . #f))) + +(define (make-user-module) + (let ((module (resolve-module '(chickadee-user) #f))) + (beautify-user-module! module) + (for-each (lambda (name) + (module-use! module (resolve-interface name))) + ;; Automatically load commonly used modules for + ;; maximum convenience. + '((chickadee) + (chickadee graphics color) + (chickadee graphics engine) + (chickadee graphics font) + (chickadee graphics texture) + (chickadee math) + (chickadee math matrix) + (chickadee math rect) + (chickadee math vector) + (chickadee scripting))) + (module-define! module 'quit-game (lambda () (abort-game))) + module)) + +(define-record-type <game-debugger> + (make-game-debugger) + game-debugger? + (debug game-debugger-debug set-game-debugger-debug!) + (debugging? game-debugger-debugging? set-game-debugger-debugging!)) + +(define *debugger* (make-game-debugger)) + +(define (launch-game file-name opts) + (let ((module (make-user-module)) + (repl #f) + (debug #f)) + (define-meta-command ((debug-game chickadee) r) + "debug-game +Enter a debugger for the current game loop error." + (if debug + (begin + (set-async-repl-debug! repl debug)) + (begin + (display "nothing to debug") + (newline)))) + (define-meta-command ((resume-game chickadee) r) + "resume-game +Resume the game loop without entering a debugger." + (if debug + (set! debug #f) + (begin + (display "not currently debugging") + (newline)))) + (define-syntax-rule (trampoline name args ...) + (lambda (args ...) + (let ((proc (false-if-exception (module-ref module 'name)))) + (when (procedure? proc) + (proc args ...))))) + (define (load-game) + (save-module-excursion + (lambda () + (let ((dir (dirname file-name))) + (set-current-module module) + (chdir dir) + (add-to-load-path dir) + (primitive-load (basename file-name)) + (let ((repl-opt (assq-ref opts 'repl))) + (cond + ((number? repl-opt) + (set! repl (spawn-coop-repl-server + (make-tcp-server-socket #:port repl-opt)))) + (repl-opt + (set! repl (make-async-repl)) + (start-async-repl repl abort-game)))))))) + (define (handle-error stack key args) + ;; Setup the REPL debug object. + (let* ((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) + )) + (error-string (call-with-output-string + (lambda (port) + (let ((frame (and (< 0 (vector-length stack)) + (vector-ref stack 0)))) + (print-exception port frame key args)))))) + (set! debug (make-debug stack 0 error-string)) + ;; Just update the REPL endlessly until the developer says to + ;; resume. + (let* ((window (current-window)) + (old-title (window-title (current-window)))) + (set-window-title! window + "*** ERROR: Run ,debug-game in REPL for details ***") + (while debug + (update-repl) + (usleep 1000)) + (set-window-title! window old-title)))) + (define (update-repl) + (cond + ((async-repl? repl) + (update-async-repl repl)) + (repl + (poll-coop-repl-server repl)))) + ;; Run game loop, deferring all event handlers to those defined + ;; in the user's Scheme file. + (run-game #:window-title (assq-ref opts 'title) + #:window-width (assq-ref opts 'width) + #:window-height (assq-ref opts 'height) + #:window-fullscreen? (assq-ref opts 'fullscreen?) + #:window-resizable? (assq-ref opts 'resizable?) + #:update-hz (assq-ref opts 'update-hz) + #:load load-game + #:update (let ((update* (trampoline update dt))) + (lambda (dt) + (update-repl) + (update* dt))) + #:draw (trampoline draw alpha) + #:quit (trampoline quit-game) + #:key-press (trampoline key-press key modifiers repeat?) + #:key-release (trampoline key-release key modifiers) + #:text-input (trampoline text-input text) + #:mouse-press (trampoline mouse-press button clicks x y) + #:mouse-release (trampoline mouse-release button x y) + #:mouse-move (trampoline mouse-move x y x-rel y-rel buttons) + #:mouse-wheel (trampoline mouse-wheel x y) + #:controller-add (trampoline controller-add controller) + #:controller-remove (trampoline controller-remove controller) + #:controller-press (trampoline controller-press controller + button) + #:controller-release (trampoline controller-release controller + button) + #:controller-move (trampoline controller-move controller axis + value) + #:error (if repl handle-error #f)) + (when (async-repl? repl) + (close-async-repl repl)))) + +(define (chickadee-play . args) + (let ((opts (simple-args-fold args %options %default-options))) + (match (operands opts) + (() + (leave "you must specify a Scheme file to load")) + ((file-name) + (launch-game file-name opts)) + (_ + (leave "too many arguments specified. just pass a Scheme file name."))))) |