snake-game: refactor and restruture
Sankaranarayanan Viswanathan
John Benediktsson
parent
38eb231977
commit
bb43e27b86
|
Before Width: | Height: | Size: 707 KiB After Width: | Height: | Size: 707 KiB |
|
Before Width: | Height: | Size: 4.0 KiB After Width: | Height: | Size: 4.0 KiB |
|
Before Width: | Height: | Size: 1.8 KiB After Width: | Height: | Size: 1.8 KiB |
|
Before Width: | Height: | Size: 9.3 KiB After Width: | Height: | Size: 9.3 KiB |
|
Before Width: | Height: | Size: 2.3 KiB After Width: | Height: | Size: 2.3 KiB |
|
|
@ -0,0 +1,11 @@
|
||||||
|
! Copyright (C) 2015 Your name.
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,121 @@
|
||||||
|
! Copyright (C) 2015 Your name.
|
||||||
|
! 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 ;
|
||||||
|
|
||||||
|
IN: snake-game.game
|
||||||
|
|
||||||
|
TUPLE: snake-game
|
||||||
|
snake snake-loc snake-dir food-loc
|
||||||
|
{ next-turn-dir initial: f }
|
||||||
|
{ score integer initial: 0 }
|
||||||
|
{ paused? boolean initial: t }
|
||||||
|
{ game-over? boolean initial: f } ;
|
||||||
|
|
||||||
|
TUPLE: snake-part
|
||||||
|
dir type ;
|
||||||
|
|
||||||
|
C: <snake-part> snake-part
|
||||||
|
|
||||||
|
: <snake> ( -- snake )
|
||||||
|
[
|
||||||
|
:left :head <snake-part> ,
|
||||||
|
:left :body <snake-part> ,
|
||||||
|
:left :tail <snake-part> ,
|
||||||
|
] V{ } make ;
|
||||||
|
|
||||||
|
: <snake-game> ( -- snake-game )
|
||||||
|
snake-game new
|
||||||
|
<snake> >>snake
|
||||||
|
{ 5 4 } clone >>snake-loc
|
||||||
|
:right >>snake-dir
|
||||||
|
{ 1 1 } clone >>food-loc ;
|
||||||
|
|
||||||
|
: 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
|
||||||
|
opposite-dir prefix [ >>dir ] 2map ;
|
||||||
|
|
||||||
|
: all-indices ( -- points )
|
||||||
|
snake-game-dim first2 * iota ;
|
||||||
|
|
||||||
|
: snake-occupied-locs ( snake head-loc -- points )
|
||||||
|
[ dir>> relative-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 ;
|
||||||
|
|
||||||
|
: update-snake-shape ( snake-game dir growing? -- )
|
||||||
|
[ [ grow-snake ] curry change-snake ]
|
||||||
|
[ [ move-snake ] curry change-snake ]
|
||||||
|
if drop ;
|
||||||
|
|
||||||
|
: update-snake-loc ( snake-game dir -- )
|
||||||
|
[ relative-loc ] curry change-snake-loc drop ;
|
||||||
|
|
||||||
|
: update-snake-dir ( snake-game dir -- )
|
||||||
|
>>snake-dir drop ;
|
||||||
|
|
||||||
|
: generate-food ( snake-game -- )
|
||||||
|
[
|
||||||
|
[ snake>> ] [ snake-loc>> ] bi
|
||||||
|
snake-unoccupied-indices random index>game-loc
|
||||||
|
] keep food-loc<< ;
|
||||||
|
|
||||||
|
: game-in-progress? ( snake-game -- ? )
|
||||||
|
[ game-over?>> ] [ paused?>> ] bi or not ;
|
||||||
|
|
||||||
|
: ?handle-pending-turn ( snake-game -- )
|
||||||
|
dup next-turn-dir>> [
|
||||||
|
>>snake-dir
|
||||||
|
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? ;
|
||||||
|
|
||||||
|
: 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-shape ]
|
||||||
|
[ drop update-snake-loc ]
|
||||||
|
[ drop update-snake-dir ]
|
||||||
|
[ nip [ generate-food ] [ drop ] if ]
|
||||||
|
} 3cleave ;
|
||||||
|
|
||||||
|
: 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
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
@ -1,28 +0,0 @@
|
||||||
! Copyright (C) 2015 Sankaranarayanan Viswanathan
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: accessors arrays byte-vectors fry images kernel locals
|
|
||||||
math sequences ;
|
|
||||||
|
|
||||||
IN: snake-game.helper
|
|
||||||
|
|
||||||
: new-image-like ( image w h -- image )
|
|
||||||
[ clone ] 2dip
|
|
||||||
[ 2array >>dim ] 2keep *
|
|
||||||
over bytes-per-pixel * <byte-vector> >>bitmap ;
|
|
||||||
|
|
||||||
:: image-part ( image x y w h -- image )
|
|
||||||
image w h new-image-like :> new-image
|
|
||||||
h iota [| i |
|
|
||||||
new-image bitmap>>
|
|
||||||
x y i + w image pixel-row-slice-at
|
|
||||||
append! drop
|
|
||||||
] each new-image ;
|
|
||||||
|
|
||||||
:: generate-sprite-sheet ( image rows cols -- seq )
|
|
||||||
cols rows 2array :> split-dims
|
|
||||||
image dim>> split-dims [ / ] 2map first2 :> ( sw sh )
|
|
||||||
rows iota [ sh * ] map :> ys
|
|
||||||
cols iota [ sw * ] map :> xs
|
|
||||||
ys xs [
|
|
||||||
swap [ image ] 2dip sw sh image-part
|
|
||||||
] cartesian-map f join ;
|
|
||||||
|
|
@ -0,0 +1,21 @@
|
||||||
|
! Copyright (C) 2015 Your name.
|
||||||
|
! 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? ;
|
||||||
|
|
@ -1,388 +1,8 @@
|
||||||
! Copyright (C) 2015 Sankaranarayanan Viswanathan
|
! Copyright (C) 2015 Sankaranarayanan Viswanathan
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays assocs calendar combinators destructors
|
USING: accessors sets snake-game.ui ui ui.gadgets.status-bar ui.gadgets.worlds ;
|
||||||
formatting hash-sets images.loader kernel locals make math
|
|
||||||
namespaces opengl opengl.textures random sequences sets sorting
|
|
||||||
snake-game.helper timers ui ui.gadgets ui.gadgets.status-bar
|
|
||||||
ui.gadgets.worlds ui.gestures ui.render vocabs.loader ;
|
|
||||||
|
|
||||||
IN: snake-game
|
IN: snake-game
|
||||||
|
|
||||||
SYMBOLS: :left :right :up :down ;
|
|
||||||
|
|
||||||
SYMBOLS: :head :body :tail ;
|
|
||||||
|
|
||||||
SYMBOL: game-textures
|
|
||||||
|
|
||||||
CONSTANT: snake-game-dim { 12 10 }
|
|
||||||
|
|
||||||
TUPLE: snake-game
|
|
||||||
snake snake-loc snake-dir food-loc
|
|
||||||
{ next-turn-dir initial: f }
|
|
||||||
{ score integer initial: 0 }
|
|
||||||
{ paused? boolean initial: t }
|
|
||||||
{ game-over? boolean initial: f } ;
|
|
||||||
|
|
||||||
TUPLE: snake-part
|
|
||||||
dir type ;
|
|
||||||
|
|
||||||
: <snake-part> ( dir type -- snake-part )
|
|
||||||
snake-part boa ;
|
|
||||||
|
|
||||||
: <snake> ( -- snake )
|
|
||||||
[
|
|
||||||
:left :head <snake-part> ,
|
|
||||||
:left :body <snake-part> ,
|
|
||||||
:left :tail <snake-part> ,
|
|
||||||
] V{ } make ;
|
|
||||||
|
|
||||||
: <snake-game> ( -- snake-game )
|
|
||||||
snake-game new
|
|
||||||
<snake> >>snake
|
|
||||||
{ 5 4 } clone >>snake-loc
|
|
||||||
:right >>snake-dir
|
|
||||||
{ 1 1 } clone >>food-loc ;
|
|
||||||
|
|
||||||
TUPLE: snake-gadget < gadget
|
|
||||||
snake-game timer textures ;
|
|
||||||
|
|
||||||
: start-new-game ( snake-gadget -- )
|
|
||||||
<snake-game> >>snake-game drop ;
|
|
||||||
|
|
||||||
: <snake-gadget> ( -- snake-gadget )
|
|
||||||
snake-gadget new
|
|
||||||
[ start-new-game ] keep ;
|
|
||||||
|
|
||||||
: opposite-dir ( dir -- dir )
|
|
||||||
H{
|
|
||||||
{ :left :right }
|
|
||||||
{ :right :left }
|
|
||||||
{ :up :down }
|
|
||||||
{ :down :up }
|
|
||||||
} at ;
|
|
||||||
|
|
||||||
: lookup-texture ( key -- texture )
|
|
||||||
game-textures get at ;
|
|
||||||
|
|
||||||
: screen-loc ( loc -- loc )
|
|
||||||
[ 20 * ] map ;
|
|
||||||
|
|
||||||
: draw-sprite* ( key screen-loc -- )
|
|
||||||
[ lookup-texture draw-texture ] with-translation ;
|
|
||||||
|
|
||||||
: draw-sprite ( grid-loc key -- )
|
|
||||||
swap screen-loc draw-sprite* ;
|
|
||||||
|
|
||||||
: draw-food ( loc -- )
|
|
||||||
"food" draw-sprite ;
|
|
||||||
|
|
||||||
: draw-background ( -- )
|
|
||||||
{ 0 0 } "background" draw-sprite ;
|
|
||||||
|
|
||||||
: offset ( loc dim -- loc )
|
|
||||||
[ + ] 2map ;
|
|
||||||
|
|
||||||
: draw-snake-head ( loc facing-dir -- )
|
|
||||||
dup name>> rest "head-" prepend
|
|
||||||
[
|
|
||||||
[ screen-loc ] dip
|
|
||||||
{
|
|
||||||
{ :right [ { -20 -10 } ] }
|
|
||||||
{ :down [ { -10 -20 } ] }
|
|
||||||
{ :up [ { -10 0 } ] }
|
|
||||||
{ :left [ { 0 -10 } ] }
|
|
||||||
} case offset
|
|
||||||
] dip
|
|
||||||
swap draw-sprite* ;
|
|
||||||
|
|
||||||
: draw-snake-body ( loc from-dir to-dir -- )
|
|
||||||
2array [ name>> rest ] map "body" prefix "-" join
|
|
||||||
draw-sprite ;
|
|
||||||
|
|
||||||
: draw-snake-tail ( loc facing-dir -- )
|
|
||||||
name>> rest "tail-" prepend draw-sprite ;
|
|
||||||
|
|
||||||
: draw-snake-part ( loc from-dir snake-part -- )
|
|
||||||
dup type>> {
|
|
||||||
{ :head [ drop opposite-dir draw-snake-head ] }
|
|
||||||
{ :tail [ drop draw-snake-tail ] }
|
|
||||||
{ :body [ dir>> draw-snake-body ] }
|
|
||||||
} case ;
|
|
||||||
|
|
||||||
: ?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 ;
|
|
||||||
|
|
||||||
: draw-snake-reduce-step ( loc from-dir snake-part -- {new-loc,new-from-dir} )
|
|
||||||
nip dir>> [ relative-loc ] keep 2array ;
|
|
||||||
|
|
||||||
: draw-snake ( snake loc from-dir -- )
|
|
||||||
2array 2dup
|
|
||||||
[
|
|
||||||
[ first2 ] dip
|
|
||||||
[ draw-snake-part ] [ draw-snake-reduce-step ] 3bi
|
|
||||||
] reduce drop
|
|
||||||
! make sure to draw the head again
|
|
||||||
swap first [ first2 ] dip draw-snake-part ;
|
|
||||||
|
|
||||||
: grow-snake ( snake dir -- snake )
|
|
||||||
opposite-dir :head <snake-part> prefix
|
|
||||||
dup second :body >>type drop ;
|
|
||||||
|
|
||||||
: snake-shape ( snake -- dirs )
|
|
||||||
[ dir>> ] map ;
|
|
||||||
|
|
||||||
: move-snake ( snake dir -- snake )
|
|
||||||
dupd [ snake-shape but-last ] dip
|
|
||||||
opposite-dir prefix [ >>dir ] 2map ;
|
|
||||||
|
|
||||||
: update-snake-shape ( snake-game dir growing? -- )
|
|
||||||
[ [ grow-snake ] curry change-snake ]
|
|
||||||
[ [ move-snake ] curry change-snake ]
|
|
||||||
if drop ;
|
|
||||||
|
|
||||||
: update-snake-loc ( snake-game dir -- )
|
|
||||||
[ relative-loc ] curry change-snake-loc drop ;
|
|
||||||
|
|
||||||
: update-snake-dir ( snake-game dir -- )
|
|
||||||
>>snake-dir drop ;
|
|
||||||
|
|
||||||
: point>index ( loc -- n )
|
|
||||||
first2 [ ] [ snake-game-dim first * ] bi* + ;
|
|
||||||
|
|
||||||
: index>point ( n -- loc )
|
|
||||||
snake-game-dim first /mod swap 2array ;
|
|
||||||
|
|
||||||
: snake-occupied-locs ( snake head-loc -- points )
|
|
||||||
[ dir>> relative-loc ] accumulate nip ;
|
|
||||||
|
|
||||||
: snake-occupied-indices ( snake head-loc -- points )
|
|
||||||
snake-occupied-locs [ point>index ] map natural-sort ;
|
|
||||||
|
|
||||||
: all-indices ( -- points )
|
|
||||||
snake-game-dim first2 * iota ;
|
|
||||||
|
|
||||||
: snake-unoccupied-indices ( snake head-loc -- points )
|
|
||||||
[ all-indices ] 2dip snake-occupied-indices >hash-set without ;
|
|
||||||
|
|
||||||
: snake-will-eat-itself? ( snake-game dir -- ? )
|
|
||||||
[ [ snake>> ] [ snake-loc>> ] bi ] dip relative-loc
|
|
||||||
[ snake-occupied-locs rest ] keep
|
|
||||||
swap member? ;
|
|
||||||
|
|
||||||
: snake-will-eat-food? ( snake-game dir -- ? )
|
|
||||||
[ [ food-loc>> ] [ snake-loc>> ] bi ] dip
|
|
||||||
relative-loc = ;
|
|
||||||
|
|
||||||
: random-sample ( seq -- e )
|
|
||||||
1 sample first ;
|
|
||||||
|
|
||||||
: generate-food ( snake-game -- )
|
|
||||||
[
|
|
||||||
[ snake>> ] [ snake-loc>> ] bi
|
|
||||||
snake-unoccupied-indices random-sample index>point
|
|
||||||
] keep food-loc<< ;
|
|
||||||
|
|
||||||
: update-score ( snake-game -- )
|
|
||||||
[ 1 + ] change-score
|
|
||||||
drop ;
|
|
||||||
|
|
||||||
: update-snake ( snake-game dir -- )
|
|
||||||
2dup snake-will-eat-food?
|
|
||||||
{
|
|
||||||
[ [ drop update-score ] [ 2drop ] if ]
|
|
||||||
[ update-snake-shape ]
|
|
||||||
[ drop update-snake-loc ]
|
|
||||||
[ drop update-snake-dir ]
|
|
||||||
[ nip [ generate-food ] [ drop ] if ]
|
|
||||||
} 3cleave ;
|
|
||||||
|
|
||||||
: game-over ( snake-game -- )
|
|
||||||
t >>game-over? drop ;
|
|
||||||
|
|
||||||
: game-in-progress? ( snake-game -- ? )
|
|
||||||
[ game-over?>> ] [ paused?>> ] bi or not ;
|
|
||||||
|
|
||||||
: ?handle-pending-turn ( snake-game -- )
|
|
||||||
dup next-turn-dir>> [
|
|
||||||
>>snake-dir
|
|
||||||
f >>next-turn-dir
|
|
||||||
] when* drop ;
|
|
||||||
|
|
||||||
: do-game-step ( gadget -- )
|
|
||||||
dup game-in-progress? [
|
|
||||||
dup ?handle-pending-turn
|
|
||||||
dup snake-dir>>
|
|
||||||
2dup snake-will-eat-itself?
|
|
||||||
[ drop game-over ] [ update-snake ] if
|
|
||||||
] [ drop ] if ;
|
|
||||||
|
|
||||||
: generate-status-message ( snake-game -- str )
|
|
||||||
[ score>> "Score: %d" sprintf ]
|
|
||||||
[
|
|
||||||
{
|
|
||||||
{ [ dup game-over?>> ] [ drop "Game Over" ] }
|
|
||||||
{ [ dup paused?>> ] [ drop "Game Paused" ] }
|
|
||||||
[ drop "Game In Progress" ]
|
|
||||||
} cond
|
|
||||||
]
|
|
||||||
bi 2array " -- " join ;
|
|
||||||
|
|
||||||
: update-status ( gadget -- )
|
|
||||||
[ snake-game>> generate-status-message ] keep show-status ;
|
|
||||||
|
|
||||||
: do-updates ( gadget -- )
|
|
||||||
[ snake-game>> do-game-step ]
|
|
||||||
[ update-status ]
|
|
||||||
[ relayout-1 ]
|
|
||||||
tri ;
|
|
||||||
|
|
||||||
M: snake-gadget pref-dim*
|
|
||||||
drop snake-game-dim [ 20 * 20 + ] map ;
|
|
||||||
|
|
||||||
: load-sprite-image ( filename -- image )
|
|
||||||
[ snake-game vocabulary>> vocab-dir ] dip
|
|
||||||
"vocab:%s/%s" sprintf load-image ;
|
|
||||||
|
|
||||||
: make-texture ( image -- texture )
|
|
||||||
{ 0 0 } <texture> ;
|
|
||||||
|
|
||||||
: make-sprites ( filename cols rows -- seq )
|
|
||||||
[ load-sprite-image ] 2dip generate-sprite-sheet
|
|
||||||
[ make-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 ;
|
|
||||||
|
|
||||||
: 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 ;
|
|
||||||
|
|
||||||
: snake-tail-textures ( -- assoc )
|
|
||||||
"tail.png" 2 2 make-sprites
|
|
||||||
{ "tail-down" "tail-left" "tail-up" "tail-right" }
|
|
||||||
[ swap 2array ] 2map ;
|
|
||||||
|
|
||||||
: food-texture ( -- assoc )
|
|
||||||
"food" "food.png" load-sprite-image make-texture
|
|
||||||
2array 1array ;
|
|
||||||
|
|
||||||
: background-texture ( -- assoc )
|
|
||||||
"background" "background.png" load-sprite-image make-texture
|
|
||||||
2array 1array ;
|
|
||||||
|
|
||||||
: load-game-textures ( snake-gadget -- textures )
|
|
||||||
dup textures>> [ ] [
|
|
||||||
[
|
|
||||||
snake-head-textures %%
|
|
||||||
snake-body-textures %%
|
|
||||||
snake-tail-textures %%
|
|
||||||
food-texture %%
|
|
||||||
background-texture %%
|
|
||||||
] H{ } make >>textures
|
|
||||||
textures>>
|
|
||||||
] ?if ;
|
|
||||||
|
|
||||||
M: snake-gadget draw-gadget*
|
|
||||||
[ load-game-textures game-textures ] keep [
|
|
||||||
draw-background
|
|
||||||
{ 10 10 } [
|
|
||||||
snake-game>>
|
|
||||||
[ food-loc>> [ draw-food ] when* ]
|
|
||||||
[
|
|
||||||
[ snake>> ]
|
|
||||||
[ snake-loc>> ]
|
|
||||||
[ snake-dir>> opposite-dir ]
|
|
||||||
tri draw-snake
|
|
||||||
] bi
|
|
||||||
] with-translation
|
|
||||||
] curry with-variable ;
|
|
||||||
|
|
||||||
M: snake-gadget graft*
|
|
||||||
[ [ do-updates ] curry 200 milliseconds every ] keep timer<< ;
|
|
||||||
|
|
||||||
M: snake-gadget ungraft*
|
|
||||||
[ stop-timer f ] change-timer
|
|
||||||
dup textures>> values [ dispose ] each
|
|
||||||
f >>textures 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
|
|
||||||
[
|
|
||||||
2dup [ snake-dir>> opposite-dir ] dip =
|
|
||||||
[ 2drop ] [ >>next-turn-dir drop ] if
|
|
||||||
] [ drop ] if* ;
|
|
||||||
|
|
||||||
: toggle-game-pause ( snake-gadget -- )
|
|
||||||
snake-game>> [ not ] change-paused? drop ;
|
|
||||||
|
|
||||||
: handle-key ( snake-gadget key -- )
|
|
||||||
{
|
|
||||||
{ [ dup quit-key? ] [ drop close-window ] }
|
|
||||||
{ [ dup pause-key? ] [ drop toggle-game-pause ] }
|
|
||||||
{ [ dup new-game-key? ] [ drop start-new-game ] }
|
|
||||||
[
|
|
||||||
[ snake-game>> ] dip over
|
|
||||||
game-in-progress? [ ?handle-movement-key ] [ 2drop ] if
|
|
||||||
]
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
M: snake-gadget handle-gesture
|
|
||||||
swap dup key-down?
|
|
||||||
[ sym>> handle-key ] [ 2drop ] if f ;
|
|
||||||
|
|
||||||
: <snake-world-attributes> ( -- world-attributes )
|
: <snake-world-attributes> ( -- world-attributes )
|
||||||
<world-attributes> "Snake Game" >>title
|
<world-attributes> "Snake Game" >>title
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,73 @@
|
||||||
|
! Copyright (C) 2015 Your name.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs byte-vectors formatting fry
|
||||||
|
images images.loader kernel locals make math math.vectors
|
||||||
|
opengl.textures sequences ;
|
||||||
|
|
||||||
|
IN: snake-game.sprites
|
||||||
|
|
||||||
|
: new-image-like ( image w h -- image )
|
||||||
|
[ clone ] 2dip
|
||||||
|
[ 2array >>dim ] 2keep *
|
||||||
|
over bytes-per-pixel * <byte-vector> >>bitmap ;
|
||||||
|
|
||||||
|
:: image-part ( image x y w h -- image )
|
||||||
|
image w h new-image-like :> new-image
|
||||||
|
h iota [| i |
|
||||||
|
new-image bitmap>>
|
||||||
|
x y i + w image pixel-row-slice-at
|
||||||
|
append! drop
|
||||||
|
] each new-image ;
|
||||||
|
|
||||||
|
:: generate-sprite-sheet ( image rows cols -- seq )
|
||||||
|
cols rows 2array :> split-dims
|
||||||
|
image dim>> split-dims [ / ] 2map first2 :> ( sw sh )
|
||||||
|
rows iota sh v*n :> ys
|
||||||
|
cols iota sh v*n :> xs
|
||||||
|
ys xs [
|
||||||
|
swap [ image ] 2dip sw sh image-part
|
||||||
|
] cartesian-map f join ;
|
||||||
|
|
||||||
|
: load-sprite-image ( filename -- image )
|
||||||
|
"vocab:snake-game/_resources/%s" sprintf load-image ;
|
||||||
|
|
||||||
|
: make-texture ( image -- texture )
|
||||||
|
{ 0 0 } <texture> ;
|
||||||
|
|
||||||
|
: make-sprites ( filename cols rows -- seq )
|
||||||
|
[ load-sprite-image ] 2dip generate-sprite-sheet
|
||||||
|
[ make-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 ;
|
||||||
|
|
||||||
|
: 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 ;
|
||||||
|
|
||||||
|
: snake-tail-textures ( -- assoc )
|
||||||
|
"tail.png" 2 2 make-sprites
|
||||||
|
{ "tail-down" "tail-left" "tail-up" "tail-right" }
|
||||||
|
[ swap 2array ] 2map ;
|
||||||
|
|
||||||
|
: food-texture ( -- assoc )
|
||||||
|
"food" "food.png" load-sprite-image make-texture
|
||||||
|
2array 1array ;
|
||||||
|
|
||||||
|
: background-texture ( -- assoc )
|
||||||
|
"background" "background.png" load-sprite-image make-texture
|
||||||
|
2array 1array ;
|
||||||
|
|
@ -0,0 +1,159 @@
|
||||||
|
! Copyright (C) 2015 Your name.
|
||||||
|
! 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 ;
|
||||||
|
|
||||||
|
IN: snake-game.ui
|
||||||
|
|
||||||
|
SYMBOL: game-textures
|
||||||
|
|
||||||
|
TUPLE: snake-gadget < gadget
|
||||||
|
snake-game timer textures ;
|
||||||
|
|
||||||
|
: start-new-game ( snake-gadget -- )
|
||||||
|
<snake-game> >>snake-game drop ;
|
||||||
|
|
||||||
|
: <snake-gadget> ( -- snake-gadget )
|
||||||
|
snake-gadget new
|
||||||
|
[ start-new-game ] keep ;
|
||||||
|
|
||||||
|
: lookup-texture ( key -- texture )
|
||||||
|
game-textures get at ;
|
||||||
|
|
||||||
|
: draw-sprite* ( key screen-loc -- )
|
||||||
|
[ lookup-texture draw-texture ] with-translation ;
|
||||||
|
|
||||||
|
: draw-sprite ( grid-loc key -- )
|
||||||
|
swap screen-loc draw-sprite* ;
|
||||||
|
|
||||||
|
: draw-food ( loc -- )
|
||||||
|
"food" draw-sprite ;
|
||||||
|
|
||||||
|
: draw-background ( -- )
|
||||||
|
{ 0 0 } "background" draw-sprite ;
|
||||||
|
|
||||||
|
: draw-snake-head ( loc facing-dir -- )
|
||||||
|
dup name>> rest "head-" prepend
|
||||||
|
[
|
||||||
|
[ screen-loc ] dip
|
||||||
|
{
|
||||||
|
{ :right [ { -20 -10 } ] }
|
||||||
|
{ :down [ { -10 -20 } ] }
|
||||||
|
{ :up [ { -10 0 } ] }
|
||||||
|
{ :left [ { 0 -10 } ] }
|
||||||
|
} case offset
|
||||||
|
] dip
|
||||||
|
swap draw-sprite* ;
|
||||||
|
|
||||||
|
: draw-snake-body ( loc from-dir to-dir -- )
|
||||||
|
[ name>> rest ] bi@ "body-%s-%s" sprintf draw-sprite ;
|
||||||
|
|
||||||
|
: draw-snake-tail ( loc facing-dir -- )
|
||||||
|
name>> rest "tail-" prepend draw-sprite ;
|
||||||
|
|
||||||
|
: draw-snake-part ( loc from-dir snake-part -- )
|
||||||
|
dup type>> {
|
||||||
|
{ :head [ drop opposite-dir draw-snake-head ] }
|
||||||
|
{ :body [ dir>> draw-snake-body ] }
|
||||||
|
{ :tail [ drop draw-snake-tail ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: next-snake-loc-from-dir ( loc from-dir snake-part -- new-loc new-from-dir )
|
||||||
|
nip dir>> [ relative-loc ] keep ;
|
||||||
|
|
||||||
|
: draw-snake ( loc from-dir snake -- )
|
||||||
|
3dup [
|
||||||
|
[ draw-snake-part ]
|
||||||
|
[ next-snake-loc-from-dir ] 3bi
|
||||||
|
] each 2drop
|
||||||
|
! make sure to draw the head again
|
||||||
|
first draw-snake-part ;
|
||||||
|
|
||||||
|
: generate-status-message ( snake-game -- str )
|
||||||
|
[ score>> "Score: %d" sprintf ]
|
||||||
|
[
|
||||||
|
{
|
||||||
|
{ [ dup game-over?>> ] [ drop "Game Over" ] }
|
||||||
|
{ [ dup paused?>> ] [ drop "Game Paused" ] }
|
||||||
|
[ drop "Game In Progress" ]
|
||||||
|
} cond
|
||||||
|
]
|
||||||
|
bi 2array " -- " join ;
|
||||||
|
|
||||||
|
: update-status ( gadget -- )
|
||||||
|
[ snake-game>> generate-status-message ] keep show-status ;
|
||||||
|
|
||||||
|
: do-updates ( gadget -- )
|
||||||
|
[ snake-game>> do-game-step ]
|
||||||
|
[ update-status ]
|
||||||
|
[ relayout-1 ]
|
||||||
|
tri ;
|
||||||
|
|
||||||
|
: toggle-game-pause ( snake-gadget -- )
|
||||||
|
snake-game>> [ not ] change-paused? drop ;
|
||||||
|
|
||||||
|
: ?handle-movement-key ( snake-game key -- )
|
||||||
|
key-action
|
||||||
|
[
|
||||||
|
2dup [ snake-dir>> opposite-dir ] dip =
|
||||||
|
[ 2drop ] [ >>next-turn-dir drop ] if
|
||||||
|
] [ drop ] if* ;
|
||||||
|
|
||||||
|
: handle-key ( snake-gadget key -- )
|
||||||
|
{
|
||||||
|
{ [ dup quit-key? ] [ drop close-window ] }
|
||||||
|
{ [ dup pause-key? ] [ drop toggle-game-pause ] }
|
||||||
|
{ [ dup new-game-key? ] [ drop start-new-game ] }
|
||||||
|
[
|
||||||
|
[ snake-game>> ] dip over
|
||||||
|
game-in-progress? [ ?handle-movement-key ] [ 2drop ] if
|
||||||
|
]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: load-game-textures ( snake-gadget -- textures )
|
||||||
|
dup textures>> [ ] [
|
||||||
|
[
|
||||||
|
snake-head-textures %%
|
||||||
|
snake-body-textures %%
|
||||||
|
snake-tail-textures %%
|
||||||
|
food-texture %%
|
||||||
|
background-texture %%
|
||||||
|
] H{ } make >>textures
|
||||||
|
textures>>
|
||||||
|
] ?if ;
|
||||||
|
|
||||||
|
M: snake-gadget graft*
|
||||||
|
[ [ do-updates ] curry 200 milliseconds every ] keep timer<< ;
|
||||||
|
|
||||||
|
M: snake-gadget ungraft*
|
||||||
|
[ stop-timer f ] change-timer
|
||||||
|
dup textures>> values [ dispose ] each
|
||||||
|
f >>textures drop ;
|
||||||
|
|
||||||
|
M: snake-gadget pref-dim*
|
||||||
|
drop snake-game-dim [ snake-game-cell-size * 20 + ] map ;
|
||||||
|
|
||||||
|
M: snake-gadget draw-gadget*
|
||||||
|
[ load-game-textures game-textures ] keep [
|
||||||
|
draw-background
|
||||||
|
{ 10 10 } [
|
||||||
|
snake-game>>
|
||||||
|
[ food-loc>> [ draw-food ] when* ]
|
||||||
|
[
|
||||||
|
[ snake-loc>> ]
|
||||||
|
[ snake-dir>> opposite-dir ]
|
||||||
|
[ snake>> ]
|
||||||
|
tri draw-snake
|
||||||
|
] bi
|
||||||
|
] with-translation
|
||||||
|
] curry with-variable ;
|
||||||
|
|
||||||
|
M: snake-gadget handle-gesture
|
||||||
|
swap dup key-down?
|
||||||
|
[ sym>> handle-key ] [ 2drop ] if f ;
|
||||||
|
|
@ -0,0 +1,45 @@
|
||||||
|
! Copyright (C) 2015 Your name.
|
||||||
|
! 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 ;
|
||||||
Loading…
Reference in New Issue