steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

snake-game: some cleanup.

factor-shell
John Benediktsson 2018-01-19 12:16:05 -08:00
parent b0b9524fcf
commit e0a93a6ea8
7 changed files with 119 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
extra/snake-game/constants/constants.factor
View File

@ -1,11 +0,0 @@
! 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

107
extra/snake-game/game/game.factor
View File

@ -1,10 +1,16 @@
! 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 combinators kernel make math random USING: accessors arrays assocs combinators fry kernel make math
sequences sets snake-game.constants snake-game.util sorting ; math.vectors random sequences sets sorting ;
IN: snake-game.game IN: snake-game.game
SYMBOLS: :left :right :up :down ;
SYMBOLS: :head :body :tail ;
CONSTANT: snake-game-dim { 12 10 }
TUPLE: snake-game TUPLE: snake-game
snake snake-loc snake-dir food-loc snake snake-loc snake-dir food-loc
{ next-turn-dir initial: f } { next-turn-dir initial: f }
@ -26,10 +32,33 @@ C: <snake-part> snake-part
: <snake-game> ( -- snake-game ) : <snake-game> ( -- snake-game )
snake-game new snake-game new
<snake> >>snake <snake> >>snake
{ 5 4 } clone >>snake-loc { 5 4 } clone >>snake-loc
:right >>snake-dir :right >>snake-dir
{ 1 1 } clone >>food-loc ; { 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 ) : game-loc>index ( loc -- n )
first2 snake-game-dim first * + ; first2 snake-game-dim first * + ;
@ -37,22 +66,19 @@ C: <snake-part> snake-part
: index>game-loc ( n -- loc ) : index>game-loc ( n -- loc )
snake-game-dim first /mod swap 2array ; snake-game-dim first /mod swap 2array ;
: snake-shape ( snake -- dirs )
[ dir>> ] map ;
: grow-snake ( snake dir -- snake ) : grow-snake ( snake dir -- snake )
opposite-dir :head <snake-part> prefix opposite-dir :head <snake-part> prefix
dup second :body >>type drop ; dup second :body >>type drop ;
: move-snake ( snake dir -- snake ) : move-snake ( snake dir -- snake )
dupd [ snake-shape but-last ] dip [ dup but-last [ dir>> ] map ] dip
opposite-dir prefix [ >>dir ] 2map ; opposite-dir prefix [ >>dir ] 2map ;
: all-indices ( -- points ) : all-indices ( -- points )
snake-game-dim first2 * <iota> ; snake-game-dim product <iota> ;
: snake-occupied-locs ( snake head-loc -- points ) : 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-indices ( snake head-loc -- points )
snake-occupied-locs [ game-loc>index ] map natural-sort ; snake-occupied-locs [ game-loc>index ] map natural-sort ;
@ -60,30 +86,23 @@ C: <snake-part> snake-part
: snake-unoccupied-indices ( snake head-loc -- points ) : snake-unoccupied-indices ( snake head-loc -- points )
[ all-indices ] 2dip snake-occupied-indices without ; [ all-indices ] 2dip snake-occupied-indices without ;
: snake-will-eat-food? ( snake-game dir -- ? ) : snake-will-eat-food? ( snake-game -- ? )
[ [ food-loc>> ] [ snake-loc>> ] bi ] dip [ food-loc>> ] [ snake-loc>> ] [ snake-dir>> ] tri move-loc = ;
relative-loc = ;
: update-score ( snake-game -- ) : increase-score ( snake-game -- snake-game )
[ 1 + ] change-score [ 1 + ] change-score ;
drop ;
: update-snake-shape ( snake-game dir growing? -- ) : update-snake-shape ( snake-game growing? -- snake-game )
[ [ grow-snake ] curry change-snake ] [ dup snake-dir>> ] dip
[ [ move-snake ] curry change-snake ] '[ _ _ [ grow-snake ] [ move-snake ] if ] change-snake ;
if drop ;
: update-snake-loc ( snake-game dir -- ) : update-snake-loc ( snake-game -- snake-game )
[ relative-loc ] curry change-snake-loc drop ; dup snake-dir>> '[ _ move-loc ] change-snake-loc ;
: update-snake-dir ( snake-game dir -- ) : generate-food ( snake-game -- snake-game )
>>snake-dir drop ; dup [ snake>> ] [ snake-loc>> ] bi
snake-unoccupied-indices random index>game-loc
: generate-food ( snake-game -- ) >>food-loc ;
[
[ snake>> ] [ snake-loc>> ] bi
snake-unoccupied-indices random index>game-loc
] keep food-loc<< ;
: game-in-progress? ( snake-game -- ? ) : game-in-progress? ( snake-game -- ? )
[ game-over?>> ] [ paused?>> ] bi or not ; [ game-over?>> ] [ paused?>> ] bi or not ;
@ -94,28 +113,24 @@ C: <snake-part> snake-part
f >>next-turn-dir f >>next-turn-dir
] when* drop ; ] when* drop ;
: snake-will-eat-itself? ( snake-game dir -- ? ) : snake-will-eat-itself? ( snake-game -- ? )
[ [ snake>> ] [ snake-loc>> ] bi ] dip relative-loc [ snake>> ] [ snake-loc>> ] [ snake-dir>> ] tri move-loc
[ snake-occupied-locs rest ] keep [ snake-occupied-locs rest ] keep swap member? ;
swap member? ;
: game-over ( snake-game -- ) : game-over ( snake-game -- )
t >>game-over? drop ; t >>game-over? drop ;
: update-snake ( snake-game dir -- ) : update-snake ( snake-game -- )
2dup snake-will-eat-food? dup snake-will-eat-food? {
{ [ [ increase-score ] when ]
[ [ drop update-score ] [ 2drop ] if ]
[ update-snake-shape ] [ update-snake-shape ]
[ drop update-snake-loc ] [ drop update-snake-loc ]
[ drop update-snake-dir ] [ [ generate-food ] when ]
[ nip [ generate-food ] [ drop ] if ] } cleave drop ;
} 3cleave ;
: do-game-step ( snake-game -- ) : do-game-step ( snake-game -- )
dup game-in-progress? [ dup game-in-progress? [
dup ?handle-pending-turn dup ?handle-pending-turn
dup snake-dir>> dup snake-will-eat-itself?
2dup snake-will-eat-itself? [ game-over ] [ update-snake ] if
[ drop game-over ] [ update-snake ] if
] [ drop ] if ; ] [ drop ] if ;

