From 9eef1780f1bac4686ad8accaa7e1d1836aed3e07 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Fri, 2 Jun 2023 23:52:41 -0500 Subject: Snake eats fruit The snake eats fruit and grows now! Though it's still pretty hit or miss as far as avoiding itself goes. I need to continue playing around with it I think. --- apple.scm | 115 +++++++++++++++++++++++++++++++++++++++++--------------------- 1 file 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. "<" 20 20 2) (list))) (fruit (make-thing 'fruit (world) - (random-choice (fruits)) 10 20 1))) + (random-choice (fruits)) 10 20 2))) (case (dynamic-wind game-setup game-loop game-cleanup) @@ -143,7 +143,7 @@ See COPYING for details. (loop (random-x world) (random-y world)) (values x y)))) -(define (random-choice . choices) +(define (random-choice choices) (list-ref choices (random-int (length choices)))) ;;; Drawing stuff @@ -218,6 +218,7 @@ See COPYING for details. (thing-place! (wall w x y))) (else))) world) + (draw-title world 10 10) (thing-pos-randomize! (me)) (thing-place! (me)) (thing-pos-randomize! (snake-head (snake))) @@ -232,6 +233,14 @@ See COPYING for details. (thing-x-set! thing x) (thing-y-set! thing y))) +(define (draw-title world x y) + (for-each thing-place! + (list (make-thing 'a world (with-attrs '(italic dim) "A") x y 0) + (make-thing 'p world (with-attrs '(italic dim) "P") (+ x 2) y 0) + (make-thing 'p world (with-attrs '(italic dim) "P") (+ x 4) y 0) + (make-thing 'p world (with-attrs '(italic dim) "L") (+ x 6) y 0) + (make-thing 'p world (with-attrs '(italic dim) "E") (+ x 8) y 0)))) + ;;; Things (define-record-type @@ -247,20 +256,6 @@ See COPYING for details. (define (wall w x y) (make-thing 'wall w "#" x y 100)) -(define (thing-attr-get thing attr) - (let ((x (assoc attr (thing-attrs thing)))) - (if x - (cdr x) - #f))) - -(define (thing-attr-set! thing attr val) - (let ((x (assoc attr (thing-attrs thing)))) - (if x - (set-cdr! x val) - (thing-attrs-set! thing - (cons (cons attr val) - (thing-attrs thing)))))) - (define (thing-place! thing) (world-set! (thing-world thing) (thing-x thing) (thing-y thing) thing)) @@ -299,21 +294,40 @@ See COPYING for details. (define (snake-head? x) (and (thing? x) (eq? 'snake-head (thing-name x)))) + +(define (fruit? x) + (and (thing? x) + (eq? 'fruit (thing-name x)))) ;;; hacky-end (define (handle-collision a b) + (log* (thing-name a) (thing-name b)) (cond ((or (and (me? a) (snake-head? b)) (and (snake-head? a) (me? b))) (game-lose)) + ((or (and (fruit? a) (snake-head? b)) + (and (snake-head? a) (fruit? b))) + (snake-eat-fruit)) ((or (and (snake-head? a) (thing? b)) (and (thing? a) (snake-head? b))) (game-win)) (else))) +(define (snake-eat-fruit) + #;(log* "snake eat fruit") + (world-set! (thing-world (fruit)) + (thing-x (fruit)) + (thing-y (fruit)) + #f) + (thing-pos-randomize! (fruit)) + (thing-look-set! (fruit) (random-choice (fruits))) + (snake-length-set! (snake) (+ (random-int 4 7) (snake-length (snake))))) + (define (game-win) (draw (cursor-move 10 10) "YOU WIN!") + (sleep 1) (readch) (newline) ((game-end) 'win)) @@ -321,6 +335,7 @@ See COPYING for details. (define (game-lose) (draw (cursor-move 10 10) "YOU LOSE :(") + (sleep 1) (readch) (newline) ((game-end) 'lose)) @@ -463,13 +478,39 @@ See COPYING for details. ((left) "<") ((up) "^")))) +(define (distance thing-a thing-b) + (sqrt (+ (expt (abs (- (thing-x thing-a) + (thing-x thing-b))) + 2) + (expt (abs (- (thing-y thing-a) + (thing-y thing-b))) + 2)))) + +(define (snake-move-toward snake thing) + (let ((tx (thing-x thing)) + (ty (thing-y thing)) + (sx (snake-x snake)) + (sy (snake-y snake))) + (cond + ((< sx tx) + (if (> (abs (- sx tx)) + (abs (- sy ty))) + 'right + (if (< sy ty) 'down 'up))) + ((> sx tx) + (if (> (abs (- sx tx)) + (abs (- sy ty))) + 'left + (if (< sy ty) 'down 'up))) + ((= sx tx) (cond + ((<= sy ty) 'down) + ((> sy ty) 'up))) + ;; Otherwise, keep going how we're going + (else (snake-direction snake))))) + (define (snake-decide-move snake) ; snake => direction (let* ((head (snake-head snake)) (direction (snake-direction snake)) - (snake-x (snake-x snake)) - (snake-y (snake-y snake)) - (me-x (thing-x (me))) - (me-y (thing-y (me))) (new-dir ;; Initial decision (cond @@ -478,7 +519,7 @@ See COPYING for details. ((eq? (thing-below head) 'me) 'down) ((eq? (thing-to-right head) 'me) 'right) ((eq? (thing-to-left head) 'me) 'left) - ;; Otherwise, if about to collide with something, dodge it. + ;; If about to collide with something, dodge it. ((or (and (thing-above head) (eq? direction 'up)) (and (thing-below head) @@ -489,35 +530,31 @@ See COPYING for details. (and (thing-to-left head) (eq? direction 'left))) (if (thing-above head) 'down 'up)) + ;; If close to the fruit, get it + ((> 5 (distance (snake-head snake) (fruit))) + (snake-move-toward snake (fruit))) ;; Otherwise, move toward `me' - ((< snake-x me-x) - (if (> (abs (- snake-x me-x)) - (abs (- snake-y me-y))) - 'right - (if (< snake-y me-y) 'down 'up))) - ((> snake-x me-x) - (if (> (abs (- snake-x me-x)) - (abs (- snake-y me-y))) - 'left - (if (< snake-y me-y) 'down 'up))) - ((= snake-x me-x) (cond - ((< snake-y me-y) 'down) - ((> snake-y me-y) 'up) - (else ((game-end) 'lose)))) - ;; Otherwise, keep going how we're going - (else (snake-direction snake))))) + (else (snake-move-toward snake (me)))))) + (unless (eq? direction new-dir) + (log* direction new-dir)) ;; Don't let the snake double back into itself (cond ((or (and (eq? direction 'right) (eq? new-dir 'left)) (and (eq? direction 'left) (eq? new-dir 'right))) - (if (< snake-y me-y) 'down 'up)) + (snake-direction-set! snake (if (< (snake-x snake) (thing-y (me))) + 'down + 'up)) + (snake-decide-move snake)) ((or (and (eq? direction 'up) (eq? new-dir 'down)) (and (eq? direction 'down) (eq? new-dir 'up))) - (if (< snake-x me-x) 'right 'left)) + (snake-direction-set! snake (if (< (snake-x snake) (thing-y (me))) + 'right + 'left)) + (snake-decide-move snake)) (else new-dir)))) (define (snake-update-direction! snake) -- cgit 1.4.1-21-gabe81