about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--README.md15
-rwxr-xr-xgame.scm304
2 files changed, 206 insertions, 113 deletions
diff --git a/README.md b/README.md index 5efe495..a8d553a 100644 --- a/README.md +++ b/README.md
@@ -30,6 +30,21 @@ Here is a picture of the cool rock I found:
30 30
31## Development log 31## Development log
32 32
33### 2023-05-31
34
35- Added color using the (yolk attrs) library
36- Parameterize (me) and (snake) in main to make definition order unimportant
37- Change game loop and event handling to allow for independent snake movement
38 - This didn't require using threads!
39 - Also enabled hjkl for movement.
40 - The snake is very dumb right now --- it just goes in a circle.
41 - Also includes timing!
42 - And changing direction!
43- Randomly place snake and apple
44- Refactor functions to pass around the world less
45 - This means that things now hold a reference to the world they're in .. I think this makes sense
46- Add checking if things are around a given thing
47
33### 2023-05-30 48### 2023-05-30
34 49
35- Changed license to LATCRIFPL 50- Changed license to LATCRIFPL
diff --git a/game.scm b/game.scm index 17c22eb..ab4fd7b 100755 --- a/game.scm +++ b/game.scm
@@ -17,11 +17,12 @@ See COPYING for details.
17 (yolk xterm) 17 (yolk xterm)
18 (yolk erase) 18 (yolk erase)
19 (yolk cursor) 19 (yolk cursor)
20 (yolk attrs)
20 (srfi 18) 21 (srfi 18)
21 (matchable) 22 (matchable)
22 (stty)) 23 (stty))
23 24
24(define (log . xs) 25(define (log* . xs)
25 (with-output-to-port (current-error-port) 26 (with-output-to-port (current-error-port)
26 (lambda () 27 (lambda ()
27 (for-each (lambda (x) (display x) (display " ") x) 28 (for-each (lambda (x) (display x) (display " ") x)
@@ -30,11 +31,24 @@ See COPYING for details.
30 31
31(define (main args) 32(define (main args)
32 (parameterize ((world (make-world 80 25))) 33 (parameterize ((world (make-world 80 25)))
33 (dynamic-wind game-setup 34 (parameterize ((me (let-values (((x y) (random-point (world))))
34 game-loop 35 (make-thing 'me (world)
35 game-cleanup)) 36 (with-attrs '(red) "รณ") x y 2)))
37 (snake (let-values (((x y) (random-point (world))))
38 (make-snake (world) 5 (current-jiffy) 100 'left
39 (make-thing 'snake-head (world)
40 "<" x y 2)
41 (list (make-thing 'snake-tail (world)
42 "-" (+ 1 x) y 2))))))
43 (dynamic-wind game-setup
44 game-loop
45 game-cleanup)))
36 #t) 46 #t)
37 47
48(define me (make-parameter #f))
49(define world (make-parameter #f))
50(define snake (make-parameter #f))
51
38(define (game-setup) 52(define (game-setup)
39 ;; Prepare terminal 53 ;; Prepare terminal
40 (stty '(raw (not echo))) 54 (stty '(raw (not echo)))
@@ -46,9 +60,7 @@ See COPYING for details.
46 invisible-cursor) 60 invisible-cursor)
47 ;; Set up world 61 ;; Set up world
48 (world-init (world)) 62 (world-init (world))
49 (world-draw (world)) 63 (world-draw (world)))
50 ;; Start snake
51 (snake-init (snake)))
52 64
53(define (game-cleanup) 65(define (game-cleanup)
54 ;; Restore terminal 66 ;; Restore terminal
@@ -59,32 +71,62 @@ See COPYING for details.
59 visible-cursor)) 71 visible-cursor))
60 72
61(define (game-loop) 73(define (game-loop)
62 (let loop ((c (readch))) 74 (call/cc
63 (if (eq? c 'done) 75 (lambda (return)
64 #t 76 (let loop ((now (current-jiffy)))
65 (let ((done? #f)) 77 (handle-input return)
66 (match c 78 (snake-step (snake) now)
67 ((or #\q #\) 79 (world-draw (world))
68 (set! done? #t)) 80 (loop (current-jiffy))))))
69 ;; Escape characters 81
70 (#\escape 82(define (handle-input done)
71 (match (readch) 83 (if (char-ready?)
72 (#\[ (match (readch) 84 (match (readch)
73 (#\A (up!)) 85 (#\q (done))
74 (#\B (down!)) 86 (#\k (up!))
75 (#\C (right!)) 87 (#\j (down!))
76 (#\D (left!)) 88 (#\l (right!))
77 (else))) 89 (#\h (left!))
78 (else))) 90 ;; Escape characters
79 (else)) 91 (#\escape (match (readch)
80 (snake-step (snake) (world)) 92 (#\[ (match (readch)
81 (world-draw (world)) 93 (#\A (up!))
82 (loop (if done? 'done (readch))))))) 94 (#\B (down!))
95 (#\C (right!))
96 (#\D (left!))
97 (_ #f)))
98 (_ #f)))
99 (x (log* x)))
100 #f))
83 101
84(define (readch) 102(define (readch)
85 (let ((c (integer->char (read-byte)))) 103 (let ((c (integer->char (read-byte))))
86 c)) 104 c))
87 105
106;;; random
107
108(define random-int
109 (case-lambda
110 (() (pseudo-random-integer 100))
111 ((max) (pseudo-random-integer max))
112 ((min max)
113 (let ((max (if (> max min) max min))
114 (min (if (< min max) min max)))
115 (+ min (pseudo-random-integer (- max min)))))))
116
117(define (random-x world)
118 (random-int 1 (- (world-width world) 1)))
119
120(define (random-y world)
121 (random-int 1 (- (world-height world) 1)))
122
123(define (random-point world)
124 (let loop ((x (random-x world))
125 (y (random-y world)))
126 (if (world-get world x y)
127 (loop (random-x world) (random-y world))
128 (values x y))))
129
88;;; Drawing stuff 130;;; Drawing stuff
89 131
90(define (draw . instructions) 132(define (draw . instructions)
@@ -128,8 +170,6 @@ See COPYING for details.
128(define (make-world width height) 170(define (make-world width height)
129 (%make-world width height (make-vector (* width height) #f))) 171 (%make-world width height (make-vector (* width height) #f)))
130 172
131(define world (make-parameter #f))
132
133(define (for-world proc world) 173(define (for-world proc world)
134 (do ((y 1 (+ y 1))) 174 (do ((y 1 (+ y 1)))
135 ((= y (world-height world)) #t) 175 ((= y (world-height world)) #t)
@@ -156,25 +196,28 @@ See COPYING for details.
156 (= y 1) 196 (= y 1)
157 (= x (- (world-width world) 1)) 197 (= x (- (world-width world) 1))
158 (= y (- (world-height world) 1))) 198 (= y (- (world-height world) 1)))
159 (thing-place! w (wall x y))) 199 (thing-place! (wall w x y)))
160 (else))) 200 (else)))
161 world) 201 world)
162 (thing-place! world (me)) 202 (thing-place! (me))
163 (thing-place! world (snake-head (snake))) 203 (thing-place! (snake-head (snake)))
164 (for-each (lambda (t) (thing-place! world t)) 204 (for-each (lambda (t) (thing-place! t))
165 (snake-tail (snake)))) 205 (snake-tail (snake))))
166 206
167;;; Things 207;;; Things
168 208
169(define-record-type <thing> 209(define-record-type <thing>
170 (make-thing name look x y z attrs) 210 (make-thing name world look x y z)
171 thing? 211 thing?
172 (name thing-name) 212 (name thing-name)
213 (world thing-world thing-world-set!)
173 (look thing-look thing-look-set!) 214 (look thing-look thing-look-set!)
174 (x thing-x thing-x-set!) 215 (x thing-x thing-x-set!)
175 (y thing-y thing-y-set!) 216 (y thing-y thing-y-set!)
176 (z thing-z thing-z-set!) 217 (z thing-z thing-z-set!))
177 (attrs thing-attrs thing-attrs-set!)) 218
219(define (wall w x y)
220 (make-thing 'wall w "#" x y 100))
178 221
179(define (thing-attr-get thing attr) 222(define (thing-attr-get thing attr)
180 (let ((x (assoc attr (thing-attrs thing)))) 223 (let ((x (assoc attr (thing-attrs thing))))
@@ -190,17 +233,19 @@ See COPYING for details.
190 (cons (cons attr val) 233 (cons (cons attr val)
191 (thing-attrs thing)))))) 234 (thing-attrs thing))))))
192 235
193(define (thing-place! world thing) 236(define (thing-place! thing)
194 (world-set! world (thing-x thing) (thing-y thing) thing)) 237 (world-set! (thing-world thing) (thing-x thing) (thing-y thing) thing))
195 238
196(define (thing-move! world thing x y) 239(define (thing-move! thing x y)
197 (world-set! world (thing-x thing) (thing-y thing) #f) 240 (let ((world (thing-world thing)))
198 (thing-x-set! thing x) 241 (world-set! world (thing-x thing) (thing-y thing) #f)
199 (thing-y-set! thing y) 242 (thing-x-set! thing x)
200 (world-set! world x y thing)) 243 (thing-y-set! thing y)
244 (world-set! world x y thing)))
201 245
202(define (thing-move-relative! world thing dx dy) 246(define (thing-move-relative! thing dx dy)
203 (let* ((new-x (+ (thing-x thing) dx)) 247 (let* ((world (thing-world thing))
248 (new-x (+ (thing-x thing) dx))
204 (new-y (+ (thing-y thing) dy)) 249 (new-y (+ (thing-y thing) dy))
205 (other (world-get world new-x new-y))) 250 (other (world-get world new-x new-y)))
206 (cond 251 (cond
@@ -215,72 +260,67 @@ See COPYING for details.
215 (set! new-y 1)) 260 (set! new-y 1))
216 ((> new-y (- (world-height world) 1)) 261 ((> new-y (- (world-height world) 1))
217 (set! new-y (- (world-height world) 1)))) 262 (set! new-y (- (world-height world) 1))))
218 (thing-move! world thing new-x new-y))))) 263 (thing-move! thing new-x new-y)))))
219 264
220(define (thing-up! thing) 265(define (thing-up! thing)
221 (thing-move-relative! (world) thing 0 -1)) 266 (thing-move-relative! thing 0 -1))
222 267
223(define (thing-down! thing) 268(define (thing-down! thing)
224 (thing-move-relative! (world) thing 0 1)) 269 (thing-move-relative! thing 0 1))
225 270
226(define (thing-right! thing) 271(define (thing-right! thing)
227 (thing-move-relative! (world) thing 1 0)) 272 (thing-move-relative! thing 1 0))
228 273
229(define (thing-left! thing) 274(define (thing-left! thing)
230 (thing-move-relative! (world) thing -1 0)) 275 (thing-move-relative! thing -1 0))
231
232(define (wall x y)
233 (make-thing 'wall "#" x y 100 '()))
234
235(define me
236 (make-parameter
237 (make-thing 'me "@" 40 10 2 '())))
238 276
239(define (up!) (thing-up! (me))) 277(define (up!) (thing-up! (me)))
240(define (down!) (thing-down! (me))) 278(define (down!) (thing-down! (me)))
241(define (left!) (thing-left! (me))) 279(define (left!) (thing-left! (me)))
242(define (right!) (thing-right! (me))) 280(define (right!) (thing-right! (me)))
243 281
244;;; random 282(define (thing-above thing)
245 283 (if (< (thing-y thing) 1)
246(define random-int 284 #f
247 (case-lambda 285 (world-get (thing-world thing)
248 (() (pseudo-random-integer 100)) 286 (thing-x thing)
249 ((max) (pseudo-random-integer max)) 287 (- (thing-y thing) 1))))
250 ((min max) 288
251 (let ((max (if (> max min) max min)) 289(define (thing-below thing)
252 (min (if (< min max) min max))) 290 (if (> (thing-y thing) (world-height (thing-world thing)))
253 (+ min (pseudo-random-integer (- max min))))))) 291 #f
254 292 (world-get (thing-world thing)
255(define (random-x world) 293 (thing-x thing)
256 (random-int 1 (- (world-width world) 1))) 294 (+ (thing-y thing) 1))))
257 295
258(define (random-y world) 296(define (thing-to-left thing)
259 (random-int 1 (- (world-height world) 1))) 297 (if (< (thing-x thing) 1)
298 #f
299 (world-get (thing-world thing)
300 (- (thing-x thing) 1)
301 (thing-y thing))))
302
303(define (thing-to-right thing)
304 (if (> (thing-x thing) (world-width (thing-world thing)))
305 #f
306 (world-get (thing-world thing)
307 (+ (thing-x thing) 1)
308 (thing-y thing)
309 )))
260 310
261;;; snake 311;;; snake
262 312
263(define-record-type <snake> 313(define-record-type <snake>
264 (make-snake length head tail) 314 (make-snake world length mtime wait direction head tail)
265 snake? 315 snake?
266 (length snake-length snake-length-set!) 316 (length snake-length snake-length-set!)
317 (world snake-world snake-world-set!)
318 (mtime snake-mtime snake-mtime-set!)
319 (direction snake-direction snake-direction-set!)
320 (wait snake-wait snake-wait-set!)
267 (head snake-head snake-head-set!) 321 (head snake-head snake-head-set!)
268 (tail snake-tail snake-tail-set!)) 322 (tail snake-tail snake-tail-set!))
269 323
270(define snake
271 (make-parameter
272 (make-snake 5
273 (make-thing 'snake-head "<" 60 20 2
274 '((dir . (-1 0))))
275 (list (make-thing 'snake-tail "-" 61 20 2 '())
276 #;(make-thing 'snake-tail "-" 62 20 2 '())
277 #;(make-thing 'snake-tail "-" 63 20 2 '())
278 #;(make-thing 'snake-tail "-" 64 20 2 '())
279 #;(make-thing 'snake-tail "-" 65 20 2 '())))))
280
281(define (snake-init snake)
282 #f)
283
284(define (snake-x snake) 324(define (snake-x snake)
285 (thing-x (snake-head snake))) 325 (thing-x (snake-head snake)))
286 326
@@ -290,9 +330,6 @@ See COPYING for details.
290(define (snake-z snake) 330(define (snake-z snake)
291 (thing-z (snake-head snake))) 331 (thing-z (snake-head snake)))
292 332
293(define (snake-direction snake)
294 (thing-attr-get (snake-head snake) 'dir))
295
296(define (take* xs n) 333(define (take* xs n)
297 ;;; Like `take' from SRFI 1, but doesn't choke on too-short lists. 334 ;;; Like `take' from SRFI 1, but doesn't choke on too-short lists.
298 (unless (and (integer? n) 335 (unless (and (integer? n)
@@ -308,24 +345,65 @@ See COPYING for details.
308 (- n 1) 345 (- n 1)
309 (cons (car xs) acc))))) 346 (cons (car xs) acc)))))
310 347
311(define (snake-step snake world) 348(define (snake-step snake now)
312 (let ((new-tail (make-thing 'snake-tail 349 (when (> now (+ (snake-mtime snake) (snake-wait snake)))
313 (if (zero? (car (snake-direction snake))) 350 (let ((new-tail (make-thing 'snake-tail (snake-world snake)
314 "|" 351 (if (snake-vertical? snake)
315 "-") 352 "|"
316 (snake-x snake) 353 "-")
317 (snake-y snake) 354 (snake-x snake)
318 (snake-z snake) 355 (snake-y snake)
319 '()))) 356 (snake-z snake))))
320 (apply thing-move-relative! 357 (snake-update-head! snake)
321 world 358 (apply thing-move-relative!
322 (snake-head snake) 359 (snake-head snake)
323 (snake-direction snake)) 360 (direction->velocity (snake-direction snake)))
324 (for-each (lambda (t) (world-set! world (thing-x t) (thing-y t) #f)) 361 (snake-update-direction! snake)
325 (snake-tail snake)) 362 (for-each (lambda (t) (world-set! (snake-world snake)
326 (snake-tail-set! snake 363 (thing-x t)
327 (take* (cons new-tail 364 (thing-y t)
328 (snake-tail snake)) 365 #f))
329 (snake-length snake))) 366 (snake-tail snake))
330 (for-each (lambda (t) (thing-place! world t)) 367 (snake-tail-set! snake
331 (snake-tail snake)))) 368 (take* (cons new-tail
369 (snake-tail snake))
370 (snake-length snake)))
371 (for-each (lambda (t) (thing-place! t))
372 (snake-tail snake))
373 (snake-mtime-set! snake now))))
374
375(define (direction->velocity direction)
376 (case direction
377 ((up) '(0 -1))
378 ((down) '(0 1))
379 ((left) '(-1 0))
380 ((right) '(1 0))
381 (else direction)))
382
383(define (snake-vertical? snake)
384 (or (eq? (snake-direction snake) 'up)
385 (eq? (snake-direction snake) 'down)))
386
387(define (snake-update-head! snake)
388 (thing-look-set! (snake-head snake)
389 (case (snake-direction snake)
390 ((right) ">")
391 ((down) "v")
392 ((left) "<")
393 ((up) "^"))))
394
395(define (snake-update-direction! snake)
396 (let ((head (snake-head snake)))
397 (case (snake-direction snake)
398 ((up)
399 (when (thing-above head)
400 (snake-direction-set! snake 'left)))
401 ((down)
402 (when (thing-below head)
403 (snake-direction-set! snake 'right)))
404 ((left)
405 (when (thing-to-left head)
406 (snake-direction-set! snake 'down)))
407 ((right)
408 (when (thing-to-right head)
409 (snake-direction-set! snake 'up))))))