about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rwxr-xr-xapple.scm115
1 files changed, 76 insertions, 39 deletions
diff --git a/apple.scm b/apple.scm index 41e12f6..bfacbc4 100755 --- a/apple.scm +++ b/apple.scm
@@ -37,7 +37,7 @@ See COPYING for details.
37 "<" 20 20 2) 37 "<" 20 20 2)
38 (list))) 38 (list)))
39 (fruit (make-thing 'fruit (world) 39 (fruit (make-thing 'fruit (world)
40 (random-choice (fruits)) 10 20 1))) 40 (random-choice (fruits)) 10 20 2)))
41 (case (dynamic-wind game-setup 41 (case (dynamic-wind game-setup
42 game-loop 42 game-loop
43 game-cleanup) 43 game-cleanup)
@@ -143,7 +143,7 @@ See COPYING for details.
143 (loop (random-x world) (random-y world)) 143 (loop (random-x world) (random-y world))
144 (values x y)))) 144 (values x y))))
145 145
146(define (random-choice . choices) 146(define (random-choice choices)
147 (list-ref choices (random-int (length choices)))) 147 (list-ref choices (random-int (length choices))))
148 148
149;;; Drawing stuff 149;;; Drawing stuff
@@ -218,6 +218,7 @@ See COPYING for details.
218 (thing-place! (wall w x y))) 218 (thing-place! (wall w x y)))
219 (else))) 219 (else)))
220 world) 220 world)
221 (draw-title world 10 10)
221 (thing-pos-randomize! (me)) 222 (thing-pos-randomize! (me))
222 (thing-place! (me)) 223 (thing-place! (me))
223 (thing-pos-randomize! (snake-head (snake))) 224 (thing-pos-randomize! (snake-head (snake)))
@@ -232,6 +233,14 @@ See COPYING for details.
232 (thing-x-set! thing x) 233 (thing-x-set! thing x)
233 (thing-y-set! thing y))) 234 (thing-y-set! thing y)))
234 235
236(define (draw-title world x y)
237 (for-each thing-place!
238 (list (make-thing 'a world (with-attrs '(italic dim) "A") x y 0)
239 (make-thing 'p world (with-attrs '(italic dim) "P") (+ x 2) y 0)
240 (make-thing 'p world (with-attrs '(italic dim) "P") (+ x 4) y 0)
241 (make-thing 'p world (with-attrs '(italic dim) "L") (+ x 6) y 0)
242 (make-thing 'p world (with-attrs '(italic dim) "E") (+ x 8) y 0))))
243
235;;; Things 244;;; Things
236 245
237(define-record-type <thing> 246(define-record-type <thing>
@@ -247,20 +256,6 @@ See COPYING for details.
247(define (wall w x y) 256(define (wall w x y)
248 (make-thing 'wall w "#" x y 100)) 257 (make-thing 'wall w "#" x y 100))
249 258
250(define (thing-attr-get thing attr)
251 (let ((x (assoc attr (thing-attrs thing))))
252 (if x
253 (cdr x)
254 #f)))
255
256(define (thing-attr-set! thing attr val)
257 (let ((x (assoc attr (thing-attrs thing))))
258 (if x
259 (set-cdr! x val)
260 (thing-attrs-set! thing
261 (cons (cons attr val)
262 (thing-attrs thing))))))
263
264(define (thing-place! thing) 259(define (thing-place! thing)
265 (world-set! (thing-world thing) (thing-x thing) (thing-y thing) thing)) 260 (world-set! (thing-world thing) (thing-x thing) (thing-y thing) thing))
266 261
@@ -299,21 +294,40 @@ See COPYING for details.
299(define (snake-head? x) 294(define (snake-head? x)
300 (and (thing? x) 295 (and (thing? x)
301 (eq? 'snake-head (thing-name x)))) 296 (eq? 'snake-head (thing-name x))))
297
298(define (fruit? x)
299 (and (thing? x)
300 (eq? 'fruit (thing-name x))))
302;;; hacky-end 301;;; hacky-end
303 302
304(define (handle-collision a b) 303(define (handle-collision a b)
304 (log* (thing-name a) (thing-name b))
305 (cond 305 (cond
306 ((or (and (me? a) (snake-head? b)) 306 ((or (and (me? a) (snake-head? b))
307 (and (snake-head? a) (me? b))) 307 (and (snake-head? a) (me? b)))
308 (game-lose)) 308 (game-lose))
309 ((or (and (fruit? a) (snake-head? b))
310 (and (snake-head? a) (fruit? b)))
311 (snake-eat-fruit))
309 ((or (and (snake-head? a) (thing? b)) 312 ((or (and (snake-head? a) (thing? b))
310 (and (thing? a) (snake-head? b))) 313 (and (thing? a) (snake-head? b)))
311 (game-win)) 314 (game-win))
312 (else))) 315 (else)))
313 316
317(define (snake-eat-fruit)
318 #;(log* "snake eat fruit")
319 (world-set! (thing-world (fruit))
320 (thing-x (fruit))
321 (thing-y (fruit))
322 #f)
323 (thing-pos-randomize! (fruit))
324 (thing-look-set! (fruit) (random-choice (fruits)))
325 (snake-length-set! (snake) (+ (random-int 4 7) (snake-length (snake)))))
326
314(define (game-win) 327(define (game-win)
315 (draw (cursor-move 10 10) 328 (draw (cursor-move 10 10)
316 "YOU WIN!") 329 "YOU WIN!")
330 (sleep 1)
317 (readch) 331 (readch)
318 (newline) 332 (newline)
319 ((game-end) 'win)) 333 ((game-end) 'win))
@@ -321,6 +335,7 @@ See COPYING for details.
321(define (game-lose) 335(define (game-lose)
322 (draw (cursor-move 10 10) 336 (draw (cursor-move 10 10)
323 "YOU LOSE :(") 337 "YOU LOSE :(")
338 (sleep 1)
324 (readch) 339 (readch)
325 (newline) 340 (newline)
326 ((game-end) 'lose)) 341 ((game-end) 'lose))
@@ -463,13 +478,39 @@ See COPYING for details.
463 ((left) "<") 478 ((left) "<")
464 ((up) "^")))) 479 ((up) "^"))))
465 480
481(define (distance thing-a thing-b)
482 (sqrt (+ (expt (abs (- (thing-x thing-a)
483 (thing-x thing-b)))
484 2)
485 (expt (abs (- (thing-y thing-a)
486 (thing-y thing-b)))
487 2))))
488
489(define (snake-move-toward snake thing)
490 (let ((tx (thing-x thing))
491 (ty (thing-y thing))
492 (sx (snake-x snake))
493 (sy (snake-y snake)))
494 (cond
495 ((< sx tx)
496 (if (> (abs (- sx tx))
497 (abs (- sy ty)))
498 'right
499 (if (< sy ty) 'down 'up)))
500 ((> sx tx)
501 (if (> (abs (- sx tx))
502 (abs (- sy ty)))
503 'left
504 (if (< sy ty) 'down 'up)))
505 ((= sx tx) (cond
506 ((<= sy ty) 'down)
507 ((> sy ty) 'up)))
508 ;; Otherwise, keep going how we're going
509 (else (snake-direction snake)))))
510
466(define (snake-decide-move snake) ; snake => direction 511(define (snake-decide-move snake) ; snake => direction
467 (let* ((head (snake-head snake)) 512 (let* ((head (snake-head snake))
468 (direction (snake-direction snake)) 513 (direction (snake-direction snake))
469 (snake-x (snake-x snake))
470 (snake-y (snake-y snake))
471 (me-x (thing-x (me)))
472 (me-y (thing-y (me)))
473 (new-dir 514 (new-dir
474 ;; Initial decision 515 ;; Initial decision
475 (cond 516 (cond
@@ -478,7 +519,7 @@ See COPYING for details.
478 ((eq? (thing-below head) 'me) 'down) 519 ((eq? (thing-below head) 'me) 'down)
479 ((eq? (thing-to-right head) 'me) 'right) 520 ((eq? (thing-to-right head) 'me) 'right)
480 ((eq? (thing-to-left head) 'me) 'left) 521 ((eq? (thing-to-left head) 'me) 'left)
481 ;; Otherwise, if about to collide with something, dodge it. 522 ;; If about to collide with something, dodge it.
482 ((or (and (thing-above head) 523 ((or (and (thing-above head)
483 (eq? direction 'up)) 524 (eq? direction 'up))
484 (and (thing-below head) 525 (and (thing-below head)
@@ -489,35 +530,31 @@ See COPYING for details.
489 (and (thing-to-left head) 530 (and (thing-to-left head)
490 (eq? direction 'left))) 531 (eq? direction 'left)))
491 (if (thing-above head) 'down 'up)) 532 (if (thing-above head) 'down 'up))
533 ;; If close to the fruit, get it
534 ((> 5 (distance (snake-head snake) (fruit)))
535 (snake-move-toward snake (fruit)))
492 ;; Otherwise, move toward `me' 536 ;; Otherwise, move toward `me'
493 ((< snake-x me-x) 537 (else (snake-move-toward snake (me))))))
494 (if (> (abs (- snake-x me-x)) 538 (unless (eq? direction new-dir)
495 (abs (- snake-y me-y))) 539 (log* direction new-dir))
496 'right
497 (if (< snake-y me-y) 'down 'up)))
498 ((> snake-x me-x)
499 (if (> (abs (- snake-x me-x))
500 (abs (- snake-y me-y)))
501 'left
502 (if (< snake-y me-y) 'down 'up)))
503 ((= snake-x me-x) (cond
504 ((< snake-y me-y) 'down)
505 ((> snake-y me-y) 'up)
506 (else ((game-end) 'lose))))
507 ;; Otherwise, keep going how we're going
508 (else (snake-direction snake)))))
509 ;; Don't let the snake double back into itself 540 ;; Don't let the snake double back into itself
510 (cond 541 (cond
511 ((or (and (eq? direction 'right) 542 ((or (and (eq? direction 'right)
512 (eq? new-dir 'left)) 543 (eq? new-dir 'left))
513 (and (eq? direction 'left) 544 (and (eq? direction 'left)
514 (eq? new-dir 'right))) 545 (eq? new-dir 'right)))
515 (if (< snake-y me-y) 'down 'up)) 546 (snake-direction-set! snake (if (< (snake-x snake) (thing-y (me)))
547 'down
548 'up))
549 (snake-decide-move snake))
516 ((or (and (eq? direction 'up) 550 ((or (and (eq? direction 'up)
517 (eq? new-dir 'down)) 551 (eq? new-dir 'down))
518 (and (eq? direction 'down) 552 (and (eq? direction 'down)
519 (eq? new-dir 'up))) 553 (eq? new-dir 'up)))
520 (if (< snake-x me-x) 'right 'left)) 554 (snake-direction-set! snake (if (< (snake-x snake) (thing-y (me)))
555 'right
556 'left))
557 (snake-decide-move snake))
521 (else new-dir)))) 558 (else new-dir))))
522 559
523(define (snake-update-direction! snake) 560(define (snake-update-direction! snake)