1 ! Copyright (C) 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle system ;
6 TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
8 ! speeds are in GL units / second
9 : default-speed ( -- speed ) 1.0 ;
10 : max-speed ( -- speed ) 30.0 ;
12 : <player> ( name sounds -- player )
13 [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
14 f f f default-speed player boa ;
16 : turn-player ( player x-radians y-radians -- )
17 >r over r> left-pivot up-pivot ;
19 : roll-player ( player z-radians -- )
22 : to-tunnel-start ( player -- )
23 [ tunnel>> first dup location>> ]
24 [ tuck (>>location) (>>nearest-segment) ] bi ;
26 : play-in-tunnel ( player segments -- )
27 >>tunnel to-tunnel-start ;
29 : update-nearest-segment ( player -- )
30 [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
31 [ (>>nearest-segment) ] tri ;
33 : update-time ( player -- seconds-passed )
34 millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
36 : moved ( player -- ) millis swap (>>last-move) ;
38 : speed-range ( -- range )
41 : change-player-speed ( inc player -- )
42 [ + speed-range clamp-to-range ] change-speed drop ;
44 : multiply-player-speed ( n player -- )
45 [ * speed-range clamp-to-range ] change-speed drop ;
47 : distance-to-move ( seconds-passed player -- distance )
50 : bounce ( d-left player -- d-left' player )
52 [ dup nearest-segment>> bounce-off-wall ]
54 [ 3/4 swap multiply-player-speed ]
58 :: (distance) ( heading player -- current next location heading )
59 player nearest-segment>>
60 player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
61 player location>> heading ;
63 : distance-to-heading-segment ( heading player -- distance )
64 (distance) distance-to-next-segment ;
66 : distance-to-heading-segment-area ( heading player -- distance )
67 (distance) distance-to-next-segment-area ;
69 : distance-to-collision ( player -- distance )
70 dup nearest-segment>> (distance-to-collision) ;
72 : from ( player -- radius distance-from-centre )
73 [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
74 distance-from-centre ;
76 : distance-from-wall ( player -- distance ) from - ;
77 : fraction-from-centre ( player -- fraction ) from swap / ;
78 : fraction-from-wall ( player -- fraction )
79 fraction-from-centre 1 swap - ;
81 : update-nearest-segment2 ( heading player -- )
82 2dup distance-to-heading-segment-area 0 <= [
83 [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
84 [ (>>nearest-segment) ] tri
89 :: move-player-on-heading ( d-left player distance heading -- d-left' player )
90 [let* | d-to-move [ d-left distance min ]
91 move-v [ d-to-move heading n*v ] |
92 move-v player location+
93 heading player update-nearest-segment2
94 d-left d-to-move - player ] ;
96 : move-toward-wall ( d-left player d-to-wall -- d-left' player )
97 over [ forward>> ] keep distance-to-heading-segment-area min
98 over forward>> move-player-on-heading ;
100 : ?move-player-freely ( d-left player -- d-left' player )
102 dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
103 move-toward-wall ?move-player-freely
107 : drag-heading ( player -- heading )
108 [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
110 : drag-player ( d-left player -- d-left' player )
111 dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
112 [ drag-heading move-player-on-heading ] bi ;
114 : (move-player) ( d-left player -- d-left' player )
115 ?move-player-freely over 0 > [
121 : move-player ( player -- )
122 [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
124 : update-player ( player -- )
125 [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;