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