From 80f6cb9e4fafaab48987d1922a18b87acd06999b Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Mon, 1 Oct 2007 15:10:59 +1000
Subject: [PATCH] jamshred updates

Jamshred now knows where the player is in the tunnel, and only renders 50
segments ahead and behind. It also turns the tunnel white as the player goes
through it.
---
 extra/jamshred/game/game.factor     |  4 ++--
 extra/jamshred/gl/gl.factor         | 16 ++++++++++------
 extra/jamshred/player/player.factor | 15 ++++++++++-----
 extra/jamshred/tunnel/tunnel.factor | 21 +++++++++++++++++----
 4 files changed, 39 insertions(+), 17 deletions(-)

diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor
index 96cdb60443..94905947f7 100644
--- a/extra/jamshred/game/game.factor
+++ b/extra/jamshred/game/game.factor
@@ -5,7 +5,7 @@ IN: jamshred.game
 TUPLE: jamshred tunnel players running ;
 
 : <jamshred> ( -- jamshred )
-    <random-tunnel> "Player 1" <player> 1array f
+    <random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
     jamshred construct-boa ;
 
 : jamshred-player ( jamshred -- player )
@@ -14,7 +14,7 @@ TUPLE: jamshred tunnel players running ;
 
 : jamshred-update ( jamshred -- )
     dup jamshred-running [
-        jamshred-player update-player
+        dup jamshred-tunnel swap jamshred-player update-player
     ] [ drop ] if ;
 
 : toggle-running ( jamshred -- )
diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor
index 0b58f14bed..ef642fcefd 100644
--- a/extra/jamshred/gl/gl.factor
+++ b/extra/jamshred/gl/gl.factor
@@ -6,8 +6,11 @@ IN: jamshred.gl
 : min-vertices 6 ; inline
 : max-vertices 32 ; inline
 
-: n-vertices ( -- n )
-    32 ; inline
+: n-vertices ( -- n ) 32 ; inline
+
+! render enough of the tunnel that it looks continuous
+: n-segments-ahead ( -- n ) 50 ; inline
+: n-segments-behind ( -- n ) 50 ; inline
 
 : draw-segment-vertex ( segment theta -- )
     over segment-color gl-color segment-vertex-and-normal
@@ -25,8 +28,9 @@ IN: jamshred.gl
 : draw-segments ( segments -- )
     1 over length pick subseq swap [ draw-segment ] 2each ;
 
-: draw-tunnel ( tunnel -- )
-    tunnel-segments draw-segments ;
+: draw-tunnel ( player tunnel -- )
+    tuck swap player-nearest-segment segment-number dup n-segments-behind -
+    swap n-segments-ahead + rot sub-tunnel draw-segments ;
 
 : init-graphics ( width height -- )
     GL_DEPTH_TEST glEnable
@@ -57,6 +61,6 @@ IN: jamshred.gl
     oint-up first3 gluLookAt ;
 
 : draw-jamshred ( jamshred width height -- )
-    init-graphics dup jamshred-player player-view
-    jamshred-tunnel draw-tunnel ;
+    init-graphics dup jamshred-player dup player-view
+    swap jamshred-tunnel draw-tunnel ;
 
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
index b339e599c4..f79edf8bdf 100644
--- a/extra/jamshred/player/player.factor
+++ b/extra/jamshred/player/player.factor
@@ -1,5 +1,5 @@
-USING: jamshred.game jamshred.oint jamshred.tunnel kernel
-math.constants ;
+USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel
+math.constants sequences ;
 IN: jamshred.player
 
 TUPLE: player name speed last-segment ;
@@ -8,13 +8,18 @@ TUPLE: player name speed last-segment ;
     1 f player construct-boa
     { 0 0 5 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> over set-delegate ;
 
-: update-player ( player -- )
-    0.1 swap go-forward ;
-
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
 
+: play-in-tunnel ( player tunnel -- )
+    tunnel-segments first dup oint-location pick set-oint-location
+    swap set-player-last-segment ;
+
 : player-nearest-segment ( tunnel player -- segment )
     [
         dup player-last-segment nearest-segment
     ] keep dupd set-player-last-segment ;
+
+: update-player ( tunnel player -- )
+    0.1 over go-forward player-nearest-segment white swap set-segment-color ;
+
diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index 42f0ee3469..9320ea84d3 100644
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -1,8 +1,8 @@
-USING: arrays kernel jamshred.oint math math.functions math.vectors
+USING: arrays kernel jamshred.oint math math.functions math.ranges math.vectors
 math.constants random sequences vectors ;
 IN: jamshred.tunnel
 
-: n-segments ( -- n ) 100 ; inline
+: n-segments ( -- n ) 5000 ; inline
 
 TUPLE: segment number color radius ;
 
@@ -71,18 +71,31 @@ C: <tunnel> tunnel
 : <straight-tunnel> ( -- tunnel )
     n-segments simple-segments <tunnel> ;
 
+: sub-tunnel ( from to tunnel -- segments )
+    #! return segments between from and to, after clamping from and to to
+    #! valid values
+    tunnel-segments [
+        sequence-index-range [ clamp-to-range ] curry 2apply
+    ] 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 ? ;
 
+: (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> = ;
+
 : find-nearest-segment ( oint segments -- segment )
-    tuck first swap [ -rot nearer-segment ] curry reduce ;
+    dup first swap 1 tail-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 )
-    1+ 0 swap rot <slice> <reversed> find-nearest-segment ;
+    swapd 1+ 0 swap rot <slice> <reversed> find-nearest-segment ;
 
 : nearest-segment ( tunnel oint start-segment -- segment )
     #! find the segment nearest to 'oint', and return it.