extra/tetris/tetris.factor

   1 ! Copyright (C) 2006, 2007, 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
   4 FROM: tetris.game => level>> ;
   5 IN: tetris
   6
   7 TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
   8
   9 : <tetris-gadget> ( tetris -- gadget )
  10     tetris-gadget new swap >>tetris ;
  11
  12 M: tetris-gadget pref-dim* drop { 200 400 } ;
  13
  14 : update-status ( gadget -- )
  15     dup tetris>> [
  16         "Level: " % dup level>> #
  17         " Score: " % score>> #
  18     ] "" make swap show-status ;
  19
  20 M: tetris-gadget draw-gadget* ( gadget -- )
  21     [
  22         [ dim>> first2 ] [ tetris>> ] bi draw-tetris
  23     ] keep update-status ;
  24
  25 : new-tetris ( gadget -- gadget )
  26     [ <new-tetris> ] change-tetris ;
  27
  28 tetris-gadget H{
  29     { T{ button-down f f 1 }     [ request-focus ] }
  30     { T{ key-down f f "UP" }     [ tetris>> rotate-right ] }
  31     { T{ key-down f f "d" }      [ tetris>> rotate-left ] }
  32     { T{ key-down f f "f" }      [ tetris>> rotate-right ] }
  33     { T{ key-down f f "e" }      [ tetris>> rotate-left ] } ! dvorak d
  34     { T{ key-down f f "u" }      [ tetris>> rotate-right ] } ! dvorak f
  35     { T{ key-down f f "LEFT" }   [ tetris>> move-left ] }
  36     { T{ key-down f f "RIGHT" }  [ tetris>> move-right ] }
  37     { T{ key-down f f "DOWN" }   [ tetris>> move-down ] }
  38     { T{ key-down f f " " }      [ tetris>> move-drop ] }
  39     { T{ key-down f f "p" }      [ tetris>> toggle-pause ] }
  40     { T{ key-down f f "n" }      [ new-tetris drop ] }
  41 } set-gestures
  42
  43 : tick ( gadget -- )
  44     [ tetris>> ?update ] [ relayout-1 ] bi ;
  45
  46 M: tetris-gadget graft* ( gadget -- )
  47     [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ;
  48
  49 M: tetris-gadget ungraft* ( gadget -- )
  50     [ cancel-alarm f ] change-alarm drop ;
  51
  52 : tetris-window ( -- )
  53     [
  54         <default-tetris> <tetris-gadget>
  55         "Tetris" open-status-window
  56     ] with-ui ;
  57
  58 MAIN: tetris-window