new jamshred collision model almost working (but buggy as hell)

extra/jamshred/gl/gl.factor

@@ -1,8 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types colors jamshred.game jamshred.oint
+USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ;
-jamshred.player jamshred.tunnel kernel math math.vectors opengl
-opengl.gl opengl.glu sequences ;
 IN: jamshred.gl
 
 : min-vertices 6 ; inline
@@ -14,6 +12,35 @@ IN: jamshred.gl
 : n-segments-ahead ( -- n ) 60 ; inline
 : n-segments-behind ( -- n ) 40 ; inline
 
+: wall-drawing-offset ( -- n )
+    #! so that we can't see through the wall, we draw it a bit further away
+    0.15 ;
+
+: wall-drawing-radius ( segment -- r )
+    radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+    [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+    [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+    [
+        [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+    ] [
+        location>> v+
+    ] bi ;
+
+: 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 ;
 : draw-segment-vertex ( segment theta -- )
     over segment-color gl-color segment-vertex-and-normal
     gl-normal gl-vertex ;

extra/jamshred/oint/oint.factor

@@ -39,8 +39,11 @@ C: <oint> oint
 : random-turn ( oint theta -- )
     2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
 
+: location+ ( v oint -- )
+    [ location>> v+ ] [ (>>location) ] bi ;
+
 : go-forward ( distance oint -- )
-    [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
+    [ forward>> n*v ] [ location+ ] bi ;
 
 : distance-vector ( oint oint -- vector )
     [ location>> ] bi@ swap v- ;
@@ -62,3 +65,9 @@ C: <oint> oint
 :: reflect ( v n -- v' )
     #! bounce v on a surface with normal n
     v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+    over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+    [ location>> ] bi@ half-way ;

extra/jamshred/player/player.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Alex Chapman
+! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
+USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ;
+USE: tools.walker
 IN: jamshred.player
 
 TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
@@ -30,6 +31,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
     [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
     [ (>>nearest-segment) ] tri ;
 
+: update-time ( player -- seconds-passed )
+    millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
 : moved ( player -- ) millis swap (>>last-move) ;
 
 : speed-range ( -- range )
@@ -41,38 +45,73 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
 : multiply-player-speed ( n player -- )
     [ * speed-range clamp-to-range ] change-speed drop ; 
 
-: distance-to-move ( player -- distance )
+: distance-to-move ( seconds-passed player -- distance )
-    [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+    speed>> * ;
-    [ (>>last-move) ] tri ;
 
-DEFER: (move-player)
+: bounce ( d-left player -- d-left' player )
+    {
+        [ dup nearest-segment>> bounce-off-wall ]
+        [ sounds>> bang ]
+        [ 3/4 swap multiply-player-speed ]
+        [ ]
+    } cleave ;
 
-: ?bounce ( distance-remaining player -- )
+:: 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) ( player -- segments current location )
+    [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ;
+
+: distance-to-next-segment ( player -- distance )
+    [ (distance) ] [ forward>> distance-to-heading-segment ] bi ;
+
+: 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 ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+    fraction-from-centre 1 swap - ;
+
+: ?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 nearest-segment>> bounce ]
+            move-toward-wall ?move-player-freely
-            [ sounds>> bang ]
+        ] [ drop ] if
-            [ 3/4 swap multiply-player-speed ]
+    ] when ;
-            [ (move-player) ]
-        } cleave
-    ] [
-        2drop
-    ] if ;
 
-: move-player-distance ( distance-remaining player distance -- distance-remaining player )
+: drag-heading ( player -- heading )
-    pick min tuck over go-forward [ - ] dip ;
+    [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
 
-: (move-player) ( distance-remaining player -- )
+: drag-distance-to-next-segment ( player -- distance )
-    over 0 <= [
+    [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ;
-        2drop
+
-    ] [
+: drag-player ( d-left player -- d-left' player )
-        dup dup nearest-segment>> distance-to-collision
+    dup [ drag-distance-to-next-segment ]
-        move-player-distance ?bounce
+    [ drag-heading move-player-on-heading ] bi ;
-    ] if ;
+
+: (move-player) ( d-left player -- d-left' player )
+    ?move-player-freely over 0 > [
+        ! bounce
+        drag-player
+        ! (move-player)
+    ] when ;
 
 : move-player ( player -- )
-    [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
+    [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
 
 : update-player ( player -- )
-    dup move-player nearest-segment>>
+    [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
-    white swap set-segment-color ;

extra/jamshred/tunnel/tunnel-tests.factor

@@ -42,4 +42,4 @@ IN: jamshred.tunnel.tests
 [ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
 [ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
 [ { 0 1 0 } ]
-[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test

extra/jamshred/tunnel/tunnel.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007 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 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
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline
@@ -8,21 +9,6 @@ IN: jamshred.tunnel
 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) ;
 
@@ -40,9 +26,7 @@ C: <segment> segment
 : (random-segments) ( segments n -- segments )
     dup 0 > [
         >r dup peek random-segment over push r> 1- (random-segments)
-    ] [
+    ] [ drop ] if ;
-        drop
-    ] if ;
 
 : default-segment-radius ( -- r ) 1 ;
 
@@ -66,7 +50,7 @@ C: <segment> segment
 : <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> ;
@@ -97,6 +81,30 @@ C: <segment> segment
     [ nearest-segment-forward ] 3keep
     nearest-segment-backward r> nearer-segment ;
 
+: get-segment ( segments n -- segment )
+    over sequence-index-range clamp-to-range 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-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. / ] ;
+
 : vector-to-centre ( seg loc -- v )
     over location>> swap v- swap forward>> proj-perp ;
 
@@ -106,19 +114,17 @@ C: <segment> segment
 : wall-normal ( seg oint -- n )
     location>> vector-to-centre normalize ;
 
-: from ( seg loc -- radius d-f-c )
+: distant ( -- n ) 1000 ;
-    dupd location>> distance-from-centre [ radius>> ] dip ;
-
-: 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 - ;
 
 :: collision-coefficient ( v w r -- c )
-    [let* | a [ v dup v. ]
+    v norm 0 = [
-            b [ v w v. 2 * ]
+        distant
-            c [ w dup v. r sq - ] |
+    ] [
-        c b a quadratic max ] ;
+        [let* | a [ v dup v. ]
+                b [ v w v. 2 * ]
+                c [ w dup v. r sq - ] |
+            c b a quadratic max ]
+    ] if ;
 
 : sideways-heading ( oint segment -- v )
     [ forward>> ] bi@ proj-perp ;
@@ -126,17 +132,12 @@ C: <segment> segment
 : 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 )
     [ sideways-heading ] [ sideways-relative-location ]
-    [ bounce-radius ] 2tri
+    [ radius>> ] 2tri
     swap [ collision-coefficient ] dip forward>> n*v ;
 
-: distance-to-collision ( oint segment -- distance )
+: (distance-to-collision) ( oint segment -- distance )
     collision-vector norm ;
 
 : bounce-forward ( segment oint -- )
@@ -151,6 +152,6 @@ C: <segment> segment
     #! 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 ;