jamshred is playable! (scroll to acc/decelerate)

extra/jamshred/jamshred.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ;
+USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ;
 IN: jamshred
 
 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
@@ -8,8 +8,8 @@ TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
 : <jamshred-gadget> ( jamshred -- gadget )
     jamshred-gadget construct-gadget swap >>jamshred ;
 
-: default-width ( -- x ) 640 ;
+: default-width ( -- x ) 800 ;
-: default-height ( -- y ) 480 ;
+: default-height ( -- y ) 600 ;
 
 M: jamshred-gadget pref-dim*
     drop default-width default-height 2array ;
@@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
     ] [
         dup [ jamshred>> jamshred-update ]
         [ relayout-1 ] bi
-        50 sleep jamshred-loop
+        10 sleep jamshred-loop
     ] if ;
 
 M: jamshred-gadget graft* ( gadget -- )
@@ -57,10 +57,15 @@ M: jamshred-gadget ungraft* ( gadget -- )
         ] [ 2drop ] if* 
     ] 2keep >>last-hand-loc drop ;
 
+: handle-mouse-scroll ( jamshred-gadget -- )
+    jamshred>> jamshred-player scroll-direction get
+    second neg swap change-player-speed ;
+
 jamshred-gadget H{
     { T{ key-down f f "r" } [ jamshred-restart ] }
     { T{ key-down f f " " } [ jamshred>> toggle-running ] }
     { T{ motion } [ handle-mouse-motion ] }
+    { T{ mouse-scroll } [ handle-mouse-scroll ] }
 } set-gestures
 
 : jamshred-window ( -- )

extra/jamshred/player/player.factor

@@ -1,12 +1,17 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences system ;
+USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order math.ranges sequences system ;
 IN: jamshred.player
 
-TUPLE: player < oint name tunnel nearest-segment last-move ;
+TUPLE: player < oint name tunnel nearest-segment last-move speed ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 10.0 ;
 
 : <player> ( name -- player )
-    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f f player boa ;
+    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip
+    f f f default-speed player boa ;
 
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
@@ -23,13 +28,15 @@ TUPLE: player < oint name tunnel nearest-segment last-move ;
     [ (>>nearest-segment) ] tri ;
 
 : moved ( player -- ) millis swap (>>last-move) ;
-: max-speed ( -- speed ) 1.0 ; ! units/second
 
-: player-speed ( player -- speed )
+: speed-range ( -- range )
-    drop max-speed ;
+    max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+    [ + speed-range clamp-to-range ] change-speed drop ;
 
 : distance-to-move ( player -- distance )
-    [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+    [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
     [ (>>last-move) ] tri ;
 
 DEFER: (move-player)

extra/jamshred/tunnel/tunnel.factor

@@ -137,7 +137,9 @@ C: <segment> segment
     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
 
 : bounce-left ( segment oint -- )
-    [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ;
+    #! must be done after forward
+    [ forward>> vneg ] dip [ left>> swap reflect ]
+    [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
 
 : bounce-up ( segment oint -- )
     #! must be done after forward and left!