jamshred: some dodgy debug logging, and some dodgy collision detection :)

extra/jamshred/game/game.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel opengl arrays sequences jamshred.tunnel
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ;
-jamshred.player math.vectors ;
 IN: jamshred.game
 
 TUPLE: jamshred tunnel players running ;
@@ -12,15 +11,15 @@ TUPLE: jamshred tunnel players running ;
 
 : jamshred-player ( jamshred -- player )
     ! TODO: support more than one player
-    jamshred-players first ;
+    players>> first ;
 
 : jamshred-update ( jamshred -- )
-    dup jamshred-running [
+    dup running>> [
         jamshred-player update-player
     ] [ drop ] if ;
 
 : toggle-running ( jamshred -- )
-    dup jamshred-running not swap set-jamshred-running ;
+    [ running>> not ] [ (>>running) ] bi ;
 
 : mouse-moved ( x-radians y-radians jamshred -- )
     jamshred-player -rot turn-player ;

extra/jamshred/jamshred.factor

@@ -1,14 +1,12 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
+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 ;
-math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
-math.vectors ;
 IN: jamshred
 
 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
 
 : <jamshred-gadget> ( jamshred -- gadget )
-    jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
+    jamshred-gadget construct-gadget swap >>jamshred ;
 
 : default-width ( -- x ) 1024 ;
 : default-height ( -- y ) 768 ;
@@ -17,22 +15,21 @@ M: jamshred-gadget pref-dim*
     drop default-width default-height 2array ;
 
 M: jamshred-gadget draw-gadget* ( gadget -- )
-    dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
+    [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
 
 : tick ( gadget -- )
-    dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
+    [ jamshred>> jamshred-update ] [ relayout-1 ] bi ;
 
 M: jamshred-gadget graft* ( gadget -- )
     [
         [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
-    ] keep set-jamshred-gadget-alarm ;
+    ] keep (>>alarm) ;
 
 M: jamshred-gadget ungraft* ( gadget -- )
-    [ jamshred-gadget-alarm cancel-alarm f ] keep
+    [ alarm>> cancel-alarm ] [ f >>alarm drop ] bi ;
-    set-jamshred-gadget-alarm ;
 
 : jamshred-restart ( jamshred-gadget -- )
-    <jamshred> swap set-jamshred-gadget-jamshred ;
+    <jamshred> >>jamshred drop ;
 
 : pix>radians ( n m -- theta )
     2 / / pi 2 * * ;
@@ -46,21 +43,20 @@ M: jamshred-gadget ungraft* ( gadget -- )
     rect-dim second pix>radians ;
 
 : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
-    over jamshred-gadget-jamshred >r
+    over jamshred>> >r
     [ first swap x>radians ] 2keep second swap y>radians
     r> mouse-moved ;
     
 : handle-mouse-motion ( jamshred-gadget -- )
     hand-loc get [
-        over jamshred-gadget-last-hand-loc [
+        over last-hand-loc>> [
             v- (handle-mouse-motion) 
         ] [ 2drop ] if* 
-    ] 2keep swap set-jamshred-gadget-last-hand-loc ;
+    ] 2keep >>last-hand-loc drop ;
 
-USE: vocabs.loader
 jamshred-gadget H{
     { T{ key-down f f "r" } [ jamshred-restart ] }
-    { T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
+    { T{ key-down f f " " } [ jamshred>> toggle-running ] }
     { T{ motion } [ handle-mouse-motion ] }
 } set-gestures
 

extra/jamshred/log/log.factor

@@ -0,0 +1,10 @@
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+    "jamshred" swap with-logging ;
+
+: jamshred-log ( message -- )
+    [ (jamshred-log) ] with-jamshred-log ; ! ugly...

extra/jamshred/oint/oint.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
 IN: jamshred.oint
 
 ! An oint is a point with three linearly independent unit vectors
@@ -10,46 +10,23 @@ IN: jamshred.oint
 
 TUPLE: oint location forward up left ;
 
-: <oint> ( location forward up left -- oint )
-    oint boa ;
-
-! : x-rotation ( theta -- matrix )
-!     #! construct this matrix:
-!     #! { { 1           0          0 }
-!     #!   { 0  cos(theta) sin(theta) }
-!     #!   { 0 -sin(theta) cos(theta) } }
-!     dup sin neg swap cos 2dup 0 -rot 3float-array >r
-!     swap neg 0 -rot 3float-array >r
-!     { 1 0 0 } r> r> 3float-array ;
-! 
-! : y-rotation ( theta -- matrix )
-!     #! costruct this matrix:
-!     #! { { cos(theta) 0 -sin(theta) }
-!     #!   {          0 1           0 }
-!     #!   { sin(theta) 0  cos(theta) } }
-!     dup sin swap cos 2dup
-!     0 swap 3float-array >r
-!     { 0 1 0 } >r
-!     0 rot neg 3float-array r> r> 3float-array ;
-
-: apply-to-oint ( oint quot -- )
-    #! apply quot to each of forward, up, and left, storing the results
-    over oint-forward over call pick set-oint-forward
-    over oint-up over call pick set-oint-up
-    over oint-left swap call swap set-oint-left ;
-
 : rotation-quaternion ( theta axis -- quaternion )
     swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
 
+: rotate-vector ( q qrecip v -- v )
+    v>q swap q* q* q>v ;
+
 : rotate-oint ( oint theta axis -- )
-    rotation-quaternion dup qrecip
+    rotation-quaternion dup qrecip pick
-    [ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
+    [ forward>> rotate-vector >>forward ]
+    [ up>> rotate-vector >>up ]
+    [ left>> rotate-vector >>left ] 3tri drop ;
 
 : left-pivot ( oint theta -- )
-    over oint-left rotate-oint ;
+    over left>> rotate-oint ;
 
 : up-pivot ( oint theta -- )
-    over oint-up rotate-oint ;
+    over up>> rotate-oint ;
 
 : random-float+- ( n -- m )
     #! find a random float between -n/2 and n/2
@@ -59,10 +36,10 @@ TUPLE: oint location forward up left ;
     2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
 
 : go-forward ( distance oint -- )
-    tuck oint-forward n*v over oint-location v+ swap set-oint-location ;
+    [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
 
 : distance-vector ( oint oint -- vector )
-    oint-location swap oint-location v- ;
+    [ location>> ] bi@ swap v- ;
 
 : distance ( oint oint -- distance )
     distance-vector norm ;
@@ -72,9 +49,16 @@ TUPLE: oint location forward up left ;
     tuck v. swap norm / ;
 
 : perpendicular-distance ( oint oint -- distance )
-    tuck distance-vector swap 2dup oint-left scalar-projection abs
+    tuck distance-vector swap 2dup left>> scalar-projection abs
-    -rot oint-up scalar-projection abs + ;
+    -rot up>> scalar-projection abs + ;
 
-:: reflect ( v l -- v' )
+: proj-perp ( v u -- w )
-    #! reflect v on l
+    dupd proj v- ;
-    v l v. l l v. / 2 * l n*v v 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' )
+    #! bounce v on a surface with normal n
+    vec n v. n n*v -2 * vec v+ ;

extra/jamshred/player/player.factor

@@ -1,39 +1,64 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: colors jamshred.oint jamshred.tunnel kernel
+USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences ;
-math math.constants sequences ;
 IN: jamshred.player
 
-TUPLE: player name tunnel nearest-segment ;
+TUPLE: player < oint name tunnel nearest-segment ;
 
 : <player> ( name -- player )
-    f f player boa
+    [ 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 } <oint> over set-delegate ;
 
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
 
 : to-tunnel-start ( player -- )
-    dup player-tunnel first dup oint-location pick set-oint-location
+    [ tunnel>> first dup location>> ]
-    swap set-player-nearest-segment ;
+    [ tuck (>>location) (>>nearest-segment) ] bi ;
 
 : play-in-tunnel ( player segments -- )
-    over set-player-tunnel to-tunnel-start ;
+    >>tunnel to-tunnel-start ;
 
 : update-nearest-segment ( player -- )
-    dup player-tunnel over dup player-nearest-segment nearest-segment
+    [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
-    swap set-player-nearest-segment ;
+    [ (>>nearest-segment) ] tri ;
 
 : max-speed ( -- speed )
-    0.3 ;
+    0.01 ;
 
 : player-speed ( player -- speed )
-    max-speed ;
+    drop max-speed ;
-    ! dup player-nearest-segment fraction-from-wall sq max-speed * ;
+    ! dup nearest-segment>> fraction-from-wall sq max-speed * ;
+
+! : move-player ( player -- )
+!     dup player-speed over go-forward update-nearest-segment ;
+DEFER: (move-player)
+
+: ?bounce ( distance-remaining player -- )
+    over 0 > [
+        [ dup nearest-segment>> bounce ]
+        ! [ (move-player) ] ! uncomment when bounce works...
+        [ 2drop ]
+        bi
+    ] [
+        2drop
+    ] if ;
+
+: move-player-distance ( distance-remaining player distance -- distance-remaining player )
+    pick min tuck over go-forward [ - ] dip ;
+
+USE: prettyprint
+USE: io.streams.string
+: (move-player) ( distance-remaining player -- )
+    over 0 <= [
+        2drop
+    ] [
+        dup dup nearest-segment>> distance-to-collision ! [ .s ] with-string-writer jamshred-log
+        move-player-distance ?bounce
+    ] if ;
 
 : move-player ( player -- )
-    dup player-speed over go-forward update-nearest-segment ;
+    [ player-speed ] [ (move-player) ] [ update-nearest-segment ] tri ;
 
 : update-player ( player -- )
-    dup move-player player-nearest-segment
+    dup move-player nearest-segment>>
     white swap set-segment-color ;

extra/jamshred/tunnel/tunnel.factor

@@ -1,23 +1,20 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays float-arrays kernel jamshred.oint math math.functions
+USING: accessors arrays float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors random sequences vectors ;
-math.ranges math.vectors math.constants random sequences vectors ;
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline
 
-TUPLE: segment number color radius ;
+TUPLE: segment < oint number color radius ;
-
+C: <segment> segment
-: <segment> ( number color radius location forward up left -- segment )
-    <oint> >r segment boa r> over set-delegate ;
 
 : segment-vertex ( theta segment -- vertex )
-     tuck 2dup oint-up swap sin v*n
+     tuck 2dup up>> swap sin v*n
-     >r oint-left swap cos v*n r> v+
+     >r left>> swap cos v*n r> v+
-     swap oint-location v+ ;
+     swap location>> v+ ;
 
 : segment-vertex-normal ( vertex segment -- normal )
-    oint-location swap v- normalize ;
+    location>> swap v- normalize ;
 
 : segment-vertex-and-normal ( segment theta -- vertex normal )
     swap [ segment-vertex ] keep dupd segment-vertex-normal ;
@@ -50,15 +47,15 @@ TUPLE: segment number color radius ;
 : default-segment-radius ( -- r ) 1 ;
 
 : initial-segment ( -- segment )
-    0 random-color default-segment-radius
+        F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
-    F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
+        0 random-color default-segment-radius <segment> ;
 
 : random-segments ( n -- segments )
     initial-segment 1vector swap (random-segments) ;
 
 : simple-segment ( n -- segment )
-    random-color default-segment-radius pick F{ 0 0 -1 } n*v
+    [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
-    F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
+    random-color default-segment-radius <segment> ;
 
 : simple-segments ( n -- segments )
     [ simple-segment ] map ;
@@ -111,3 +108,60 @@ TUPLE: segment number color radius ;
 
 : fraction-from-wall ( oint segment -- fraction )
     fraction-from-centre 1 swap - ;
+
+: sideways-heading ( oint segment -- v )
+    [ forward>> ] bi@ proj-perp ;
+
+! : facing-nearest-wall? ( oint segment -- ? )
+!     [ [ location>> ] bi@ distance ]
+!     [ sideways-heading ]
+!     [ [ location>> ] bi@ [ v+ ] dip distance ] tri < ;
+
+! : distance-to-collision ( oint segment -- distance )
+! ! TODO: this isn't right. If oint is facing away from the wall then it should return a much bigger distance...
+!     #! distance on the oint's heading to the segment wall
+!     facing-nearest-wall? [
+!         [ sideways-heading norm ]
+!         [ distance-from-wall ] 2bi swap /
+!     ] [
+!     ] if ;
+
+:: (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..)
+
+:: 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) ] ;
+
+: distance-to-collision ( oint segment -- distance )
+    [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ]
+    [ drop forward>> n*v norm ] 2tri ;
+
+:: (wall-normal) ( seg loc -- n )
+    [let* | back [ loc seg location>> v- ]
+           back-proj [ back seg forward>> proj ]
+           perp-point [ loc back-proj v- ] |
+        perp-point seg location>> v- normalize ] ;
+
+: wall-normal ( segment oint -- n )
+    location>> (wall-normal) ;
+
+: bounce-forward ( segment oint -- )
+    [ wall-normal ] [ swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-up ( oint segment -- )
+    2drop ; ! TODO
+
+: bounce-left ( oint segment -- )
+    2drop ; ! TODO
+
+! : bounce ( oint segment -- )
+!     [ swap bounce-forward ]
+!     [ bounce-up ]
+!     [ bounce-left ] 2tri ;
+
+: bounce ( oint segment -- )
+    drop 0.01 left-pivot ; ! just temporary