1 ! Copyright (C) 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors colors.constants combinators jamshred.log
4 jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
5 math.constants math.order math.ranges math.vectors math.matrices
6 sequences shuffle specialized-arrays strings system ;
7 QUALIFIED-WITH: alien.c-types c
8 SPECIALIZED-ARRAY: c:float
19 ! speeds are in GL units / second
20 CONSTANT: default-speed 1.0
21 CONSTANT: max-speed 30.0
23 : <player> ( name sounds -- player )
24 [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
25 f f 0 default-speed player boa ;
27 : turn-player ( player x-radians y-radians -- )
28 [ over ] dip left-pivot up-pivot ;
30 : roll-player ( player z-radians -- )
33 : to-tunnel-start ( player -- )
34 [ tunnel>> first dup location>> ]
35 [ tuck (>>location) (>>nearest-segment) ] bi ;
37 : play-in-tunnel ( player segments -- )
38 >>tunnel to-tunnel-start ;
40 : update-nearest-segment ( player -- )
41 [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
42 [ (>>nearest-segment) ] tri ;
44 : update-time ( player -- seconds-passed )
45 millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
47 : moved ( player -- ) millis swap (>>last-move) ;
49 : speed-range ( -- range )
52 : change-player-speed ( inc player -- )
53 [ + 0 max-speed clamp ] change-speed drop ;
55 : multiply-player-speed ( n player -- )
56 [ * 0 max-speed clamp ] change-speed drop ;
58 : distance-to-move ( seconds-passed player -- distance )
61 : bounce ( d-left player -- d-left' player )
63 [ dup nearest-segment>> bounce-off-wall ]
65 [ 3/4 swap multiply-player-speed ]
69 :: (distance) ( heading player -- current next location heading )
70 player nearest-segment>>
71 player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
72 player location>> heading ;
74 : distance-to-heading-segment ( heading player -- distance )
75 (distance) distance-to-next-segment ;
77 : distance-to-heading-segment-area ( heading player -- distance )
78 (distance) distance-to-next-segment-area ;
80 : distance-to-collision ( player -- distance )
81 dup nearest-segment>> (distance-to-collision) ;
83 : almost-to-collision ( player -- distance )
84 distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
86 : from ( player -- radius distance-from-centre )
87 [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
88 distance-from-centre ;
90 : distance-from-wall ( player -- distance ) from - ;
91 : fraction-from-centre ( player -- fraction ) from swap / ;
92 : fraction-from-wall ( player -- fraction )
93 fraction-from-centre 1 swap - ;
95 : update-nearest-segment2 ( heading player -- )
96 2dup distance-to-heading-segment-area 0 <= [
97 [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
98 [ (>>nearest-segment) ] tri
103 :: move-player-on-heading ( d-left player distance heading -- d-left' player )
104 [let* | d-to-move [ d-left distance min ]
105 move-v [ d-to-move heading n*v ] |
106 move-v player location+
107 heading player update-nearest-segment2
108 d-left d-to-move - player ] ;
110 : distance-to-move-freely ( player -- distance )
111 [ almost-to-collision ]
112 [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
114 : ?move-player-freely ( d-left player -- d-left' player )
116 ! must make sure we are moving a significant distance, otherwise
117 ! we can recurse endlessly due to floating-point imprecision.
118 ! (at least I /think/ that's what causes it...)
119 dup distance-to-move-freely dup 0.1 > [
120 over forward>> move-player-on-heading ?move-player-freely
124 : drag-heading ( player -- heading )
125 [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
127 : drag-player ( d-left player -- d-left' player )
128 dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
129 [ drag-heading move-player-on-heading ] bi ;
131 : (move-player) ( d-left player -- d-left' player )
132 ?move-player-freely over 0 > [
138 : move-player ( player -- )
139 [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
141 : update-player ( player -- )
142 [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ;