jamshred still buggy, but player now 'slides' on the walls instead of bouncing

extra/jamshred/jamshred.factor

@@ -88,7 +88,7 @@ jamshred-gadget H{
     { T{ mouse-scroll } [ handle-mouse-scroll ] }
 } set-gestures
 
-: jamshred-window ( -- )
+: jamshred-window ( -- jamshred )
-    [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
+    [ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
 
 MAIN: jamshred-window

extra/jamshred/player/player.factor

@@ -56,26 +56,20 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
         [ ]
     } cleave ;
 
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+:: (distance) ( heading player -- current next location heading )
-    [let* | d-to-move [ d-left distance min ]
+    player nearest-segment>>
-            move-v [ d-to-move heading n*v ] |
+    player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
-        move-v player location+
+    player location>> heading ;
-        player update-nearest-segment
-        d-left d-to-move - player ] ;
 
-: (distance) ( player -- segments current location )
+: distance-to-heading-segment ( heading player -- distance )
-    [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ;
+    (distance) distance-to-next-segment ;
 
-: distance-to-next-segment ( player -- distance )
+: distance-to-heading-segment-area ( heading player -- distance )
-    [ (distance) ] [ forward>> distance-to-heading-segment ] bi ;
+    (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 ;
@@ -85,10 +79,28 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
 : 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 ;
@@ -96,18 +108,15 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
 : 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 -- )

extra/jamshred/tunnel/tunnel.factor

@@ -1,4 +1,4 @@
-! 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
@@ -98,12 +98,14 @@ C: <segment> segment
         { +eq+ [ nip ] } ! current segment
     } case ;
 
-:: distance-to-heading-segment ( segments current location heading -- distance )
+:: distance-to-next-segment ( current next location heading -- distance )
-    #! the distance on the oint's current heading until it enters the next
+    [let | cf [ current forward>> ] |
-    #! segment's cross-section
+        cf next location>> v. cf location v. - cf heading v. / ] ;
-    [let* | next [ segments current heading heading-segment location>> ]
+
-            cf   [ current forward>> ] |
+:: distance-to-next-segment-area ( current next location heading -- distance )
-        cf next v. cf location v. - cf heading v. / ] ;
+    [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 ;
@@ -116,6 +118,14 @@ C: <segment> segment
 
 : 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
@@ -123,7 +133,7 @@ C: <segment> segment
         [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 )
@@ -132,13 +142,12 @@ C: <segment> segment
 : sideways-relative-location ( oint segment -- loc )
     [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
 
-: collision-vector ( oint segment -- v )
-    [ sideways-heading ] [ sideways-relative-location ]
-    [ radius>> ] 2tri
-    swap [ collision-coefficient ] dip forward>> n*v ;
-
 : (distance-to-collision) ( oint segment -- distance )
-    collision-vector norm ;
+    [ sideways-heading ] [ sideways-relative-location ]
+    [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+    dupd (distance-to-collision) swap forward>> n*v ;
 
 : bounce-forward ( segment oint -- )
     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;