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 assocs calendar combinators
   4 combinators.short-circuit destructors formatting kernel math
   5 math.vectors namespaces opengl opengl.textures sequences sets
   6 snake-game.game snake-game.sprites timers ui ui.gadgets
   7 ui.gadgets.worlds 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             { :right [ { -20 -10 } ] }
  46             { :down  [ { -10 -20 } ] }
  47             { :up    [ { -10  0  } ] }
  48             { :left  [ {  0  -10 } ] }
  49         } case v+
  50     ] dip swap draw-sprite* ;
  51
  52 : draw-snake-body ( loc from-dir to-dir -- )
  53     [ name>> rest ] bi@ "body-%s-%s" sprintf draw-sprite ;
  54
  55 : draw-snake-tail ( loc facing-dir -- )
  56     name>> rest "tail-" prepend draw-sprite ;
  57
  58 : draw-snake-part ( loc from-dir snake-part -- )
  59     dup type>> {
  60         { :head [ drop opposite-dir draw-snake-head ] }
  61         { :body [ dir>> draw-snake-body ] }
  62         { :tail [ drop draw-snake-tail ] }
  63     } case ;
  64
  65 : next-snake-loc-from-dir ( loc from-dir snake-part -- new-loc new-from-dir )
  66     nip dir>> [ move-loc ] keep ;
  67
  68 : draw-snake ( loc from-dir snake -- )
  69     3dup [
  70         [ draw-snake-part ]
  71         [ next-snake-loc-from-dir ] 3bi
  72     ] each 2drop
  73     ! make sure to draw the head again
  74     first draw-snake-part ;
  75
  76 : game-status ( snake-game -- str )
  77     [ score>> ]
  78     [
  79         {
  80             { [ dup game-over?>> ] [ drop "Game Over" ] }
  81             { [ dup paused?>> ] [ drop "Game Paused" ] }
  82             [ drop "Game In Progress" ]
  83         } cond
  84     ] bi "Score: %d -- %s" sprintf ;
  85
  86 : update-status ( gadget -- )
  87     [ snake-game>> game-status ] keep show-status ;
  88
  89 : do-updates ( gadget -- )
  90     [ snake-game>> do-game-step ]
  91     [ update-status ]
  92     [ relayout-1 ]
  93     tri ;
  94
  95 : toggle-game-pause ( snake-gadget -- )
  96     snake-game>> [ not ] change-paused? drop ;
  97
  98 M: snake-gadget graft*
  99     dup '[ _ do-updates ] 200 milliseconds every >>timer
 100     snake-textures >>textures
 101     drop ;
 102
 103 M: snake-gadget ungraft*
 104     [ stop-timer f ] change-timer
 105     dup find-gl-context ! so texture disposing works properly
 106     [ values dispose-each f ] change-textures
 107     drop ;
 108
 109 M: snake-gadget pref-dim*
 110     drop snake-game-dim [ snake-game-cell-size * 20 + ] map ;
 111
 112 M: snake-gadget draw-gadget*
 113     [ textures>> game-textures ] keep '[
 114         draw-background
 115         { 10 10 } [
 116             _ snake-game>>
 117             [ food-loc>> [ draw-food ] when* ]
 118             [
 119                 [ snake-loc>> ]
 120                 [ snake-dir>> opposite-dir ]
 121                 [ snake>> ]
 122                 tri draw-snake
 123             ] bi
 124         ] with-translation
 125     ] with-variable ;
 126
 127 : key-dir ( key -- dir )
 128     H{
 129         { "RIGHT"  :right }
 130         { "LEFT"   :left }
 131         { "UP"     :up }
 132         { "DOWN"   :down }
 133     } at ;
 134
 135 : quit-key? ( key -- ? )
 136     HS{ "ESC" "q" "Q" } in? ;
 137
 138 : pause-key? ( key -- ? )
 139     HS{ " " "SPACE" "p" "P" } in? ;
 140
 141 : new-game-key? ( key -- ? )
 142     HS{ "ENTER" "RET" "n" "N" } in? ;
 143
 144 M: snake-gadget handle-gesture
 145     swap dup key-down? [
 146         sym>> {
 147             { [ dup quit-key? ] [ drop close-window ] }
 148             { [ dup pause-key? ] [ drop toggle-game-pause ] }
 149             { [ dup new-game-key? ] [ drop start-new-game ] }
 150             [
 151                 key-dir [
 152                     swap snake-game>> dup {
 153                         [ game-in-progress? ]
 154                         [ snake-dir>> opposite-dir pick = not ]
 155                     } 1&& [ next-turn-dir<< ] [ 2drop ] if
 156                 ] [ drop ] if*
 157             ]
 158         } cond
 159     ] [ 2drop ] if f ;