! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-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 vectors ;
+USING: accessors alien.c-types colors combinators jamshred.oint
+kernel literals math math.constants math.order math.quadratic
+math.vectors random sequences specialized-arrays vectors ;
FROM: jamshred.oint => distance ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
C: <segment> segment
: segment-number++ ( segment -- )
- [ number>> 1 + ] keep (>>number) ;
+ [ number>> 1 + ] keep number<< ;
: clamp-length ( n seq -- n' )
0 swap length clamp ;
random-color >>color dup segment-number++ ;
: (random-segments) ( segments n -- segments )
- dup 0 > [
- [ dup last random-segment over push ] dip 1 - (random-segments)
- ] [ drop ] if ;
+ [ dup last random-segment suffix! ] times ;
CONSTANT: default-segment-radius 1
n-segments simple-segments ;
: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
+ ! return segments between from and to, after clamping from and to to
+ ! valid values
[ '[ _ clamp-length ] bi@ ] keep <slice> ;
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- [ 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 [ nearer-segment dup ] dip = ;
-
-: find-nearest-segment ( oint segments -- segment )
- dup first swap rest-slice rot [ (find-nearest-segment) ] curry
- find 2drop ;
-
-: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
-
-: nearest-segment-backward ( segments oint start -- 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'
- number>> over [
- [ nearest-segment-forward ] 3keep nearest-segment-backward
- ] dip nearer-segment ;
-
: get-segment ( segments n -- segment )
over clamp-length swap nth ;
number>> 1 - get-segment ;
: heading-segment ( segments current-segment heading -- segment )
- #! the next segment on the given heading
- over forward>> v. 0 <=> {
+ ! the next segment on the given heading
+ over forward>> vdot 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. / ] ;
+ current forward>> :> cf
+ cf next location>> vdot cf location vdot - cf heading vdot / ;
:: 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. / ] ;
+ current forward>> :> cf
+ next current half-way-between-oints :> h
+ cf h vdot cf location vdot - cf heading vdot / ;
-: vector-to-centre ( seg loc -- v )
+: vector-to-center ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ;
-: distance-from-centre ( seg loc -- distance )
- vector-to-centre norm ;
+: distance-from-center ( seg loc -- distance )
+ vector-to-center norm ;
: wall-normal ( seg oint -- n )
- location>> vector-to-centre normalize ;
+ location>> vector-to-center normalize ;
CONSTANT: distant 1000
: max-real ( a b -- c )
- #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ ! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
dup real? [
over real? [ max ] [ nip ] if
] [
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 ]
+ v dup vdot :> a
+ v w vdot 2 * :> b
+ w dup vdot r sq - :> c
+ c b a quadratic max-real
] if ;
: sideways-heading ( oint segment -- v )
dupd (distance-to-collision) swap forward>> n*v ;
: bounce-forward ( segment oint -- )
- [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+ [ wall-normal ] [ forward>> swap reflect ] [ forward<< ] tri ;
: bounce-left ( segment oint -- )
- #! must be done after forward
+ ! must be done after forward
[ forward>> vneg ] dip [ left>> swap reflect ]
- [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+ [ forward>> proj-perp normalize ] [ left<< ] tri ;
: bounce-up ( segment oint -- )
- #! must be done after forward and left!
- nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+ ! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ up<< ] tri ;
: bounce-off-wall ( oint segment -- )
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
-