From bb43e27b860c8c8a9a14fdbf19696be3bb5ecf86 Mon Sep 17 00:00:00 2001 From: Sankaranarayanan Viswanathan Date: Wed, 2 Dec 2015 13:36:48 +0530 Subject: [PATCH] snake-game: refactor and restruture --- .../{ => _resources}/background.png | Bin extra/snake-game/{ => _resources}/body.png | Bin extra/snake-game/{ => _resources}/food.png | Bin extra/snake-game/{ => _resources}/head.png | Bin extra/snake-game/{ => _resources}/tail.png | Bin extra/snake-game/constants/constants.factor | 11 + extra/snake-game/game/game.factor | 121 ++++++ extra/snake-game/helper/helper.factor | 28 -- extra/snake-game/input/input.factor | 21 + extra/snake-game/snake-game.factor | 382 +----------------- extra/snake-game/sprites/sprites.factor | 73 ++++ extra/snake-game/ui/ui.factor | 159 ++++++++ extra/snake-game/util/util.factor | 45 +++ 13 files changed, 431 insertions(+), 409 deletions(-) rename extra/snake-game/{ => _resources}/background.png (100%) rename extra/snake-game/{ => _resources}/body.png (100%) rename extra/snake-game/{ => _resources}/food.png (100%) rename extra/snake-game/{ => _resources}/head.png (100%) rename extra/snake-game/{ => _resources}/tail.png (100%) create mode 100644 extra/snake-game/constants/constants.factor create mode 100644 extra/snake-game/game/game.factor delete mode 100644 extra/snake-game/helper/helper.factor create mode 100644 extra/snake-game/input/input.factor create mode 100644 extra/snake-game/sprites/sprites.factor create mode 100644 extra/snake-game/ui/ui.factor create mode 100644 extra/snake-game/util/util.factor diff --git a/extra/snake-game/background.png b/extra/snake-game/_resources/background.png similarity index 100% rename from extra/snake-game/background.png rename to extra/snake-game/_resources/background.png diff --git a/extra/snake-game/body.png b/extra/snake-game/_resources/body.png similarity index 100% rename from extra/snake-game/body.png rename to extra/snake-game/_resources/body.png diff --git a/extra/snake-game/food.png b/extra/snake-game/_resources/food.png similarity index 100% rename from extra/snake-game/food.png rename to extra/snake-game/_resources/food.png diff --git a/extra/snake-game/head.png b/extra/snake-game/_resources/head.png similarity index 100% rename from extra/snake-game/head.png rename to extra/snake-game/_resources/head.png diff --git a/extra/snake-game/tail.png b/extra/snake-game/_resources/tail.png similarity index 100% rename from extra/snake-game/tail.png rename to extra/snake-game/_resources/tail.png diff --git a/extra/snake-game/constants/constants.factor b/extra/snake-game/constants/constants.factor new file mode 100644 index 0000000000..b6f6c59c13 --- /dev/null +++ b/extra/snake-game/constants/constants.factor @@ -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 diff --git a/extra/snake-game/game/game.factor b/extra/snake-game/game/game.factor new file mode 100644 index 0000000000..0a0b4dcfa3 --- /dev/null +++ b/extra/snake-game/game/game.factor @@ -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 ) + [ + :left :head , + :left :body , + :left :tail , + ] V{ } make ; + +: ( -- snake-game ) + snake-game new + >>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 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 ; diff --git a/extra/snake-game/helper/helper.factor b/extra/snake-game/helper/helper.factor deleted file mode 100644 index ebb7dc880f..0000000000 --- a/extra/snake-game/helper/helper.factor +++ /dev/null @@ -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 * >>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 ; diff --git a/extra/snake-game/input/input.factor b/extra/snake-game/input/input.factor new file mode 100644 index 0000000000..8f47e2d379 --- /dev/null +++ b/extra/snake-game/input/input.factor @@ -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? ; diff --git a/extra/snake-game/snake-game.factor b/extra/snake-game/snake-game.factor index 7431f12535..39fca95b6e 100644 --- a/extra/snake-game/snake-game.factor +++ b/extra/snake-game/snake-game.factor @@ -1,388 +1,8 @@ ! Copyright (C) 2015 Sankaranarayanan Viswanathan ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs calendar combinators destructors -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 ; - +USING: accessors sets snake-game.ui ui ui.gadgets.status-bar ui.gadgets.worlds ; 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 ; - -: ( dir type -- snake-part ) - snake-part boa ; - -: ( -- snake ) - [ - :left :head , - :left :body , - :left :tail , - ] V{ } make ; - -: ( -- snake-game ) - snake-game new - >>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 drop ; - -: ( -- 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 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 } ; - -: 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 ; - : ( -- world-attributes ) "Snake Game" >>title [ diff --git a/extra/snake-game/sprites/sprites.factor b/extra/snake-game/sprites/sprites.factor new file mode 100644 index 0000000000..dec02e78ea --- /dev/null +++ b/extra/snake-game/sprites/sprites.factor @@ -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 * >>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 } ; + +: 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 ; diff --git a/extra/snake-game/ui/ui.factor b/extra/snake-game/ui/ui.factor new file mode 100644 index 0000000000..610c744125 --- /dev/null +++ b/extra/snake-game/ui/ui.factor @@ -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 drop ; + +: ( -- 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 ; diff --git a/extra/snake-game/util/util.factor b/extra/snake-game/util/util.factor new file mode 100644 index 0000000000..8aec411845 --- /dev/null +++ b/extra/snake-game/util/util.factor @@ -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 ;