21
extra/snake-game/input/input.factor
View File

@ -1,21 +0,0 @@
! 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? ;

47
extra/snake-game/sprites/sprites.factor
View File

@ -28,46 +28,37 @@ IN: snake-game.sprites
swap [ image ] 2dip sw sh image-part swap [ image ] 2dip sw sh image-part
] cartesian-map f join ; ] cartesian-map f join ;
: load-sprite-image ( filename -- image ) : load-snake-image ( filename -- image )
"vocab:snake-game/_resources/%s" sprintf load-image ; "vocab:snake-game/_resources/%s" sprintf load-image ;
: make-texture ( image -- texture ) : load-snake-texture ( file-name -- texture )
{ 0 0 } <texture> ; load-snake-image { 0 0 } <texture> ;
: make-sprites ( filename cols rows -- seq ) : load-sprite-textures ( filename cols rows -- seq )
[ load-sprite-image ] 2dip generate-sprite-sheet [ load-snake-image ] 2dip generate-sprite-sheet
[ make-texture ] map ; [ { 0 0 } <texture> ] map ;
: snake-head-textures ( -- assoc ) : snake-head-textures ( -- assoc )
"head.png" 1 4 make-sprites
{ "head-up" "head-right" "head-down" "head-left" } { "head-up" "head-right" "head-down" "head-left" }
[ swap 2array ] 2map ; "head.png" 1 4 load-sprite-textures zip ;
:: assoc-with-value-like ( assoc key seq -- )
key assoc at :> value
seq [ [ value ] dip assoc set-at ] each ;
: snake-body-textures ( -- assoc ) : snake-body-textures ( -- assoc )
"body.png" 3 2 make-sprites {
{ 1 2 3 4 5 6 } "body-right-up" "body-down-right" "body-right-right"
[ swap 2array ] 2map "body-up-up" "body-up-right" "body-right-down"
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 "body-down-left" "body-left-up" "body-left-left"
dup 4 { "body-up-up" "body-down-down" } assoc-with-value-like "body-down-down" "body-left-down" "body-up-left"
dup 5 { "body-up-right" "body-left-down" } assoc-with-value-like }
dup 6 { "body-right-down" "body-up-left" } assoc-with-value-like "body.png" 3 2 load-sprite-textures '[ _ zip ] bi@ append ;
dup [ { 1 2 3 4 5 6 } ] dip [ delete-at ] curry each ;
: snake-tail-textures ( -- assoc ) : snake-tail-textures ( -- assoc )
"tail.png" 2 2 make-sprites
{ "tail-down" "tail-left" "tail-up" "tail-right" } { "tail-down" "tail-left" "tail-up" "tail-right" }
[ swap 2array ] 2map ; "tail.png" 2 2 load-sprite-textures zip ;
: food-texture ( -- assoc ) : food-texture ( -- assoc )
"food" "food.png" load-sprite-image make-texture "food" "food.png" load-snake-texture 2array 1array ;
2array 1array ;
: background-texture ( -- assoc ) : background-texture ( -- assoc )
"background" "background.png" load-sprite-image make-texture "background" "background.png" load-snake-texture 2array 1array ;
2array 1array ;

59
extra/snake-game/ui/ui.factor
View File

