1 ! Copyright (C) 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors colors combinators jamshred.oint
5 jamshred.sound jamshred.tunnel kernel math math.order
6 math.vectors ranges sequences specialized-arrays
8 QUALIFIED-WITH: alien.c-types c
9 SPECIALIZED-ARRAY: c:float
20 ! speeds are in GL units / second
21 CONSTANT: default-speed 1.0
22 CONSTANT: max-speed 30.0
24 : <player> ( name sounds -- player )
25 [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
26 f f 0 default-speed player boa ;
28 : turn-player ( player x-radians y-radians -- )
29 overd left-pivot up-pivot ;
31 : roll-player ( player z-radians -- )
34 : to-tunnel-start ( player -- )
37 [ location>> >>location ] bi drop ;
39 : play-in-tunnel ( player segments -- )
40 >>tunnel to-tunnel-start ;
42 : update-time ( player -- seconds-passed )
43 nano-count swap [ last-move>> - 1,000,000,000 / ] [ last-move<< ] 2bi ;
45 : moved ( player -- ) nano-count swap last-move<< ;
47 : speed-range ( -- range )
50 : change-player-speed ( inc player -- )
51 [ + 0 max-speed clamp ] change-speed drop ;
53 : multiply-player-speed ( n player -- )
54 [ * 0 max-speed clamp ] change-speed drop ;
56 : distance-to-move ( seconds-passed player -- distance )
59 : bounce ( d-left player -- d-left' player )
61 [ dup nearest-segment>> bounce-off-wall ]
63 [ 3/4 swap multiply-player-speed ]
67 :: (distance) ( heading player -- current next location heading )
68 player nearest-segment>>
69 player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
70 player location>> heading ;
72 : distance-to-heading-segment ( heading player -- distance )
73 (distance) distance-to-next-segment ;
75 : distance-to-heading-segment-area ( heading player -- distance )
76 (distance) distance-to-next-segment-area ;
78 : distance-to-collision ( player -- distance )
79 dup nearest-segment>> (distance-to-collision) ;
81 : almost-to-collision ( player -- distance )
82 distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
84 : from ( player -- radius distance-from-centre )
85 [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
86 distance-from-centre ;
88 : distance-from-wall ( player -- distance ) from - ;
89 : fraction-from-centre ( player -- fraction ) from swap / ;
90 : fraction-from-wall ( player -- fraction )
91 fraction-from-centre 1 swap - ;
93 : update-nearest-segment2 ( heading player -- )
94 2dup distance-to-heading-segment-area 0 <= [
95 [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
96 [ nearest-segment<< ] tri
101 :: move-player-on-heading ( d-left player distance heading -- d-left' player )
102 d-left distance min :> d-to-move
103 d-to-move heading n*v :> move-v
105 move-v player location+
106 heading player update-nearest-segment2
107 d-left d-to-move - player ;
109 : distance-to-move-freely ( player -- distance )
110 [ almost-to-collision ]
111 [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
113 : ?move-player-freely ( d-left player -- d-left' player )
115 ! must make sure we are moving a significant distance, otherwise
116 ! we can recurse endlessly due to floating-point imprecision.
117 ! (at least I /think/ that's what causes it...)
118 dup distance-to-move-freely dup 0.1 > [
119 over forward>> move-player-on-heading ?move-player-freely
123 : drag-heading ( player -- heading )
124 [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
126 : drag-player ( d-left player -- d-left' player )
127 dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
128 [ drag-heading move-player-on-heading ] bi ;
130 : (move-player) ( d-left player -- d-left' player )
131 ?move-player-freely over 0 > [
136 : move-player ( player -- )
137 [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
139 : update-player ( player -- )
140 [ move-player ] [ nearest-segment>> COLOR: white swap color<< ] bi ;