+++ /dev/null
-! Copyright (C) 2015 Sankaranarayanan Viswanathan.
-! See http://factorcode.org/license.txt for BSD license.
-IN: snake-game.constants
-
-SYMBOLS: :left :right :up :down ;
-
-SYMBOLS: :head :body :tail ;
-
-CONSTANT: snake-game-dim { 12 10 }
-
-CONSTANT: snake-game-cell-size 20
! Copyright (C) 2015 Sankaranarayanan Viswanathan.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators kernel make math random
-sequences sets snake-game.constants snake-game.util sorting ;
+USING: accessors arrays assocs combinators fry kernel make math
+math.vectors random sequences sets sorting ;
IN: snake-game.game
+SYMBOLS: :left :right :up :down ;
+
+SYMBOLS: :head :body :tail ;
+
+CONSTANT: snake-game-dim { 12 10 }
+
TUPLE: snake-game
snake snake-loc snake-dir food-loc
{ next-turn-dir initial: f }
: <snake-game> ( -- snake-game )
snake-game new
- <snake> >>snake
- { 5 4 } clone >>snake-loc
- :right >>snake-dir
- { 1 1 } clone >>food-loc ;
+ <snake> >>snake
+ { 5 4 } clone >>snake-loc
+ :right >>snake-dir
+ { 1 1 } clone >>food-loc ;
+
+: ?roll-over ( x max -- x )
+ {
+ { [ 2dup >= ] [ 2drop 0 ] }
+ { [ over neg? ] [ nip 1 - ] }
+ [ drop ]
+ } cond ;
+
+: move-loc ( loc dir -- loc )
+ H{
+ { :left { -1 0 } }
+ { :right { 1 0 } }
+ { :up { 0 -1 } }
+ { :down { 0 1 } }
+ } at v+ snake-game-dim [ ?roll-over ] 2map ;
+
+: opposite-dir ( dir -- dir )
+ H{
+ { :left :right }
+ { :right :left }
+ { :up :down }
+ { :down :up }
+ } at ;
: game-loc>index ( loc -- n )
first2 snake-game-dim first * + ;
: index>game-loc ( n -- loc )
snake-game-dim first /mod swap 2array ;
-: snake-shape ( snake -- dirs )
- [ dir>> ] map ;
-
: grow-snake ( snake dir -- snake )
opposite-dir :head <snake-part> prefix
dup second :body >>type drop ;
: move-snake ( snake dir -- snake )
- dupd [ snake-shape but-last ] dip
+ [ dup but-last [ dir>> ] map ] dip
opposite-dir prefix [ >>dir ] 2map ;
: all-indices ( -- points )
- snake-game-dim first2 * <iota> ;
+ snake-game-dim product <iota> ;
: snake-occupied-locs ( snake head-loc -- points )
- [ dir>> relative-loc ] accumulate nip ;
+ [ dir>> move-loc ] accumulate nip ;
: snake-occupied-indices ( snake head-loc -- points )
snake-occupied-locs [ game-loc>index ] map natural-sort ;
: snake-unoccupied-indices ( snake head-loc -- points )
[ all-indices ] 2dip snake-occupied-indices without ;
-: snake-will-eat-food? ( snake-game dir -- ? )
- [ [ food-loc>> ] [ snake-loc>> ] bi ] dip
- relative-loc = ;
-
-: update-score ( snake-game -- )
- [ 1 + ] change-score
- drop ;
+: snake-will-eat-food? ( snake-game -- ? )
+ [ food-loc>> ] [ snake-loc>> ] [ snake-dir>> ] tri move-loc = ;
-: update-snake-shape ( snake-game dir growing? -- )
- [ [ grow-snake ] curry change-snake ]
- [ [ move-snake ] curry change-snake ]
- if drop ;
+: increase-score ( snake-game -- snake-game )
+ [ 1 + ] change-score ;
-: update-snake-loc ( snake-game dir -- )
- [ relative-loc ] curry change-snake-loc drop ;
+: update-snake-shape ( snake-game growing? -- snake-game )
+ [ dup snake-dir>> ] dip
+ '[ _ _ [ grow-snake ] [ move-snake ] if ] change-snake ;
-: update-snake-dir ( snake-game dir -- )
- >>snake-dir drop ;
+: update-snake-loc ( snake-game -- snake-game )
+ dup snake-dir>> '[ _ move-loc ] change-snake-loc ;
-: generate-food ( snake-game -- )
- [
- [ snake>> ] [ snake-loc>> ] bi
- snake-unoccupied-indices random index>game-loc
- ] keep food-loc<< ;
+: generate-food ( snake-game -- snake-game )
+ dup [ snake>> ] [ snake-loc>> ] bi
+ snake-unoccupied-indices random index>game-loc
+ >>food-loc ;
: game-in-progress? ( snake-game -- ? )
[ game-over?>> ] [ paused?>> ] bi or not ;
f >>next-turn-dir
] when* drop ;
-: snake-will-eat-itself? ( snake-game dir -- ? )
- [ [ snake>> ] [ snake-loc>> ] bi ] dip relative-loc
- [ snake-occupied-locs rest ] keep
- swap member? ;
+: snake-will-eat-itself? ( snake-game -- ? )
+ [ snake>> ] [ snake-loc>> ] [ snake-dir>> ] tri move-loc
+ [ snake-occupied-locs rest ] keep swap member? ;
: game-over ( snake-game -- )
t >>game-over? drop ;
-: update-snake ( snake-game dir -- )
- 2dup snake-will-eat-food?
- {
- [ [ drop update-score ] [ 2drop ] if ]
+: update-snake ( snake-game -- )
+ dup snake-will-eat-food? {
+ [ [ increase-score ] when ]
[ update-snake-shape ]
[ drop update-snake-loc ]
- [ drop update-snake-dir ]
- [ nip [ generate-food ] [ drop ] if ]
- } 3cleave ;
+ [ [ generate-food ] when ]
+ } cleave drop ;
: do-game-step ( snake-game -- )
dup game-in-progress? [
dup ?handle-pending-turn
- dup snake-dir>>
- 2dup snake-will-eat-itself?
- [ drop game-over ] [ update-snake ] if
+ dup snake-will-eat-itself?
+ [ game-over ] [ update-snake ] if
] [ drop ] if ;
+++ /dev/null
-! Copyright (C) 2015 Sankaranarayanan Viswanathan.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs sets snake-game.constants ;
-IN: snake-game.input
-
-: key-action ( key -- action )
- H{
- { "RIGHT" :right }
- { "LEFT" :left }
- { "UP" :up }
- { "DOWN" :down }
- } at ;
-
-: quit-key? ( key -- ? )
- HS{ "ESC" "q" "Q" } in? ;
-
-: pause-key? ( key -- ? )
- HS{ " " "SPACE" "p" "P" } in? ;
-
-: new-game-key? ( key -- ? )
- HS{ "ENTER" "RET" "n" "N" } in? ;
IN: snake-game
: <snake-world-attributes> ( -- world-attributes )
- <world-attributes> "Snake Game" >>title
+ <world-attributes> "Snake Game" >>title
[
{ maximize-button resize-handles } without
] change-window-controls ;
swap [ image ] 2dip sw sh image-part
] cartesian-map f join ;
-: load-sprite-image ( filename -- image )
+: load-snake-image ( filename -- image )
"vocab:snake-game/_resources/%s" sprintf load-image ;
-: make-texture ( image -- texture )
- { 0 0 } <texture> ;
+: load-snake-texture ( file-name -- texture )
+ load-snake-image { 0 0 } <texture> ;
-: make-sprites ( filename cols rows -- seq )
- [ load-sprite-image ] 2dip generate-sprite-sheet
- [ make-texture ] map ;
+: load-sprite-textures ( filename cols rows -- seq )
+ [ load-snake-image ] 2dip generate-sprite-sheet
+ [ { 0 0 } <texture> ] map ;
: snake-head-textures ( -- assoc )
- "head.png" 1 4 make-sprites
{ "head-up" "head-right" "head-down" "head-left" }
- [ swap 2array ] 2map ;
-
-:: assoc-with-value-like ( assoc key seq -- )
- key assoc at :> value
- seq [ [ value ] dip assoc set-at ] each ;
+ "head.png" 1 4 load-sprite-textures zip ;
: snake-body-textures ( -- assoc )
- "body.png" 3 2 make-sprites
- { 1 2 3 4 5 6 }
- [ swap 2array ] 2map
- dup 1 { "body-right-up" "body-down-left" } assoc-with-value-like
- dup 2 { "body-down-right" "body-left-up" } assoc-with-value-like
- dup 3 { "body-right-right" "body-left-left" } assoc-with-value-like
- dup 4 { "body-up-up" "body-down-down" } assoc-with-value-like
- dup 5 { "body-up-right" "body-left-down" } assoc-with-value-like
- dup 6 { "body-right-down" "body-up-left" } assoc-with-value-like
- dup [ { 1 2 3 4 5 6 } ] dip [ delete-at ] curry each ;
+ {
+ "body-right-up" "body-down-right" "body-right-right"
+ "body-up-up" "body-up-right" "body-right-down"
+ }
+ {
+ "body-down-left" "body-left-up" "body-left-left"
+ "body-down-down" "body-left-down" "body-up-left"
+ }
+ "body.png" 3 2 load-sprite-textures '[ _ zip ] bi@ append ;
: snake-tail-textures ( -- assoc )
- "tail.png" 2 2 make-sprites
{ "tail-down" "tail-left" "tail-up" "tail-right" }
- [ swap 2array ] 2map ;
+ "tail.png" 2 2 load-sprite-textures zip ;
: food-texture ( -- assoc )
- "food" "food.png" load-sprite-image make-texture
- 2array 1array ;
+ "food" "food.png" load-snake-texture 2array 1array ;
: background-texture ( -- assoc )
- "background" "background.png" load-sprite-image make-texture
- 2array 1array ;
+ "background" "background.png" load-snake-texture 2array 1array ;
! Copyright (C) 2015 Sankaranarayanan Viswanathan.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators destructors
-formatting kernel make math namespaces opengl opengl.textures
-sequences sets snake-game.constants snake-game.game
-snake-game.input snake-game.util snake-game.sprites timers
-ui ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
-
-FROM: snake-game.util => screen-loc ;
-FROM: snake-game.util => relative-loc ;
+formatting kernel make math math.vectors namespaces opengl
+opengl.textures sequences sets snake-game.game
+snake-game.sprites timers ui ui.gadgets ui.gadgets.worlds
+ui.gestures ui.render ;
IN: snake-game.ui
<snake-game> >>snake-game drop ;
: <snake-gadget> ( -- snake-gadget )
- snake-gadget new
- [ start-new-game ] keep ;
+ snake-gadget new [ start-new-game ] keep ;
+
+CONSTANT: snake-game-cell-size 20
+
+: game-loc>screen-loc ( loc -- loc )
+ [ snake-game-cell-size * ] map ;
: lookup-texture ( key -- texture )
game-textures get at ;
[ lookup-texture draw-texture ] with-translation ;
: draw-sprite ( grid-loc key -- )
- swap screen-loc draw-sprite* ;
+ swap game-loc>screen-loc draw-sprite* ;
: draw-food ( loc -- )
"food" draw-sprite ;
{ 0 0 } "background" draw-sprite ;
: draw-snake-head ( loc facing-dir -- )
- dup name>> rest "head-" prepend
- [
- [ screen-loc ] dip
+ dup name>> rest "head-" prepend [
+ [ game-loc>screen-loc ] dip
{
{ :right [ { -20 -10 } ] }
{ :down [ { -10 -20 } ] }
{ :up [ { -10 0 } ] }
{ :left [ { 0 -10 } ] }
- } case offset
- ] dip
- swap draw-sprite* ;
+ } case v+
+ ] dip swap draw-sprite* ;
: draw-snake-body ( loc from-dir to-dir -- )
[ name>> rest ] bi@ "body-%s-%s" sprintf draw-sprite ;
} case ;
: next-snake-loc-from-dir ( loc from-dir snake-part -- new-loc new-from-dir )
- nip dir>> [ relative-loc ] keep ;
+ nip dir>> [ move-loc ] keep ;
: draw-snake ( loc from-dir snake -- )
3dup [
first draw-snake-part ;
: generate-status-message ( snake-game -- str )
- [ score>> "Score: %d" sprintf ]
+ [ score>> ]
[
{
{ [ dup game-over?>> ] [ drop "Game Over" ] }
{ [ dup paused?>> ] [ drop "Game Paused" ] }
[ drop "Game In Progress" ]
} cond
- ]
- bi 2array " -- " join ;
-
+ ] bi "Score: %d -- %s" sprintf ;
+
: update-status ( gadget -- )
[ snake-game>> generate-status-message ] keep show-status ;
: toggle-game-pause ( snake-gadget -- )
snake-game>> [ not ] change-paused? drop ;
+: key-action ( key -- action )
+ H{
+ { "RIGHT" :right }
+ { "LEFT" :left }
+ { "UP" :up }
+ { "DOWN" :down }
+ } at ;
+
+: quit-key? ( key -- ? )
+ HS{ "ESC" "q" "Q" } in? ;
+
+: pause-key? ( key -- ? )
+ HS{ " " "SPACE" "p" "P" } in? ;
+
+: new-game-key? ( key -- ? )
+ HS{ "ENTER" "RET" "n" "N" } in? ;
+
: ?handle-movement-key ( snake-game key -- )
key-action
[
M: snake-gadget ungraft*
[ stop-timer f ] change-timer
- dup textures>> values [ dispose ] each
- f >>textures drop ;
+ [ values dispose-each f ] change-textures
+ drop ;
M: snake-gadget pref-dim*
drop snake-game-dim [ snake-game-cell-size * 20 + ] map ;
+++ /dev/null
-! Copyright (C) 2015 Sankaranarayanan Viswanathan.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators kernel math sequences
-snake-game.constants ;
-
-IN: snake-game.util
-
-: screen-loc ( loc -- loc )
- [ snake-game-cell-size * ] map ;
-
-: offset ( loc dim -- loc )
- [ + ] 2map ;
-
-: ?roll-over ( x max -- x )
- {
- { [ 2dup >= ] [ 2drop 0 ] }
- { [ over neg? ] [ nip 1 - ] }
- [ drop ]
- } cond ;
-
-: ?roll-over-x ( x -- x )
- snake-game-dim first ?roll-over ;
-
-: ?roll-over-y ( y -- y )
- snake-game-dim second ?roll-over ;
-
-: move ( loc dim -- loc )
- offset first2
- [ ?roll-over-x ] [ ?roll-over-y ] bi* 2array ;
-
-: relative-loc ( loc dir -- loc )
- {
- { :left [ { -1 0 } move ] }
- { :right [ { 1 0 } move ] }
- { :up [ { 0 -1 } move ] }
- { :down [ { 0 1 } move ] }
- } case ;
-
-: opposite-dir ( dir -- dir )
- H{
- { :left :right }
- { :right :left }
- { :up :down }
- { :down :up }
- } at ;
projects / factor.git / commitdiff