Add a CLI.

2 files changed, 348 insertions, 0 deletions

diff --git a/chickadee/cli.scm b/chickadee/cli.scm
new file mode 100644
index 0000000..66f2093
--- /dev/null
+++ b/chickadee/cli.scm
@@ -0,0 +1,96 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; 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)
+  #:use-module (chickadee)
+  #:use-module (chickadee config)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37)
+  #:export (launch-chickadee
+            display-version-and-exit
+            leave
+            simple-args-fold
+            operands))
+
+(define (display-version-and-exit)
+  (format #t "Chickadee ~a
+Copyright (C) 2021 David Thompson and Chickadee contributors
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"
+          %chickadee-version)
+  (exit 0))
+
+(define (display-help-and-exit)
+  (format #t "Usage: chickadee SUBCOMMAND ARGS ...~%
+Run SUBCOMMAND with ARGS
+
+Valid subcommands:
+* play~%")
+  (exit 1))
+
+(define (leave format-string . args)
+  "Display error message and exist."
+  (apply format (current-error-port) format-string args)
+  (newline)
+  (exit 1))
+
+(define (simple-args-fold args options defaults)
+  (args-fold args options
+             (lambda (opt name arg result)
+               (leave "unrecognized option: ~A" name))
+             (lambda (arg result)
+               (alist-cons 'operand arg result))
+             defaults))
+
+(define (operands opts)
+  (filter-map (match-lambda
+                (('operand . arg) arg)
+                (_ #f))
+              opts))
+
+(define (run-chickadee-command command . args)
+  (define (invalid-command)
+    (format (current-error-port) "invalid subcommand: ~a~%~%" command)
+    (display-help-and-exit))
+  (let* ((module
+          (catch 'misc-error
+            (lambda ()
+              (resolve-interface `(chickadee cli ,command)))
+            (lambda args
+              (invalid-command))))
+         (proc-name (symbol-append 'chickadee- command))
+         (command-proc (false-if-exception (module-ref module proc-name))))
+    (if (procedure? command-proc)
+        (apply command-proc args)
+        (invalid-command))))
+
+(define (subcommand? arg)
+  (not (string-prefix? "-" arg)))
+
+(define (launch-chickadee . args)
+  (match args
+    ((program (or "--verison" "-v"))
+     (display-version-and-exit))
+    ((or (program) (program (or "--help" "-h")))
+     (display-help-and-exit))
+    ((program (? subcommand? subcommand) . args*)
+     (apply run-chickadee-command (string->symbol subcommand) args*))
+    ((program invalid-subcommand . args*)
+     (leave "invalid subcommand: ~A" invalid-subcommand))))
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.")))))