extra/snake-game/ui/ui.factor

   1 ! Copyright (C) 2015 Sankaranarayanan Viswanathan.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar combinators destructors
   4 formatting kernel make math math.vectors namespaces opengl
   5 opengl.textures sequences sets snake-game.game
   6 snake-game.sprites timers ui ui.gadgets ui.gadgets.worlds
   7 ui.gestures ui.render ;
   8
   9 IN: snake-game.ui
  10
  11 SYMBOL: game-textures
  12
  13 TUPLE: snake-gadget < gadget
  14     snake-game timer textures ;
  15
  16 : start-new-game ( snake-gadget -- )
  17     <snake-game> >>snake-game drop ;
  18
  19 : <snake-gadget> ( -- snake-gadget )
  20     snake-gadget new [ start-new-game ] keep ;
  21
  22 CONSTANT: snake-game-cell-size 20
  23
  24 : game-loc>screen-loc ( loc -- loc )
  25     [ snake-game-cell-size * ] map ;
  26
  27 : lookup-texture ( key -- texture )
  28     game-textures get at ;
  29
  30 : draw-sprite* ( key screen-loc -- )
  31     [ lookup-texture draw-texture ] with-translation ;
  32
  33 : draw-sprite ( grid-loc key -- )
  34     swap game-loc>screen-loc draw-sprite* ;
  35
  36 : draw-food ( loc -- )
  37     "food" draw-sprite ;
  38
  39 : draw-background ( -- )
  40     { 0 0 } "background" draw-sprite ;
  41
  42 : draw-snake-head ( loc facing-dir -- )
  43     dup name>> rest "head-" prepend [
  44         [ game-loc>screen-loc ] dip
  45         {
  46             { :right [ { -20 -10 } ] }
  47             { :down  [ { -10 -20 } ] }
  48             { :up    [ { -10  0  } ] }
  49             { :left  [ {  0  -10 } ] }
  50         } case v+
  51     ] dip swap draw-sprite* ;
  52
  53 : draw-snake-body ( loc from-dir to-dir -- )
  54     [ name>> rest ] bi@ "body-%s-%s" sprintf draw-sprite ;
  55
  56 : draw-snake-tail ( loc facing-dir -- )
  57     name>> rest "tail-" prepend draw-sprite ;
  58
  59 : draw-snake-part ( loc from-dir snake-part -- )
  60     dup type>> {
  61         { :head [ drop opposite-dir draw-snake-head ] }
  62         { :body [ dir>> draw-snake-body ] }
  63         { :tail [ drop draw-snake-tail ] }
  64     } case ;
  65
  66 : next-snake-loc-from-dir ( loc from-dir snake-part -- new-loc new-from-dir )
  67     nip dir>> [ move-loc ] keep ;
  68
  69 : draw-snake ( loc from-dir snake -- )
  70     3dup [
  71         [ draw-snake-part ]
  72         [ next-snake-loc-from-dir ] 3bi
  73     ] each 2drop
  74     ! make sure to draw the head again
  75     first draw-snake-part ;
  76
  77 : generate-status-message ( snake-game -- str )
  78     [ score>> ]
  79     [
  80         {
  81             { [ dup game-over?>> ] [ drop "Game Over" ] }
  82             { [ dup paused?>> ] [ drop "Game Paused" ] }
  83             [ drop "Game In Progress" ]
  84         } cond
  85     ] bi "Score: %d -- %s" sprintf ;
  86
  87 : update-status ( gadget -- )
  88     [ snake-game>> generate-status-message ] keep show-status ;
  89
  90 : do-updates ( gadget -- )
  91     [ snake-game>> do-game-step ]
  92     [ update-status ]
  93     [ relayout-1 ]
  94     tri ;
  95
  96 : toggle-game-pause ( snake-gadget -- )
  97     snake-game>> [ not ] change-paused? drop ;
  98
  99 : key-action ( key -- action )
 100     H{
 101         { "RIGHT"  :right }
 102         { "LEFT"   :left }
 103         { "UP"     :up }
 104         { "DOWN"   :down }
 105     } at ;
 106
 107 : quit-key? ( key -- ? )
 108     HS{ "ESC" "q" "Q" } in? ;
 109
 110 : pause-key? ( key -- ? )
 111     HS{ " " "SPACE" "p" "P" } in? ;
 112
 113 : new-game-key? ( key -- ? )
 114     HS{ "ENTER" "RET" "n" "N" } in? ;
 115
 116 : ?handle-movement-key ( snake-game key -- )
 117     key-action
 118     [
 119         2dup [ snake-dir>> opposite-dir ] dip =
 120         [ 2drop ] [ >>next-turn-dir drop ] if
 121     ] [ drop ] if* ;
 122
 123 : handle-key ( snake-gadget key -- )
 124     {
 125         { [ dup quit-key? ] [ drop close-window ] }
 126         { [ dup pause-key? ] [ drop toggle-game-pause ] }
 127         { [ dup new-game-key? ] [ drop start-new-game ] }
 128         [
 129             [ snake-game>> ] dip over
 130             game-in-progress? [ ?handle-movement-key ] [ 2drop ] if
 131         ]
 132     } cond ;
 133
 134 : load-game-textures ( snake-gadget -- textures )
 135     dup textures>> [ ] [
 136         [
 137             snake-head-textures %%
 138             snake-body-textures %%
 139             snake-tail-textures %%
 140             food-texture %%
 141             background-texture %%
 142         ] H{ } make >>textures
 143         textures>>
 144     ] ?if ;
 145
 146 M: snake-gadget graft*
 147     [ [ do-updates ] curry 200 milliseconds every ] keep timer<< ;
 148
 149 M: snake-gadget ungraft*
 150     [ stop-timer f ] change-timer
 151     [ values dispose-each f ] change-textures
 152     drop ;
 153
 154 M: snake-gadget pref-dim*
 155     drop snake-game-dim [ snake-game-cell-size * 20 + ] map ;
 156
 157 M: snake-gadget draw-gadget*
 158     [ load-game-textures game-textures ] keep [
 159         draw-background
 160         { 10 10 } [
 161             snake-game>>
 162             [ food-loc>> [ draw-food ] when* ]
 163             [
 164                 [ snake-loc>> ]
 165                 [ snake-dir>> opposite-dir ]
 166                 [ snake>> ]
 167                 tri draw-snake
 168             ] bi
 169         ] with-translation
 170     ] curry with-variable ;
 171
 172 M: snake-gadget handle-gesture
 173     swap dup key-down?
 174     [ sym>> handle-key ] [ 2drop ] if f ;