1 ! Copyright (C) 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays colors combinators fry jamshred.oint
4 kernel literals locals math math.constants math.matrices
5 math.order math.quadratic math.ranges math.vectors random
6 sequences specialized-arrays vectors ;
7 FROM: jamshred.oint => distance ;
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 )
35 [ dup last random-segment over push ] dip 1 - (random-segments)
38 CONSTANT: default-segment-radius 1
40 : initial-segment ( -- segment )
41 float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
42 0 random-color default-segment-radius <segment> ;
44 : random-segments ( n -- segments )
45 initial-segment 1vector swap (random-segments) ;
47 : simple-segment ( n -- segment )
48 [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
49 random-color default-segment-radius <segment> ;
51 : simple-segments ( n -- segments )
52 [ simple-segment ] map ;
54 : <random-tunnel> ( -- segments )
55 n-segments random-segments ;
57 : <straight-tunnel> ( -- segments )
58 n-segments simple-segments ;
60 : sub-tunnel ( from to segments -- segments )
61 #! return segments between from and to, after clamping from and to to
63 [ '[ _ clamp-length ] bi@ ] keep <slice> ;
65 : nearer-segment ( segment segment oint -- segment )
66 #! return whichever of the two segments is nearer to the oint
67 [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ;
69 : (find-nearest-segment) ( nearest next oint -- nearest ? )
70 #! find the nearest of 'next' and 'nearest' to 'oint', and return
71 #! t if the nearest hasn't changed
72 pick [ nearer-segment dup ] dip = ;
74 : find-nearest-segment ( oint segments -- segment )
75 dup first swap rest-slice rot [ (find-nearest-segment) ] curry
78 : nearest-segment-forward ( segments oint start -- segment )
79 rot dup length swap <slice> find-nearest-segment ;
81 : nearest-segment-backward ( segments oint start -- segment )
82 swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
84 : nearest-segment ( segments oint start-segment -- segment )
85 #! find the segment nearest to 'oint', and return it.
86 #! start looking at segment 'start-segment'
88 [ nearest-segment-forward ] 3keep nearest-segment-backward
89 ] dip nearer-segment ;
91 : get-segment ( segments n -- segment )
92 over clamp-length swap nth ;
94 : next-segment ( segments current-segment -- segment )
95 number>> 1 + get-segment ;
97 : previous-segment ( segments current-segment -- segment )
98 number>> 1 - get-segment ;
100 : heading-segment ( segments current-segment heading -- segment )
101 #! the next segment on the given heading
102 over forward>> v. 0 <=> {
103 { +gt+ [ next-segment ] }
104 { +lt+ [ previous-segment ] }
105 { +eq+ [ nip ] } ! current segment
108 :: distance-to-next-segment ( current next location heading -- distance )
109 [let | cf [ current forward>> ] |
110 cf next location>> v. cf location v. - cf heading v. / ] ;
112 :: distance-to-next-segment-area ( current next location heading -- distance )
113 [let | cf [ current forward>> ]
114 h [ next current half-way-between-oints ] |
115 cf h v. cf location v. - cf heading v. / ] ;
117 : vector-to-centre ( seg loc -- v )
118 over location>> swap v- swap forward>> proj-perp ;
120 : distance-from-centre ( seg loc -- distance )
121 vector-to-centre norm ;
123 : wall-normal ( seg oint -- n )
124 location>> vector-to-centre normalize ;
126 CONSTANT: distant 1000
128 : max-real ( a b -- c )
129 #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
131 over real? [ max ] [ nip ] if
133 drop dup real? [ drop distant ] unless
136 :: collision-coefficient ( v w r -- c )
140 [let* | a [ v dup v. ]
142 c [ w dup v. r sq - ] |
143 c b a quadratic max-real ]
146 : sideways-heading ( oint segment -- v )
147 [ forward>> ] bi@ proj-perp ;
149 : sideways-relative-location ( oint segment -- loc )
150 [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
152 : (distance-to-collision) ( oint segment -- distance )
153 [ sideways-heading ] [ sideways-relative-location ]
154 [ nip radius>> ] 2tri collision-coefficient ;
156 : collision-vector ( oint segment -- v )
157 dupd (distance-to-collision) swap forward>> n*v ;
159 : bounce-forward ( segment oint -- )
160 [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
162 : bounce-left ( segment oint -- )
163 #! must be done after forward
164 [ forward>> vneg ] dip [ left>> swap reflect ]
165 [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
167 : bounce-up ( segment oint -- )
168 #! must be done after forward and left!
169 nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
171 : bounce-off-wall ( oint segment -- )
172 swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;