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 timers arrays calendar kernel make math math.rectangles
   4 math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets
   5 ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures
   6 ui.render ui ;
   7 FROM: tetris.game => level>> ;
   8 IN: tetris
   9
  10 TUPLE: tetris-gadget < gadget { tetris tetris } { timer } ;
  11
  12 : <tetris-gadget> ( tetris -- gadget )
  13     tetris-gadget new swap >>tetris ;
  14
  15 M: tetris-gadget pref-dim* drop { 200 400 } ;
  16
  17 : update-status ( gadget -- )
  18     dup tetris>> [
  19         [ "Level: " % level>> # ]
  20         [ " Score: " % score>> # ]
  21         [ paused?>> [ " (Paused)" % ] when ] tri
  22     ] "" make swap show-status ;
  23
  24 M: tetris-gadget draw-gadget* ( gadget -- )
  25     [
  26         [ dim>> first2 ] [ tetris>> ] bi draw-tetris
  27     ] keep update-status ;
  28
  29 : new-tetris ( gadget -- gadget )
  30     [ <new-tetris> ] change-tetris ;
  31
  32 : unless-paused ( tetris quot -- )
  33     over tetris>> paused?>> [
  34         2drop
  35     ] [
  36         call
  37     ] if ; inline
  38
  39 tetris-gadget H{
  40     { T{ button-down f f 1 }     [ request-focus ] }
  41     { T{ key-down f f "UP" }     [ [ tetris>> rotate-right ] unless-paused ] }
  42     { T{ key-down f f "d" }      [ [ tetris>> rotate-left ] unless-paused ] }
  43     { T{ key-down f f "f" }      [ [ tetris>> rotate-right ] unless-paused ] }
  44     { T{ key-down f f "e" }      [ [ tetris>> rotate-left ] unless-paused ] }
  45     { T{ key-down f f "u" }      [ [ tetris>> rotate-right ] unless-paused ] }
  46     { T{ key-down f f "LEFT" }   [ [ tetris>> move-left ] unless-paused ] }
  47     { T{ key-down f f "RIGHT" }  [ [ tetris>> move-right ] unless-paused ] }
  48     { T{ key-down f f "DOWN" }   [ [ tetris>> move-down ] unless-paused ] }
  49     { T{ key-down f f " " }      [ [ tetris>> move-drop ] unless-paused ] }
  50     { T{ key-down f f "p" }      [ tetris>> toggle-pause ] }
  51     { T{ key-down f f "n" }      [ new-tetris drop ] }
  52 } set-gestures
  53
  54 : tick ( gadget -- )
  55     [ tetris>> ?update ] [ relayout-1 ] bi ;
  56
  57 M: tetris-gadget graft* ( gadget -- )
  58     [ [ tick ] curry 100 milliseconds every ] keep timer<< ;
  59
  60 M: tetris-gadget ungraft* ( gadget -- )
  61     [ stop-timer f ] change-timer drop ;
  62
  63 : tetris-window ( -- )
  64     [
  65         <default-tetris> <tetris-gadget>
  66         "Tetris" open-status-window
  67     ] with-ui ;
  68
  69 MAIN: tetris-window