-! Copyright (C) 2007 Alex Chapman
+! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USING: accessors arrays colors combinators fry jamshred.oint
+kernel literals locals math math.constants math.matrices
+math.order math.quadratic math.ranges math.vectors random
+sequences specialized-arrays.float vectors ;
+FROM: jamshred.oint => distance ;
IN: jamshred.tunnel
-: n-segments ( -- n ) 5000 ; inline
+CONSTANT: n-segments 5000
TUPLE: segment < oint number color radius ;
C: <segment> segment
-: segment-vertex ( theta segment -- vertex )
- tuck 2dup up>> swap sin v*n
- >r left>> swap cos v*n r> v+
- swap location>> v+ ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
-
: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
+ [ number>> 1 + ] keep (>>number) ;
+
+: clamp-length ( n seq -- n' )
+ 0 swap length clamp ;
: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
-: tunnel-segment-distance ( -- n ) 0.4 ;
-: random-rotation-angle ( -- theta ) pi 20 / ;
+CONSTANT: tunnel-segment-distance 0.4
+CONSTANT: random-rotation-angle $[ pi 20 / ]
: random-segment ( previous-segment -- segment )
clone dup random-rotation-angle random-turn
tunnel-segment-distance over go-forward
- random-color over set-segment-color dup segment-number++ ;
+ random-color >>color dup segment-number++ ;
: (random-segments) ( segments n -- segments )
dup 0 > [
- >r dup peek random-segment over push r> 1- (random-segments)
- ] [
- drop
- ] if ;
+ [ dup last random-segment over push ] dip 1 - (random-segments)
+ ] [ drop ] if ;
-: default-segment-radius ( -- r ) 1 ;
+CONSTANT: default-segment-radius 1
: initial-segment ( -- segment )
- F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+ float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
0 random-color default-segment-radius <segment> ;
: random-segments ( n -- segments )
initial-segment 1vector swap (random-segments) ;
: simple-segment ( n -- segment )
- [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+ [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
random-color default-segment-radius <segment> ;
: simple-segments ( n -- segments )
: <straight-tunnel> ( -- segments )
n-segments simple-segments ;
-: sub-tunnel ( from to sements -- segments )
+: sub-tunnel ( from to segments -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+ [ '[ _ clamp-length ] bi@ ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint
- >r 2dup r> tuck distance >r distance r> < -rot ? ;
+ [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ;
: (find-nearest-segment) ( nearest next oint -- nearest ? )
#! find the nearest of 'next' and 'nearest' to 'oint', and return
#! t if the nearest hasn't changed
- pick >r nearer-segment dup r> = ;
+ pick [ nearer-segment dup ] dip = ;
: find-nearest-segment ( oint segments -- segment )
dup first swap rest-slice rot [ (find-nearest-segment) ] curry
rot dup length swap <slice> find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+ swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.
#! start looking at segment 'start-segment'
- segment-number over >r
- [ nearest-segment-forward ] 3keep
- nearest-segment-backward r> nearer-segment ;
+ number>> over [
+ [ nearest-segment-forward ] 3keep nearest-segment-backward
+ ] dip nearer-segment ;
+
+: get-segment ( segments n -- segment )
+ over clamp-length swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1 + get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1 - get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
: vector-to-centre ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ;
: wall-normal ( seg oint -- n )
location>> vector-to-centre normalize ;
-: from ( seg loc -- radius d-f-c )
- dupd location>> distance-from-centre [ radius>> ] dip ;
+CONSTANT: distant 1000
-: distance-from-wall ( seg loc -- distance ) from - ;
-: fraction-from-centre ( seg loc -- fraction ) from / ;
-: fraction-from-wall ( seg loc -- fraction )
- fraction-from-centre 1 swap - ;
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
:: collision-coefficient ( v w r -- c )
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max ] ;
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
: sideways-heading ( oint segment -- v )
[ forward>> ] bi@ proj-perp ;
: sideways-relative-location ( oint segment -- loc )
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-: bounce-offset 0.1 ; inline
-
-: bounce-radius ( segment -- r )
- radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?)
-
-: collision-vector ( oint segment -- v )
+: (distance-to-collision) ( oint segment -- distance )
[ sideways-heading ] [ sideways-relative-location ]
- [ bounce-radius ] 2tri
- swap [ collision-coefficient ] dip forward>> n*v ;
+ [ nip radius>> ] 2tri collision-coefficient ;
-: distance-to-collision ( oint segment -- distance )
- collision-vector norm ;
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
: bounce-forward ( segment oint -- )
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
#! must be done after forward and left!
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
-: bounce ( oint segment -- )
+: bounce-off-wall ( oint segment -- )
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
projects / factor.git / blobdiff