#lang typed-scheme
(require (planet dvanhorn/typed-student/advanced)
(planet dvanhorn/typed-student/world))
(provide (all-defined-out))
(define-type-alias Seg Posn)
(define-struct food ([x : Number] [y : Number] [t : Number]))
(define-type-alias Food food)
(define-type-alias Dir (U 'up 'down 'left 'right))
(define-struct snake ([dir : Dir]
[segs : (Pair Seg (Listof Seg))]))
(define-type-alias Snake snake)
(define-struct world ([snake : Snake]
[food : (Listof Food)]
[level : Level]
[blocks : (Listof Block)]))
(define-type-alias World world)
(define-type-alias Level Number)
(define-type-alias Block Posn)
(define SEG-SIZE 8)
(define WIDTH (* SEG-SIZE 30))
(define HEIGHT (* SEG-SIZE 30))
(define FOOD-LIFE 50)
(define food0
(list (make-food (* 4 SEG-SIZE) (* 4 SEG-SIZE) FOOD-LIFE)))
(define snake0
(make-snake 'right
(list (make-posn SEG-SIZE SEG-SIZE))))
(define world0
(make-world snake0 empty 0 empty))
(: posn=? (Posn Posn -> Boolean))
(define (posn=? p1 p2)
(and (= (posn-x p1) (posn-x p2))
(= (posn-y p1) (posn-y p2))))
(: posn-move (Posn Number Number -> Posn))
(define (posn-move p dx dy)
(make-posn (+ (posn-x p) dx)
(+ (posn-y p) dy)))
(: all-but-last (∀ (α) ((Pair α (Listof α)) -> (Listof α))))
(define (all-but-last segs)
(let ((r (rest segs))) (cond [(empty? r) empty]
[else (cons (first segs) (all-but-last r))])))
(: direction? (Any -> Boolean : Dir))
(define (direction? x)
(and (symbol? x)
(or (symbol=? x 'up)
(symbol=? x 'down)
(symbol=? x 'left)
(symbol=? x 'right))))
(: snake-head (Snake -> Seg))
(define (snake-head snake)
(first (snake-segs snake)))
(: next-head (Snake -> Seg))
(define (next-head snake)
(move-seg (first (snake-segs snake))
(snake-dir snake)))
(: move-seg (Seg Dir -> Seg))
(define (move-seg seg dir)
(cond [(symbol=? dir 'up) (posn-move seg 0 (- SEG-SIZE))]
[(symbol=? dir 'down) (posn-move seg 0 SEG-SIZE)]
[(symbol=? dir 'left) (posn-move seg (- SEG-SIZE) 0)]
[(symbol=? dir 'right) (posn-move seg SEG-SIZE 0)]))
(: eating? (Snake Food -> Boolean))
(define (eating? snake food)
(posn=? (snake-head snake)
(make-posn (food-x food) (food-y food))))
(: self-colliding? (Snake -> Boolean))
(define (self-colliding? snake)
(ormap (lambda: ([s : Seg]) (posn=? (next-head snake) s))
(rest (snake-segs snake))))
(: wall-colliding? (Snake -> Boolean))
(define (wall-colliding? snake)
(let ((x (posn-x (snake-head snake)))
(y (posn-y (snake-head snake))))
(or (= 0 x) (= x WIDTH)
(= 0 y) (= y HEIGHT))))
(: block-colliding? (Snake Block -> Boolean))
(define (block-colliding? s b)
(posn=? (next-head s) b))
(: snake-slither (Snake -> Snake))
(define (snake-slither snake)
(make-snake (snake-dir snake)
(ann (cons (next-head snake)
(all-but-last (snake-segs snake)))
(Pair Seg (Listof Seg)))))
(: snake-grow (Snake -> Snake))
(define (snake-grow snake)
(make-snake (snake-dir snake)
(ann (cons (next-head snake)
(snake-segs snake))
(Pair Seg (Listof Seg)))))
(: snake-change-direction (Snake Dir -> Snake))
(define (snake-change-direction snake dir)
(make-snake dir (snake-segs snake)))
(define MT-SCENE (empty-scene WIDTH HEIGHT))
(define FOOD-IMG
(overlay
(circle SEG-SIZE 'solid 'green)
(circle SEG-SIZE 'outline 'black)))
(define SEG-IMG
(overlay
(circle SEG-SIZE 'solid 'red)
(circle SEG-SIZE 'outline 'black)))
(define BLOCK-IMG
(overlay
(circle SEG-SIZE 'solid 'gray)
(circle SEG-SIZE 'outline 'black)))
(: level+scene (Level Scene -> Scene))
(define (level+scene level scene)
(place-image (text (number->string level) 30 'gray)
0
0
scene))
(: snake+scene (Snake Scene -> Scene))
(define (snake+scene snake scene)
(head+scene (first (snake-segs snake))
(snake-dir snake)
(foldr seg+scene scene (rest (snake-segs snake)))))
(: dir->string (Dir -> String))
(define (dir->string dir)
(cond [(symbol=? dir 'up) "↑"]
[(symbol=? dir 'down) "↓"]
[(symbol=? dir 'left) "←"]
[(symbol=? dir 'right) "→"]))
(: head+scene (Seg Dir Scene -> Scene))
(define (head+scene s d scene)
(place-image
(let ((t (text (dir->string d) 16 'black)))
(overlay/xy SEG-IMG
(* -1/2 (image-width t))
(* -1/2 (image-height t))
t))
(posn-x s)
(posn-y s)
scene))
(: seg+scene (Seg Scene -> Scene))
(define (seg+scene seg scene)
(img+scene seg SEG-IMG scene))
(: food+scene (Food Scene -> Scene))
(define (food+scene f scene)
(place-image FOOD-IMG (food-x f) (food-y f) scene))
(: blocks+scene ([Listof Block] Scene -> Scene))
(define (blocks+scene bs scene)
(foldr (lambda: ([b : Block] [s : Scene])
(img+scene b BLOCK-IMG s))
scene
bs))
(: img+scene (Posn Image Scene -> Scene))
(define (img+scene posn img scene)
(place-image img (posn-x posn) (posn-y posn) scene))
(: eat-food (Snake [Listof Food] -> [Listof Food]))
(define (eat-food s lof)
(filter (lambda: ([f : Food]) (not (eating? s f)))
lof))
(: maybe-new-food ([Listof Food] -> [Listof Food]))
(define (maybe-new-food lof)
(cond [(zero? (random FOOD-LIFE))
(cons (new-food) lof)]
[else lof]))
(: new-food (-> Food))
(define (new-food)
(make-food
(* SEG-SIZE (add1 (random (sub1 (quotient WIDTH SEG-SIZE)))))
(* SEG-SIZE (add1 (random (sub1 (quotient HEIGHT SEG-SIZE)))))
(+ (* 1/2 FOOD-LIFE) (random FOOD-LIFE))))
(: new-block (-> Block))
(define (new-block)
(make-posn
(* SEG-SIZE (add1 (random (sub1 (quotient WIDTH SEG-SIZE)))))
(* SEG-SIZE (add1 (random (sub1 (quotient HEIGHT SEG-SIZE)))))))
(: eat-and-grow (World -> World))
(define (eat-and-grow w)
(make-world (snake-grow (world-snake w))
(cons (new-food) (eat-food (world-snake w) (world-food w)))
(world-level w)
(world-blocks w)))
(: food-decay (Food -> Food))
(define (food-decay f)
(make-food (food-x f)
(food-y f)
(sub1 (food-t f))))
(: food-rotten? (Food -> Boolean))
(define (food-rotten? f)
(zero? (food-t f)))
(: next-level (World -> World))
(define (next-level w)
(make-world (truncate-snake (world-snake w))
(world-food w)
(add1 (world-level w))
(cons (new-block) (world-blocks w))))
(: truncate-snake (Snake -> Snake))
(define (truncate-snake s)
(make-snake (snake-dir s)
(list (first (snake-segs s)))))
(: level-complete? (World -> Boolean))
(define (level-complete? w)
(> (length (snake-segs (world-snake w)))
(expt 2 (world-level w))))
(: food-not-rotten? (Food -> Boolean))
(define (food-not-rotten? f)
(not (food-rotten? f)))
(begin
(require/typed big-bang (Number Number Number World -> Boolean) htdp/world)
(require/typed stop-when ((World -> Boolean) -> Boolean) htdp/world)
(require/typed on-tick-event ((World -> World) -> Boolean) htdp/world)
(require/typed on-redraw ((World -> Scene) -> Boolean) htdp/world)
(require/typed on-key-event ((World KeyEvent -> World) -> Boolean) htdp/world))
(big-bang WIDTH HEIGHT 1/10 world0)
(on-redraw
(lambda: ([w : World])
(snake+scene (world-snake w)
(blocks+scene
(world-blocks w)
(foldr food+scene
(level+scene (world-level w) MT-SCENE)
(world-food w))))))
(on-tick-event
(lambda: ([w : World])
(cond [(ormap (lambda: ([f : Food]) (eating? (world-snake w) f)) (world-food w))
(eat-and-grow w)]
[(level-complete? w)
(next-level w)]
[else
(make-world
(snake-slither (world-snake w))
(maybe-new-food
(filter food-not-rotten? (map food-decay (world-food w))))
(world-level w)
(world-blocks w))])))
(on-key-event
(lambda: ([w : World] [ke : KeyEvent])
(cond [(direction? ke)
(make-world (snake-change-direction (world-snake w) ke)
(world-food w)
(world-level w)
(world-blocks w))]
[else w])))
(stop-when
(lambda: ([w : World])
(or (self-colliding? (world-snake w))
(wall-colliding? (world-snake w))
(ormap (lambda: ([b : Block]) (block-colliding? (world-snake w) b))
(world-blocks w)))))