1 ! Copyright (C) 2015 Your name.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators kernel make math random
4 sequences sets snake-game.constants snake-game.util sorting ;
9 snake snake-loc snake-dir food-loc
10 { next-turn-dir initial: f }
11 { score integer initial: 0 }
12 { paused? boolean initial: t }
13 { game-over? boolean initial: f } ;
18 C: <snake-part> snake-part
20 : <snake> ( -- snake )
22 :left :head <snake-part> ,
23 :left :body <snake-part> ,
24 :left :tail <snake-part> ,
27 : <snake-game> ( -- snake-game )
30 { 5 4 } clone >>snake-loc
32 { 1 1 } clone >>food-loc ;
34 : game-loc>index ( loc -- n )
35 first2 snake-game-dim first * + ;
37 : index>game-loc ( n -- loc )
38 snake-game-dim first /mod swap 2array ;
40 : snake-shape ( snake -- dirs )
43 : grow-snake ( snake dir -- snake )
44 opposite-dir :head <snake-part> prefix
45 dup second :body >>type drop ;
47 : move-snake ( snake dir -- snake )
48 dupd [ snake-shape but-last ] dip
49 opposite-dir prefix [ >>dir ] 2map ;
51 : all-indices ( -- points )
52 snake-game-dim first2 * iota ;
54 : snake-occupied-locs ( snake head-loc -- points )
55 [ dir>> relative-loc ] accumulate nip ;
57 : snake-occupied-indices ( snake head-loc -- points )
58 snake-occupied-locs [ game-loc>index ] map natural-sort ;
60 : snake-unoccupied-indices ( snake head-loc -- points )
61 [ all-indices ] 2dip snake-occupied-indices without ;
63 : snake-will-eat-food? ( snake-game dir -- ? )
64 [ [ food-loc>> ] [ snake-loc>> ] bi ] dip
67 : update-score ( snake-game -- )
71 : update-snake-shape ( snake-game dir growing? -- )
72 [ [ grow-snake ] curry change-snake ]
73 [ [ move-snake ] curry change-snake ]
76 : update-snake-loc ( snake-game dir -- )
77 [ relative-loc ] curry change-snake-loc drop ;
79 : update-snake-dir ( snake-game dir -- )
82 : generate-food ( snake-game -- )
84 [ snake>> ] [ snake-loc>> ] bi
85 snake-unoccupied-indices random index>game-loc
88 : game-in-progress? ( snake-game -- ? )
89 [ game-over?>> ] [ paused?>> ] bi or not ;
91 : ?handle-pending-turn ( snake-game -- )
97 : snake-will-eat-itself? ( snake-game dir -- ? )
98 [ [ snake>> ] [ snake-loc>> ] bi ] dip relative-loc
99 [ snake-occupied-locs rest ] keep
102 : game-over ( snake-game -- )
103 t >>game-over? drop ;
105 : update-snake ( snake-game dir -- )
106 2dup snake-will-eat-food?
108 [ [ drop update-score ] [ 2drop ] if ]
109 [ update-snake-shape ]
110 [ drop update-snake-loc ]
111 [ drop update-snake-dir ]
112 [ nip [ generate-food ] [ drop ] if ]
115 : do-game-step ( snake-game -- )
116 dup game-in-progress? [
117 dup ?handle-pending-turn
119 2dup snake-will-eat-itself?
120 [ drop game-over ] [ update-snake ] if