path: root/chickadee/cli/play.scm

;;; 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 play)
  #:declarative? #f
  #:use-module (chickadee)
  #:use-module (chickadee async-repl)
  #:use-module (chickadee cli)
  #:use-module (chickadee config)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics viewport)
  #:use-module (ice-9 exceptions)
  #: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 base compile)
  #:use-module (system repl command)
  #:use-module (system repl debug)
  #:use-module (system repl coop-server)
  #:use-module (system repl server)
  #:export (chickadee-play
            %default-modules))

(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 "
  -c, --clear-color=RGB  set the clear color to hex color code RGB")
  (display "
 --repl                  start REPL in this terminal")
  (display "
 --repl-server=[PORT]    start REPL server on PORT or 37146 by default")
  (display "
 --language=LANG         change language; default: scheme")
  (display "
 -x EXTENSION            add EXTENSION to the front of the load extensions")
  (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 '(#\c "clear-color") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'clear-color (string->color 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)))
        (option '("language") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'language (string->symbol arg) result)))
        (option '(#\x) #t #f
                (lambda (opt name arg result)
                  (alist-cons 'extension arg result)))))

(define %default-options
  `((title . "chickadee")
    (width . 640)
    (height . 480)
    (fullscreen? . #f)
    (resizable? . #f)
    (update-hz . 60)
    (clear-color . ,%default-clear-color)
    (repl . #f)
    (language . scheme)))

(define %default-modules
  '((chickadee)
    (chickadee audio)
    (chickadee graphics color)
    (chickadee graphics engine)
    (chickadee graphics text)
    (chickadee graphics texture)
    (chickadee math)
    (chickadee math matrix)
    (chickadee math rect)
    (chickadee math vector)
    (chickadee scripting)))

(define (make-user-module)
  (let ((module (resolve-module '(chickadee-user) #f)))
    (beautify-user-module! module)
    ;; Automatically load commonly used modules for
    ;; maximum convenience.
    (for-each (lambda (name)
                (module-use! module (resolve-interface name)))
              %default-modules)
    (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)
           (set! %load-extensions
                 (append (filter-map (match-lambda
                                       (('extension . ext) ext)
                                       (_ #f))
                                     opts)
                         %load-extensions))
           (load-compiled
            (compile-file (basename file-name)
                          #:from (assq-ref opts 'language)
                          #:env module))
           (parameterize ((current-language (assq-ref opts 'language)))
             (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 e stack)
      ;; Setup the REPL debug object.
      (let* ((frame (stack-ref stack 0))
             (error-string
              (format #f "~a: In procedure: ~a:~%In procedure: ~a: ~a~%"
                      (match (frame-source frame)
                        ((_ file-name line . column)
                         (format #f "~a:~a:~a"
                                 (if file-name
                                     (basename file-name)
                                     "unknown file")
                                 line column))
                        (_ "unknown"))
                      (or (frame-procedure-name frame)
                          "unknown")
                      (or (and (exception-with-origin? e)
                               (exception-origin e))
                          "unknown")
                      (if (and (exception-with-message? e)
                               (exception-with-irritants? e))
                          (apply format #f (exception-message e)
                                 (exception-irritants e))
                          ""))))
        (set! debug (make-debug (narrow-stack->vector stack 0) 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)
              #:clear-color (assq-ref opts 'clear-color)
              #: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 (or (assq-ref opts 'repl)
                              (assq-ref opts 'repl-server))
                          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.")))))