jamshred: some very wrong bounce code...

extra/jamshred/game/game.factor

@@ -3,10 +3,10 @@
 USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ;
 IN: jamshred.game
 
-TUPLE: jamshred tunnel players running ;
+TUPLE: jamshred tunnel players running quit ;
 
 : <jamshred> ( -- jamshred )
-    <random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
+    <random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f f
     jamshred boa ;
 
 : jamshred-player ( jamshred -- player )
@@ -19,7 +19,13 @@ TUPLE: jamshred tunnel players running ;
     ] [ drop ] if ;
 
 : toggle-running ( jamshred -- )
-    [ running>> not ] [ (>>running) ] bi ;
+    dup running>> [
+        f >>running drop
+    ] [
+        [ jamshred-player moved ]
+        [ t >>running drop ] bi
+    ] if ;
 
 : mouse-moved ( x-radians y-radians jamshred -- )
     jamshred-player -rot turn-player ;
+

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 ui ui.gadgets ui.gestures ui.render math.vectors ;
+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 ;
 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 ) 1024 ;
-: default-height ( -- y ) 768 ;
+: default-width ( -- x ) 640 ;
+: default-height ( -- y ) 480 ;
 
 M: jamshred-gadget pref-dim*
     drop default-width default-height 2array ;
@@ -17,16 +17,19 @@ M: jamshred-gadget pref-dim*
 M: jamshred-gadget draw-gadget* ( gadget -- )
     [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
 
-: tick ( gadget -- )
-    [ jamshred>> jamshred-update ] [ relayout-1 ] bi ;
+: jamshred-loop ( gadget -- )
+    dup jamshred>> quit>> [
+        drop
+    ] [
+        dup [ jamshred>> jamshred-update ]
+        [ relayout-1 ] bi
+        50 sleep jamshred-loop
+    ] if ;
 
 M: jamshred-gadget graft* ( gadget -- )
-    [
-        [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
-    ] keep (>>alarm) ;
-
+    [ jamshred-loop ] in-thread drop ;
 M: jamshred-gadget ungraft* ( gadget -- )
-    [ alarm>> cancel-alarm ] [ f >>alarm drop ] bi ;
+    jamshred>> t >>quit drop ;
 
 : jamshred-restart ( jamshred-gadget -- )
     <jamshred> >>jamshred drop ;

extra/jamshred/oint/oint-tests.factor

@@ -0,0 +1,4 @@
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test

extra/jamshred/oint/oint.factor

@@ -55,10 +55,6 @@ TUPLE: oint location forward up left ;
 : proj-perp ( v u -- w )
     dupd proj v- ;
 
-! :: reflect ( v l -- v' )
-!     #! reflect v on l
-!     v l v. l l v. / 2 * l n*v v v- ;
-
-:: reflect ( vec n -- v' )
+:: reflect ( v n -- v' )
     #! bounce v on a surface with normal n
-    vec n v. n n*v -2 * vec v+ ;
+    v v n v. n n v. / 2 * n n*v v- ;

extra/jamshred/player/player.factor

@@ -1,12 +1,12 @@
 ! 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 ;
+USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences system ;
 IN: jamshred.player
 
-TUPLE: player < oint name tunnel nearest-segment ;
+TUPLE: player < oint name tunnel nearest-segment last-move ;
 
 : <player> ( name -- player )
-    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f player boa ;
+    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f f player boa ;
 
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
@@ -22,19 +22,23 @@ TUPLE: player < oint name tunnel nearest-segment ;
     [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
     [ (>>nearest-segment) ] tri ;
 
-: max-speed ( -- speed )
-    0.01 ;
+: moved ( player -- ) millis swap (>>last-move) ;
+: max-speed ( -- speed ) 1.0 ; ! units/second
 
 : player-speed ( player -- speed )
     drop max-speed ;
     ! dup nearest-segment>> fraction-from-wall sq max-speed * ;
 
-! : move-player ( player -- )
-!     dup player-speed over go-forward update-nearest-segment ;
+: distance-to-move ( player -- distance )
+    [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+    [ (>>last-move) ] tri ;
+
 DEFER: (move-player)
 
+USE: morse
 : ?bounce ( distance-remaining player -- )
     over 0 > [
+        "e" play-as-morse
         [ dup nearest-segment>> bounce ]
         ! [ (move-player) ] ! uncomment when bounce works...
         [ 2drop ]
@@ -52,12 +56,13 @@ USE: io.streams.string
     over 0 <= [
         2drop
     ] [
-        dup dup nearest-segment>> distance-to-collision ! [ .s ] with-string-writer jamshred-log
+        dup dup nearest-segment>> distance-to-collision
+        [ dup . ] with-string-writer jamshred-log
         move-player-distance ?bounce
     ] if ;
 
 : move-player ( player -- )
-    [ player-speed ] [ (move-player) ] [ update-nearest-segment ] tri ;
+    [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
 
 : update-player ( player -- )
     dup move-player nearest-segment>>

extra/jamshred/tunnel/tunnel.factor

@@ -126,15 +126,23 @@ C: <segment> segment
 !     ] [
 !     ] if ;
 
+USING: jamshred.log prettyprint io.streams.string ;
+
+: distant 10 ; inline
+
 :: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c )
-    -2b sqrt(b^2-2ac) + 2a /
-    -2b sqrt(b^2-2ac) - 2a / max ; ! the -ve answer is behind us (I think..)
+    sqrt(b^2-2ac) complex? [
+        distant
+    ] [
+        -2b sqrt(b^2-2ac) + 2a /
+        -2b sqrt(b^2-2ac) - 2a / max ! the -ve answer is behind us
+    ] if ;
 
 :: collision-coefficient ( v w -- c )
     [let* | a [ v dup v. ]
             b [ v w v. 2 * ]
             c [ w dup v. v dup v. - ] |
-        b -2 * b sq a c * 2 * - sqrt a 2 * (collision-coefficient) ] ;
+        b neg b sq a c * 4 * - sqrt a 2 * (collision-coefficient) ] ;
 
 : distance-to-collision ( oint segment -- distance )
     [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ]
@@ -150,18 +158,15 @@ C: <segment> segment
     location>> (wall-normal) ;
 
 : bounce-forward ( segment oint -- )
-    [ wall-normal ] [ swap reflect ] [ (>>forward) ] tri ;
+    [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
 
-: bounce-up ( oint segment -- )
-    2drop ; ! TODO
+: bounce-left ( segment oint -- )
+    [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ;
 
-: bounce-left ( oint segment -- )
-    2drop ; ! TODO
-
-! : bounce ( oint segment -- )
-!     [ swap bounce-forward ]
-!     [ bounce-up ]
-!     [ bounce-left ] 2tri ;
+: bounce-up ( segment oint -- )
+    #! must be done after forward and left!
+    nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
 
 : bounce ( oint segment -- )
-    drop 0.01 left-pivot ; ! just temporary
+    swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+