unmaintained/tetris/tetris.factor

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