1 USING: accessors arrays assocs calendar colors.constants
2 combinators game.input grouping kernel math math.parser
3 math.vectors sequences threads timers ui ui.gadgets
4 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
5 ui.gadgets.packs ui.pens.polygon ui.pens.solid ;
6 IN: game.input.demos.joysticks
8 CONSTANT: SIZE { 151 151 }
9 CONSTANT: INDICATOR-SIZE { 4 4 }
10 : FREQUENCY ( -- f ) 30 recip seconds ;
12 TUPLE: axis-gadget < gadget indicator z-indicator pov ;
14 M: axis-gadget pref-dim* drop SIZE ;
16 : (rect-polygon) ( lo hi -- polygon )
18 [ [ second ] [ first ] bi* swap 2array ]
19 [ [ first ] [ second ] bi* 2array ] 2bi swapd 4array ;
21 : indicator-polygon ( -- polygon )
22 { 0 0 } INDICATOR-SIZE (rect-polygon) ;
24 CONSTANT: pov-polygons
26 { pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } }
27 { pov-up { { 70 65 } { 75 60 } { 80 65 } } }
28 { pov-up-right { { 83 60 } { 90 60 } { 90 67 } } }
29 { pov-right { { 85 70 } { 90 75 } { 85 80 } } }
30 { pov-down-right { { 90 83 } { 90 90 } { 83 90 } } }
31 { pov-down { { 70 85 } { 75 90 } { 80 85 } } }
32 { pov-down-left { { 67 90 } { 60 90 } { 60 83 } } }
33 { pov-left { { 65 70 } { 60 75 } { 65 80 } } }
34 { pov-up-left { { 67 60 } { 60 60 } { 60 67 } } }
37 : <indicator-gadget> ( color -- indicator )
38 indicator-polygon <polygon-gadget> ;
40 : (>loc) ( axisloc -- windowloc )
41 0.5 v*n { 0.5 0.5 } v+ SIZE v* v>integer
42 INDICATOR-SIZE 2 v/n v- ;
44 : (xy>loc) ( x y -- xyloc )
46 : (z>loc) ( z -- zloc )
47 0.0 swap 2array (>loc) ;
49 : (xyz>loc) ( x y z -- xyloc zloc )
50 [ [ 0.0 ] unless* ] tri@
51 [ (xy>loc) ] dip (z>loc) ;
53 :: move-axis ( gadget x y z -- )
54 x y z (xyz>loc) :> ( xy z )
55 xy gadget indicator>> loc<<
56 z gadget z-indicator>> loc<< ;
58 : move-pov ( gadget pov -- )
59 swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ]
62 :: add-pov-gadget ( gadget direction polygon -- gadget direction gadget )
63 gadget COLOR: white polygon <polygon-gadget> [ add-gadget ] keep
66 : add-pov-gadgets ( gadget -- gadget )
67 pov-polygons [ add-pov-gadget ] assoc-map >>pov ;
69 : <axis-gadget> ( -- gadget )
72 COLOR: black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
73 COLOR: red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
74 dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
76 TUPLE: joystick-demo-gadget < pack axis raxis controller buttons timer ;
78 : add-gadget-with-border ( parent child -- parent )
79 { 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
81 : add-controller-label ( gadget controller -- gadget )
82 [ >>controller ] [ product-string <label> add-gadget ] bi ;
84 : add-axis-gadget ( gadget shelf -- gadget shelf )
85 <axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi-curry bi* ;
87 : add-raxis-gadget ( gadget shelf -- gadget shelf )
88 <axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi-curry bi* ;
90 : button-pref-dim ( n -- dim )
91 number>string [ drop ] <border-button> pref-dim ;
93 :: (add-button-gadgets) ( gadget pile -- )
94 gadget controller>> read-controller buttons>>
95 dup length button-pref-dim :> pref-dim
97 number>string [ drop ] <border-button>
100 buttons gadget buttons<<
102 [ <shelf> ] dip [ add-gadget ] each
103 pile swap add-gadget drop
106 : add-button-gadgets ( gadget pile -- gadget pile )
107 [ (add-button-gadgets) ] 2keep ;
109 : <joystick-demo-gadget> ( controller -- gadget )
110 joystick-demo-gadget new
111 { 0 1 } >>orientation
112 swap add-controller-label
113 <shelf> add-axis-gadget add-raxis-gadget add-gadget
114 <pile> add-button-gadgets add-gadget ;
116 : update-buttons ( buttons button-states -- )
117 [ >>selected? drop ] 2each ;
119 : kill-update-axes ( gadget -- )
120 COLOR: gray <solid> >>interior
121 [ [ stop-timer ] when* f ] change-timer
124 : (update-axes) ( gadget controller-state -- )
126 [ [ axis>> ] [ [ x>> ] [ y>> ] [ z>> ] tri ] bi* move-axis ]
127 [ [ raxis>> ] [ [ rx>> ] [ ry>> ] [ rz>> ] tri ] bi* move-axis ]
128 [ [ axis>> ] [ pov>> ] bi* move-pov ]
129 [ [ buttons>> ] [ buttons>> ] bi* update-buttons ]
133 : update-axes ( gadget -- )
134 dup controller>> read-controller
135 [ (update-axes) ] [ kill-update-axes ] if* ;
137 M: joystick-demo-gadget graft*
138 dup '[ _ update-axes ] FREQUENCY every >>timer
141 M: joystick-demo-gadget ungraft*
142 timer>> [ stop-timer ] when* ;
144 : joystick-window ( controller -- )
145 [ <joystick-demo-gadget> ] [ product-string ] bi
148 : joystick-demo ( -- )
151 100 milliseconds sleep ! It might take a moment to find devices...
152 get-controllers [ joystick-window ] each