1 ! Copyright (C) 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
7 : n-segments ( -- n ) 5000 ; inline
9 TUPLE: segment < oint number color radius ;
12 : segment-number++ ( segment -- )
13 [ number>> 1+ ] keep (>>number) ;
15 : random-color ( -- color )
16 { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
18 : tunnel-segment-distance ( -- n ) 0.4 ;
19 : random-rotation-angle ( -- theta ) pi 20 / ;
21 : random-segment ( previous-segment -- segment )
22 clone dup random-rotation-angle random-turn
23 tunnel-segment-distance over go-forward
24 random-color over set-segment-color dup segment-number++ ;
26 : (random-segments) ( segments n -- segments )
28 >r dup peek random-segment over push r> 1- (random-segments)
31 : default-segment-radius ( -- r ) 1 ;
33 : initial-segment ( -- segment )
34 F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
35 0 random-color default-segment-radius <segment> ;
37 : random-segments ( n -- segments )
38 initial-segment 1vector swap (random-segments) ;
40 : simple-segment ( n -- segment )
41 [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
42 random-color default-segment-radius <segment> ;
44 : simple-segments ( n -- segments )
45 [ simple-segment ] map ;
47 : <random-tunnel> ( -- segments )
48 n-segments random-segments ;
50 : <straight-tunnel> ( -- segments )
51 n-segments simple-segments ;
53 : sub-tunnel ( from to segments -- segments )
54 #! return segments between from and to, after clamping from and to to
56 [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
58 : nearer-segment ( segment segment oint -- segment )
59 #! return whichever of the two segments is nearer to the oint
60 >r 2dup r> tuck distance >r distance r> < -rot ? ;
62 : (find-nearest-segment) ( nearest next oint -- nearest ? )
63 #! find the nearest of 'next' and 'nearest' to 'oint', and return
64 #! t if the nearest hasn't changed
65 pick >r nearer-segment dup r> = ;
67 : find-nearest-segment ( oint segments -- segment )
68 dup first swap rest-slice rot [ (find-nearest-segment) ] curry
71 : nearest-segment-forward ( segments oint start -- segment )
72 rot dup length swap <slice> find-nearest-segment ;
74 : nearest-segment-backward ( segments oint start -- segment )
75 swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
77 : nearest-segment ( segments oint start-segment -- segment )
78 #! find the segment nearest to 'oint', and return it.
79 #! start looking at segment 'start-segment'
80 segment-number over >r
81 [ nearest-segment-forward ] 3keep
82 nearest-segment-backward r> nearer-segment ;
84 : get-segment ( segments n -- segment )
85 over sequence-index-range clamp-to-range swap nth ;
87 : next-segment ( segments current-segment -- segment )
88 number>> 1+ get-segment ;
90 : previous-segment ( segments current-segment -- segment )
91 number>> 1- get-segment ;
93 : heading-segment ( segments current-segment heading -- segment )
94 #! the next segment on the given heading
95 over forward>> v. 0 <=> {
96 { +gt+ [ next-segment ] }
97 { +lt+ [ previous-segment ] }
98 { +eq+ [ nip ] } ! current segment
101 :: distance-to-next-segment ( current next location heading -- distance )
102 [let | cf [ current forward>> ] |
103 cf next location>> v. cf location v. - cf heading v. / ] ;
105 :: distance-to-next-segment-area ( current next location heading -- distance )
106 [let | cf [ current forward>> ]
107 h [ next current half-way-between-oints ] |
108 cf h v. cf location v. - cf heading v. / ] ;
110 : vector-to-centre ( seg loc -- v )
111 over location>> swap v- swap forward>> proj-perp ;
113 : distance-from-centre ( seg loc -- distance )
114 vector-to-centre norm ;
116 : wall-normal ( seg oint -- n )
117 location>> vector-to-centre normalize ;
119 : distant ( -- n ) 1000 ;
121 : max-real ( a b -- c )
122 #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
124 over real? [ max ] [ nip ] if
126 drop dup real? [ drop distant ] unless
129 :: collision-coefficient ( v w r -- c )
133 [let* | a [ v dup v. ]
135 c [ w dup v. r sq - ] |
136 c b a quadratic max-real ]
139 : sideways-heading ( oint segment -- v )
140 [ forward>> ] bi@ proj-perp ;
142 : sideways-relative-location ( oint segment -- loc )
143 [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
145 : (distance-to-collision) ( oint segment -- distance )
146 [ sideways-heading ] [ sideways-relative-location ]
147 [ nip radius>> ] 2tri collision-coefficient ;
149 : collision-vector ( oint segment -- v )
150 dupd (distance-to-collision) swap forward>> n*v ;
152 : bounce-forward ( segment oint -- )
153 [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
155 : bounce-left ( segment oint -- )
156 #! must be done after forward
157 [ forward>> vneg ] dip [ left>> swap reflect ]
158 [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
160 : bounce-up ( segment oint -- )
161 #! must be done after forward and left!
162 nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
164 : bounce-off-wall ( oint segment -- )
165 swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;