blob: aeb725b67db4e97c2b4b8b8d60d6799f8fd90a10 (
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
158
159
160
161
162
|
(import scheme
(chicken base)
(chicken format)
(chicken process-context)
(chicken condition)
(chicken pretty-print)
(srfi 1)
(srfi 12)
miscmacros
simple-logger
(prefix sdl2 "sdl2:")
(prefix sdl2-ttf "ttf:")
(prefix sdl2-image "img:")
matchable
tilemap
defstruct
input)
(define +color-depth+ 32)
(define +screen-width+ 600)
(define +screen-height+ 400)
(define *fullscreen?* #f)
(define +background-color+ (sdl2:make-color 0 0 0))
(define +software-mode?+ (member "--software" (command-line-arguments)))
(define +vsync?+ (member "--vsync" (command-line-arguments)))
(define +debug?+ (member "--debug" (command-line-arguments)))
;; When --debug is passed, show debug/info logs (e.g. input events).
(when +debug?+
(log-level 0))
(sdl2:set-main-ready!)
(sdl2:init! '(video joystick))
(ttf:init!)
(img:init! '(png))
(on-exit sdl2:quit!)
;; Install a custom exception handler that will call quit! and then
;; call the original exception handler. This ensures that quit! will
;; be called even if an unhandled exception reaches the top level.
(current-exception-handler
(let ((original-handler (current-exception-handler)))
(lambda (exception)
(sdl2:quit!)
(original-handler exception))))
(if (and +vsync?+ (not +software-mode?+)) ; vsync doesn't work with software rendering
(sdl2:set-hint! 'render-vsync "1"))
(define *window* (sdl2:create-window! "MacroKnight"
'centered 'centered
+screen-width+ +screen-height+
(if *fullscreen?* '(fullscreen) '())))
(define *renderer*
(handle-exceptions exn
(lambda ()
(display "Error initialising accelerated renderer. Falling back")
(sdl2:create-renderer! *window* -1 '(software)))
(sdl2:create-renderer! *window* -1 '(accelerated))))
(define *font* (ttf:open-font "DejaVuSans.ttf" 12))
(define *text-color* (sdl2:make-color 255 255 255))
(pp (sdl2:num-joysticks))
(define *joystick* (if (> (sdl2:num-joysticks) 0)
(sdl2:joystick-open! 0)
#f))
(define *level* (load-tilemap "assets/level-0.tmx"))
(define *level-tileset-texture* (sdl2:create-texture-from-surface *renderer* (tileset-image (tilemap-tileset *level*))))
(define *input* (create-input-state))
(define (draw-tile renderer tileset tile-id row-num col-num)
(let ((tile (tileset-tile tileset tile-id)))
(sdl2:render-copy! renderer *level-tileset-texture*
(tile-rect tile)
(sdl2:make-rect (* col-num (tileset-tileheight tileset))
(* row-num (tileset-tilewidth tileset))
(tileset-tilewidth tileset)
(tileset-tileheight tileset)))))
(define (draw-tilemap-rows draw-fn rows row-num)
(unless (null? rows)
(for-each
(cut draw-fn <> row-num <>)
(car rows)
(iota (length (car rows))))
(draw-tilemap-rows draw-fn (cdr rows) (+ row-num 1))))
(define (draw-tilemap renderer tilemap)
(let ((map-layers (tilemap-layers tilemap))
(tileset (tilemap-tileset tilemap)))
(for-each
(lambda (layer)
(draw-tilemap-rows
(cut draw-tile renderer tileset <> <> <>)
(layer-map layer)
0))
map-layers)))
(define (draw-objects renderer tilemap)
(let ((objects (tilemap-objects tilemap))
(tileset (tilemap-tileset tilemap)))
(for-each
(cut draw-object renderer tileset <>)
objects)))
(define (draw-object renderer tileset object)
(match (object-type object)
("Player" (draw-player renderer tileset object))
("Text" (draw-text renderer tileset object))
("Enemy" (draw-enemy renderer tileset object))
(_ #f)))
(define (draw-player renderer tileset object)
(let ((col-num (inexact->exact (floor (/ (object-x object) (tileset-tilewidth tileset)))))
(row-num (inexact->exact (floor (/ (object-y object) (tileset-tileheight tileset))))))
(draw-tile renderer tileset 29 row-num col-num)))
(define (draw-text renderer tileset object)
(let* ((text (cdr (assoc "text" (object-properties object))))
(text-texture (sdl2:create-texture-from-surface renderer
(ttf:render-text-solid *font* text *text-color*))))
(sdl2:render-copy! renderer text-texture #f (sdl2:make-rect
(inexact->exact (floor (object-x object)))
(inexact->exact (floor (object-y object)))
(inexact->exact (floor (object-width object)))
(inexact->exact (floor (object-height object)))))))
(define (draw-enemy renderer tileset object)
(let ((col-num (inexact->exact (floor (/ (object-x object) (tileset-tilewidth tileset)))))
(row-num (inexact->exact (floor (/ (object-y object) (tileset-tileheight tileset))))))
(draw-tile renderer tileset 111 row-num col-num)))
(set! (sdl2:render-draw-color *renderer*) +background-color+)
(sdl2:render-clear! *renderer*)
(let/cc exit-main-loop!
(while #t
(set! (sdl2:render-draw-color *renderer*) +background-color+)
(sdl2:render-clear! *renderer*)
(sdl2:pump-events!)
(let ((events-this-frame
(let collect ((lst '()))
(if (not (sdl2:has-events?))
(reverse lst)
(let ((e (sdl2:make-event)))
(sdl2:poll-event! e)
(collect (cons e lst)))))))
(set! *input* (input-state-update *input* events-this-frame))
(when (input-pressed? *input* 'quit)
(log-debug "[game] quit pressed")
(exit-main-loop!)))
(draw-tilemap *renderer* *level*)
(draw-objects *renderer* *level*)
(sdl2:render-present! *renderer*)
(sdl2:delay! 10)))
(when *joystick* (sdl2:joystick-close *joystick*))
(format #t "Bye!\n")
|
