Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / extra / jamshred / tunnel / tunnel.factor

diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
old mode 100755 (executable)
new mode 100644 (file)
index 8d2cc8e..ac5be9d
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -1,22 +1,28 @@
 ! 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
+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.float vectors ;
+FROM: jamshred.oint => distance ;
 IN: jamshred.tunnel
 
-: n-segments ( -- n ) 5000 ; inline
+CONSTANT: n-segments 5000
 
 TUPLE: segment < oint number color radius ;
 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 )
-    { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
+    { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
 
-: tunnel-segment-distance ( -- n ) 0.4 ;
-: random-rotation-angle ( -- theta ) pi 20 / ;
+CONSTANT: tunnel-segment-distance 0.4
+CONSTANT: random-rotation-angle $[ pi 20 / ]
 
 : random-segment ( previous-segment -- segment )
     clone dup random-rotation-angle random-turn
@@ -25,20 +31,20 @@ C: <segment> segment
 
 : (random-segments) ( segments n -- segments )
     dup 0 > [
-        >r dup peek random-segment over push r> 1- (random-segments)
+        [ dup last random-segment over push ] dip 1 - (random-segments)
     ] [ drop ] if ;
 
-: default-segment-radius ( -- r ) 1 ;
+CONSTANT: default-segment-radius 1
 
 : initial-segment ( -- segment )
-    F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+    float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
     0 random-color default-segment-radius <segment> ;
 
 : random-segments ( n -- segments )
     initial-segment 1vector swap (random-segments) ;
 
 : simple-segment ( n -- segment )
-    [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+    [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
     random-color default-segment-radius <segment> ;
 
 : simple-segments ( n -- segments )
@@ -53,16 +59,16 @@ C: <segment> segment
 : 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> ;
+    [ '[ _ clamp-length ] bi@ ] 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 ? ;
+    [ 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 >r nearer-segment dup r> = ;
+    pick [ nearer-segment dup ] dip = ;
 
 : find-nearest-segment ( oint segments -- segment )
     dup first swap rest-slice rot [ (find-nearest-segment) ] curry
@@ -72,23 +78,23 @@ C: <segment> 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 ;
+    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 >r
-    [ nearest-segment-forward ] 3keep
-    nearest-segment-backward r> nearer-segment ;
+    number>> over [
+        [ nearest-segment-forward ] 3keep nearest-segment-backward
+    ] dip nearer-segment ;
 
 : get-segment ( segments n -- segment )
-    over sequence-index-range clamp-to-range swap nth ;
+    over clamp-length swap nth ;
 
 : next-segment ( segments current-segment -- segment )
-    number>> 1+ get-segment ;
+    number>> 1 + get-segment ;
 
 : previous-segment ( segments current-segment -- segment )
-    number>> 1- get-segment ;
+    number>> 1 - get-segment ;
 
 : heading-segment ( segments current-segment heading -- segment )
     #! the next segment on the given heading
@@ -116,7 +122,7 @@ C: <segment> segment
 : wall-normal ( seg oint -- n )
     location>> vector-to-centre normalize ;
 
-: distant ( -- n ) 1000 ;
+CONSTANT: distant 1000
 
 : max-real ( a b -- c )
     #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)