blob: 14ae081e2c42e40dfa1316311de04337193fbaf7 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
;;; Lisp Game Jam 2018
;;; Copyright © 2018, 2021 Ricardo Wurmus <rekado@elephly.net>
;;; 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 graphics)
#:use-module (chickadee graphics framebuffer)
#:use-module (chickadee graphics 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 %scale-factor 2)
(define %height (* %scale-factor 240))
(define %width (* %scale-factor 320))
(define-class <shell> (<node>)
(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)))
(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 (switch-scene shell new-scene)
(detach (current-scene shell))
(set! (current-scene shell) new-scene)
(attach shell new-scene))
(define-method (on-start (shell <shell>))
(set! (repl shell) (spawn-coop-repl-server)))
(define-method (on-enter (shell <shell>))
(attach shell (current-scene shell)))
(define (reset-game)
(switch-scene (root-node) ((reset-thunk (root-node)))))
(define-method (on-quit (shell <shell>))
(abort-game))
(define-method (on-key-press (shell <shell>) key mods repeat?)
(match mods
((or ('left-control) ('right-control) ('caps-lock))
(match key
('q (abort-game))
('r
(reset-game)
#f)
(_ #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))
|
