extra/snake-game/ui/ui.factor

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