@ -1,13 +1,10 @@
! 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 arrays assocs calendar combinators destructors
formatting kernel make math namespaces opengl opengl.textures formatting kernel make math math.vectors namespaces opengl
sequences sets snake-game.constants snake-game.game opengl.textures sequences sets snake-game.game
snake-game.input snake-game.util snake-game.sprites timers snake-game.sprites timers ui ui.gadgets ui.gadgets.worlds
ui ui.gadgets ui.gadgets.worlds ui.gestures ui.render ; ui.gestures ui.render ;
FROM: snake-game.util => screen-loc ;
FROM: snake-game.util => relative-loc ;
IN: snake-game.ui IN: snake-game.ui
@ -20,8 +17,12 @@ TUPLE: snake-gadget < gadget
<snake-game> >>snake-game drop ; <snake-game> >>snake-game drop ;
: <snake-gadget> ( -- snake-gadget ) : <snake-gadget> ( -- snake-gadget )
snake-gadget new snake-gadget new [ start-new-game ] keep ;
[ 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 ) : lookup-texture ( key -- texture )
game-textures get at ; game-textures get at ;
@ -30,7 +31,7 @@ TUPLE: snake-gadget < gadget
[ lookup-texture draw-texture ] with-translation ; [ lookup-texture draw-texture ] with-translation ;
: draw-sprite ( grid-loc key -- ) : draw-sprite ( grid-loc key -- )
swap screen-loc draw-sprite* ; swap game-loc>screen-loc draw-sprite* ;
: draw-food ( loc -- ) : draw-food ( loc -- )
"food" draw-sprite ; "food" draw-sprite ;
@ -39,17 +40,15 @@ TUPLE: snake-gadget < gadget
{ 0 0 } "background" draw-sprite ; { 0 0 } "background" draw-sprite ;
: draw-snake-head ( loc facing-dir -- ) : draw-snake-head ( loc facing-dir -- )
dup name>> rest "head-" prepend dup name>> rest "head-" prepend [
[ [ game-loc>screen-loc ] dip
[ screen-loc ] dip
{ {
{ :right [ { -20 -10 } ] } { :right [ { -20 -10 } ] }
{ :down [ { -10 -20 } ] } { :down [ { -10 -20 } ] }
{ :up [ { -10 0 } ] } { :up [ { -10 0 } ] }
{ :left [ { 0 -10 } ] } { :left [ { 0 -10 } ] }
} case offset } case v+
] dip ] dip swap draw-sprite* ;
swap draw-sprite* ;
: draw-snake-body ( loc from-dir to-dir -- ) : draw-snake-body ( loc from-dir to-dir -- )
[ name>> rest ] bi@ "body-%s-%s" sprintf draw-sprite ; [ name>> rest ] bi@ "body-%s-%s" sprintf draw-sprite ;
@ -65,7 +64,7 @@ TUPLE: snake-gadget < gadget
} case ; } case ;
: next-snake-loc-from-dir ( loc from-dir snake-part -- new-loc new-from-dir ) : 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 -- ) : draw-snake ( loc from-dir snake -- )
3dup [ 3dup [
@ -76,15 +75,14 @@ TUPLE: snake-gadget < gadget
first draw-snake-part ; first draw-snake-part ;
: generate-status-message ( snake-game -- str ) : generate-status-message ( snake-game -- str )
[ score>> "Score: %d" sprintf ] [ score>> ]
[ [
{ {
{ [ dup game-over?>> ] [ drop "Game Over" ] } { [ dup game-over?>> ] [ drop "Game Over" ] }
{ [ dup paused?>> ] [ drop "Game Paused" ] } { [ dup paused?>> ] [ drop "Game Paused" ] }
[ drop "Game In Progress" ] [ drop "Game In Progress" ]
} cond } cond
] ] bi "Score: %d -- %s" sprintf ;
bi 2array " -- " join ;
: update-status ( gadget -- ) : update-status ( gadget -- )
[ snake-game>> generate-status-message ] keep show-status ; [ snake-game>> generate-status-message ] keep show-status ;
@ -98,6 +96,23 @@ TUPLE: snake-gadget < gadget
: toggle-game-pause ( snake-gadget -- ) : toggle-game-pause ( snake-gadget -- )
snake-game>> [ not ] change-paused? drop ; 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 -- ) : ?handle-movement-key ( snake-game key -- )
key-action key-action
[ [
@ -133,8 +148,8 @@ M: snake-gadget graft*
M: snake-gadget ungraft* M: snake-gadget ungraft*
[ stop-timer f ] change-timer [ stop-timer f ] change-timer
dup textures>> values [ dispose ] each [ values dispose-each f ] change-textures
f >>textures drop ; drop ;
M: snake-gadget pref-dim* M: snake-gadget pref-dim*
drop snake-game-dim [ snake-game-cell-size * 20 + ] map ; drop snake-game-dim [ snake-game-cell-size * 20 + ] map ;

45
extra/snake-game/util/util.factor
View File

@ -1,45 +0,0 @@
! 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 ;