apps/tetris/tetris-gadget.factor

   1 ! Copyright (C) 2006 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel generic gadgets tetris tetris-gl sequences threads arrays ;
   4 IN: tetris-gadget
   5
   6 TUPLE: tetris-gadget tetris quit? ;
   7
   8 C: tetris-gadget ( tetris -- gadget )
   9     [ set-tetris-gadget-tetris ] keep
  10     [ f swap set-tetris-gadget-quit? ] keep
  11     [ delegate>gadget ] keep ;
  12
  13 M: tetris-gadget pref-dim* drop { 200 400 } ;
  14
  15 M: tetris-gadget draw-gadget* ( gadget -- )
  16     ! TODO: show score, level, etc.
  17     dup rect-dim dup first swap second rot tetris-gadget-tetris draw-tetris ;
  18
  19 : new-tetris ( gadget -- )
  20     dup tetris-gadget-tetris <new-tetris> swap set-tetris-gadget-tetris ;
  21
  22 tetris-gadget H{
  23     { T{ key-down f f "ESCAPE" } [ t swap set-tetris-gadget-quit? ] }
  24     { T{ key-down f f "q" }      [ t swap set-tetris-gadget-quit? ] }
  25     { T{ key-down f f "UP" }     [ tetris-gadget-tetris rotate ] }
  26     { T{ key-down f f "LEFT" }   [ tetris-gadget-tetris move-left ] }
  27     { T{ key-down f f "RIGHT" }  [ tetris-gadget-tetris move-right ] }
  28     { T{ key-down f f "DOWN" }   [ tetris-gadget-tetris move-down ] }
  29     { T{ key-down f f " " }      [ tetris-gadget-tetris move-drop ] }
  30     { T{ key-down f f "p" }      [ tetris-gadget-tetris toggle-pause ] }
  31     { T{ key-down f f "n" }      [ new-tetris ] }
  32 } set-gestures
  33
  34 : tetris-process ( gadget -- )
  35     dup tetris-gadget-quit? [
  36         10 sleep
  37         dup tetris-gadget-tetris maybe-update
  38         [ relayout-1 ] keep
  39         tetris-process
  40     ] unless ;
  41
  42 M: tetris-gadget graft* ( gadget -- )
  43     f over set-tetris-gadget-quit?
  44     [ tetris-process ] in-thread drop ;
  45
  46 M: tetris-gadget ungraft* ( gadget -- )
  47     t swap set-tetris-gadget-quit? ;
  48
  49 : tetris-window ( -- ) <default-tetris> <tetris-gadget> "Tetris" open-titled-window ;
  50