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 IN: tetris
   5
   6 TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
   7
   8 : <tetris-gadget> ( tetris -- gadget )
   9     tetris-gadget new-gadget swap >>tetris ;
  10
  11 M: tetris-gadget pref-dim* drop { 200 400 } ;
  12
  13 : update-status ( gadget -- )
  14     dup tetris>> [
  15         "Level: " % dup level>> #
  16         " Score: " % score>> #
  17     ] "" make swap show-status ;
  18
  19 M: tetris-gadget draw-gadget* ( gadget -- )
  20     [
  21         [ dim>> first2 ] [ tetris>> ] bi draw-tetris
  22     ] keep update-status ;
  23
  24 : new-tetris ( gadget -- gadget )
  25     [ <new-tetris> ] change-tetris ;
  26
  27 tetris-gadget H{
  28     { T{ button-down f f 1 }     [ request-focus ] }
  29     { T{ key-down f f "UP" }     [ tetris>> rotate-right ] }
  30     { T{ key-down f f "d" }      [ tetris>> rotate-left ] }
  31     { T{ key-down f f "f" }      [ tetris>> rotate-right ] }
  32     { T{ key-down f f "e" }      [ tetris>> rotate-left ] } ! dvorak d
  33     { T{ key-down f f "u" }      [ tetris>> rotate-right ] } ! dvorak f
  34     { T{ key-down f f "LEFT" }   [ tetris>> move-left ] }
  35     { T{ key-down f f "RIGHT" }  [ tetris>> move-right ] }
  36     { T{ key-down f f "DOWN" }   [ tetris>> move-down ] }
  37     { T{ key-down f f " " }      [ tetris>> move-drop ] }
  38     { T{ key-down f f "p" }      [ tetris>> toggle-pause ] }
  39     { T{ key-down f f "n" }      [ new-tetris drop ] }
  40 } set-gestures
  41
  42 : tick ( gadget -- )
  43     [ tetris>> ?update ] [ relayout-1 ] bi ;
  44
  45 M: tetris-gadget graft* ( gadget -- )
  46     [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ;
  47
  48 M: tetris-gadget ungraft* ( gadget -- )
  49     [ cancel-alarm f ] change-alarm drop ;
  50
  51 : tetris-window ( -- )
  52     [
  53         <default-tetris> <tetris-gadget>
  54         "Tetris" open-status-window
  55     ] with-ui ;
  56
  57 MAIN: tetris-window