[ ]
} cleave ;
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [let* | d-to-move [ d-left distance min ]
- move-v [ d-to-move heading n*v ] |
- move-v player location+
- player update-nearest-segment
- d-left d-to-move - player ] ;
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
-: (distance) ( player -- segments current location )
- [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ;
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
-: distance-to-next-segment ( player -- distance )
- [ (distance) ] [ forward>> distance-to-heading-segment ] bi ;
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
: distance-to-collision ( player -- distance )
dup nearest-segment>> (distance-to-collision) ;
-: move-toward-wall ( d-left player d-to-wall -- d-left' player )
- over distance-to-next-segment min
- over forward>> move-player-on-heading ;
-
: from ( player -- radius distance-from-centre )
[ nearest-segment>> dup radius>> swap ] [ location>> ] bi
distance-from-centre ;
: fraction-from-wall ( player -- fraction )
fraction-from-centre 1 swap - ;
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [let* | d-to-move [ d-left distance min ]
+ move-v [ d-to-move heading n*v ] |
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ] ;
+
+: move-toward-wall ( d-left player d-to-wall -- d-left' player )
+ over [ forward>> ] keep distance-to-heading-segment-area min
+ over forward>> move-player-on-heading ;
+
: ?move-player-freely ( d-left player -- d-left' player )
- ! 2dup [ 0 > ] [ fraction-from-wall 0 > ] bi* and [
over 0 > [
- dup distance-to-collision dup 0 > [
+ dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
move-toward-wall ?move-player-freely
] [ drop ] if
] when ;
: drag-heading ( player -- heading )
[ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
-: drag-distance-to-next-segment ( player -- distance )
- [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ;
-
: drag-player ( d-left player -- d-left' player )
- dup [ drag-distance-to-next-segment ]
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
[ drag-heading move-player-on-heading ] bi ;
: (move-player) ( d-left player -- d-left' player )
?move-player-freely over 0 > [
! bounce
drag-player
- ! (move-player)
+ (move-player)
] when ;
: move-player ( player -- )
-! 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.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
USE: tools.walker
{ +eq+ [ nip ] } ! current segment
} case ;
-:: distance-to-heading-segment ( segments current location heading -- distance )
- #! the distance on the oint's current heading until it enters the next
- #! segment's cross-section
- [let* | next [ segments current heading heading-segment location>> ]
- cf [ current forward>> ] |
- cf next v. cf location v. - cf heading v. / ] ;
+:: 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 ;
: distant ( -- n ) 1000 ;
+: 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 )
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 ]
+ c b a quadratic max-real ]
] if ;
: sideways-heading ( oint segment -- v )
: sideways-relative-location ( oint segment -- loc )
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-: collision-vector ( oint segment -- v )
+: (distance-to-collision) ( oint segment -- distance )
[ sideways-heading ] [ sideways-relative-location ]
- [ 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 ;