1 ! Copyright (C) 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types colors combinators jamshred.oint
4 kernel literals math math.constants math.order math.quadratic
5 math.vectors random sequences specialized-arrays vectors ;
6 FROM: jamshred.oint => distance ;
7 FROM: alien.c-types => float ;
8 SPECIALIZED-ARRAY: float
11 CONSTANT: n-segments 5000
13 TUPLE: segment < oint number color radius ;
16 : segment-number++ ( segment -- )
17 [ number>> 1 + ] keep number<< ;
19 : clamp-length ( n seq -- n' )
22 : random-color ( -- color )
23 { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
25 CONSTANT: tunnel-segment-distance 0.4
26 CONSTANT: random-rotation-angle $[ pi 20 / ]
28 : random-segment ( previous-segment -- segment )
29 clone dup random-rotation-angle random-turn
30 tunnel-segment-distance over go-forward
31 random-color >>color dup segment-number++ ;
33 : (random-segments) ( segments n -- segments )
34 [ dup last random-segment suffix! ] times ;
36 CONSTANT: default-segment-radius 1
38 : initial-segment ( -- segment )
39 float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
40 0 random-color default-segment-radius <segment> ;
42 : random-segments ( n -- segments )
43 initial-segment 1vector swap (random-segments) ;
45 : simple-segment ( n -- segment )
46 [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
47 random-color default-segment-radius <segment> ;
49 : simple-segments ( n -- segments )
50 [ simple-segment ] map ;
52 : <random-tunnel> ( -- segments )
53 n-segments random-segments ;
55 : <straight-tunnel> ( -- segments )
56 n-segments simple-segments ;
58 : sub-tunnel ( from to segments -- segments )
59 ! return segments between from and to, after clamping from and to to
61 [ '[ _ clamp-length ] bi@ ] keep <slice> ;
63 : get-segment ( segments n -- segment )
64 over clamp-length swap nth ;
66 : next-segment ( segments current-segment -- segment )
67 number>> 1 + get-segment ;
69 : previous-segment ( segments current-segment -- segment )
70 number>> 1 - get-segment ;
72 : heading-segment ( segments current-segment heading -- segment )
73 ! the next segment on the given heading
74 over forward>> vdot 0 <=> {
75 { +gt+ [ next-segment ] }
76 { +lt+ [ previous-segment ] }
77 { +eq+ [ nip ] } ! current segment
80 :: distance-to-next-segment ( current next location heading -- distance )
81 current forward>> :> cf
82 cf next location>> vdot cf location vdot - cf heading vdot / ;
84 :: distance-to-next-segment-area ( current next location heading -- distance )
85 current forward>> :> cf
86 next current half-way-between-oints :> h
87 cf h vdot cf location vdot - cf heading vdot / ;
89 : vector-to-centre ( seg loc -- v )
90 over location>> swap v- swap forward>> proj-perp ;
92 : distance-from-centre ( seg loc -- distance )
93 vector-to-centre norm ;
95 : wall-normal ( seg oint -- n )
96 location>> vector-to-centre normalize ;
98 CONSTANT: distant 1000
100 : max-real ( a b -- c )
101 ! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
103 over real? [ max ] [ nip ] if
105 drop dup real? [ drop distant ] unless
108 :: collision-coefficient ( v w r -- c )
114 w dup vdot r sq - :> c
115 c b a quadratic max-real
118 : sideways-heading ( oint segment -- v )
119 [ forward>> ] bi@ proj-perp ;
121 : sideways-relative-location ( oint segment -- loc )
122 [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
124 : (distance-to-collision) ( oint segment -- distance )
125 [ sideways-heading ] [ sideways-relative-location ]
126 [ nip radius>> ] 2tri collision-coefficient ;
128 : collision-vector ( oint segment -- v )
129 dupd (distance-to-collision) swap forward>> n*v ;
131 : bounce-forward ( segment oint -- )
132 [ wall-normal ] [ forward>> swap reflect ] [ forward<< ] tri ;
134 : bounce-left ( segment oint -- )
135 ! must be done after forward
136 [ forward>> vneg ] dip [ left>> swap reflect ]
137 [ forward>> proj-perp normalize ] [ left<< ] tri ;
139 : bounce-up ( segment oint -- )
140 ! must be done after forward and left!
141 nip [ forward>> ] [ left>> cross ] [ up<< ] tri ;
143 : bounce-off-wall ( oint segment -- )
144 swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;