From 4171f445a83dfabe893085bc85cc14a8f67e00fe Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 29 May 2008 14:14:18 +1000 Subject: [PATCH 1/2] new jamshred collision model almost working (but buggy as hell) --- extra/jamshred/gl/gl.factor | 33 +++++++- extra/jamshred/oint/oint.factor | 11 ++- extra/jamshred/player/player.factor | 95 ++++++++++++++++------- extra/jamshred/tunnel/tunnel-tests.factor | 2 +- extra/jamshred/tunnel/tunnel.factor | 79 +++++++++---------- 5 files changed, 148 insertions(+), 72 deletions(-) diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index fffc97b4c6..4171c79a0a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types colors jamshred.game jamshred.oint -jamshred.player jamshred.tunnel kernel math math.vectors opengl -opengl.gl opengl.glu sequences ; +USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ; IN: jamshred.gl : min-vertices 6 ; inline @@ -14,6 +12,35 @@ IN: jamshred.gl : n-segments-ahead ( -- n ) 60 ; inline : n-segments-behind ( -- n ) 40 ; inline +: wall-drawing-offset ( -- n ) + #! so that we can't see through the wall, we draw it a bit further away + 0.15 ; + +: wall-drawing-radius ( segment -- r ) + radius>> wall-drawing-offset + ; + +: wall-up ( segment -- v ) + [ wall-drawing-radius ] [ up>> ] bi n*v ; + +: wall-left ( segment -- v ) + [ wall-drawing-radius ] [ left>> ] bi n*v ; + +: segment-vertex ( theta segment -- vertex ) + [ + [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+ + ] [ + location>> v+ + ] bi ; + +: segment-vertex-normal ( vertex segment -- normal ) + location>> swap v- normalize ; + +: segment-vertex-and-normal ( segment theta -- vertex normal ) + swap [ segment-vertex ] keep dupd segment-vertex-normal ; + +: equally-spaced-radians ( n -- seq ) + #! return a sequence of n numbers between 0 and 2pi + dup [ / pi 2 * * ] curry map ; : draw-segment-vertex ( segment theta -- ) over segment-color gl-color segment-vertex-and-normal gl-normal gl-vertex ; diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index d50a93a3d2..7a37646a6d 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -39,8 +39,11 @@ C: oint : random-turn ( oint theta -- ) 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; +: location+ ( v oint -- ) + [ location>> v+ ] [ (>>location) ] bi ; + : go-forward ( distance oint -- ) - [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ; + [ forward>> n*v ] [ location+ ] bi ; : distance-vector ( oint oint -- vector ) [ location>> ] bi@ swap v- ; @@ -62,3 +65,9 @@ C: oint :: reflect ( v n -- v' ) #! bounce v on a surface with normal n v v n v. n n v. / 2 * n n*v v- ; + +: half-way ( p1 p2 -- p3 ) + over v- 2 v/n v+ ; + +: half-way-between-oints ( o1 o2 -- p ) + [ location>> ] bi@ half-way ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 8dc5125143..ccef69a6e4 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ; +USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ; +USE: tools.walker IN: jamshred.player TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; @@ -30,6 +31,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] [ (>>nearest-segment) ] tri ; +: update-time ( player -- seconds-passed ) + millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; + : moved ( player -- ) millis swap (>>last-move) ; : speed-range ( -- range ) @@ -41,38 +45,73 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : multiply-player-speed ( n player -- ) [ * speed-range clamp-to-range ] change-speed drop ; -: distance-to-move ( player -- distance ) - [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ] - [ (>>last-move) ] tri ; +: distance-to-move ( seconds-passed player -- distance ) + speed>> * ; -DEFER: (move-player) +: bounce ( d-left player -- d-left' player ) + { + [ dup nearest-segment>> bounce-off-wall ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ ] + } cleave ; -: ?bounce ( distance-remaining player -- ) +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + player update-nearest-segment + d-left d-to-move - player ] ; + +: (distance) ( player -- segments current location ) + [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ; + +: distance-to-next-segment ( player -- distance ) + [ (distance) ] [ forward>> distance-to-heading-segment ] bi ; + +: distance-to-collision ( player -- distance ) + dup nearest-segment>> (distance-to-collision) ; + +: move-toward-wall ( d-left player d-to-wall -- d-left' player ) + over distance-to-next-segment min + over forward>> move-player-on-heading ; + +: from ( player -- radius distance-from-centre ) + [ nearest-segment>> dup radius>> swap ] [ location>> ] bi + distance-from-centre ; + +: distance-from-wall ( player -- distance ) from - ; +: fraction-from-centre ( player -- fraction ) from swap / ; +: fraction-from-wall ( player -- fraction ) + fraction-from-centre 1 swap - ; + +: ?move-player-freely ( d-left player -- d-left' player ) + ! 2dup [ 0 > ] [ fraction-from-wall 0 > ] bi* and [ over 0 > [ - { - [ dup nearest-segment>> bounce ] - [ sounds>> bang ] - [ 3/4 swap multiply-player-speed ] - [ (move-player) ] - } cleave - ] [ - 2drop - ] if ; + dup distance-to-collision dup 0 > [ + move-toward-wall ?move-player-freely + ] [ drop ] if + ] when ; -: move-player-distance ( distance-remaining player distance -- distance-remaining player ) - pick min tuck over go-forward [ - ] dip ; +: drag-heading ( player -- heading ) + [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; -: (move-player) ( distance-remaining player -- ) - over 0 <= [ - 2drop - ] [ - dup dup nearest-segment>> distance-to-collision - move-player-distance ?bounce - ] if ; +: drag-distance-to-next-segment ( player -- distance ) + [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ; + +: drag-player ( d-left player -- d-left' player ) + dup [ drag-distance-to-next-segment ] + [ drag-heading move-player-on-heading ] bi ; + +: (move-player) ( d-left player -- d-left' player ) + ?move-player-freely over 0 > [ + ! bounce + drag-player + ! (move-player) + ] when ; : move-player ( player -- ) - [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ; + [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; : update-player ( player -- ) - dup move-player nearest-segment>> - white swap set-segment-color ; + [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 903ff94739..722609851a 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -42,4 +42,4 @@ IN: jamshred.tunnel.tests [ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test [ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test [ { 0 1 0 } ] -[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test +[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 5cf1e33e64..24b4b6a386 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; +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 IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline @@ -8,21 +9,6 @@ IN: jamshred.tunnel TUPLE: segment < oint number color radius ; C: segment -: segment-vertex ( theta segment -- vertex ) - tuck 2dup up>> swap sin v*n - >r left>> swap cos v*n r> v+ - swap location>> v+ ; - -: segment-vertex-normal ( vertex segment -- normal ) - location>> swap v- normalize ; - -: segment-vertex-and-normal ( segment theta -- vertex normal ) - swap [ segment-vertex ] keep dupd segment-vertex-normal ; - -: equally-spaced-radians ( n -- seq ) - #! return a sequence of n numbers between 0 and 2pi - dup [ / pi 2 * * ] curry map ; - : segment-number++ ( segment -- ) [ number>> 1+ ] keep (>>number) ; @@ -40,9 +26,7 @@ C: segment : (random-segments) ( segments n -- segments ) dup 0 > [ >r dup peek random-segment over push r> 1- (random-segments) - ] [ - drop - ] if ; + ] [ drop ] if ; : default-segment-radius ( -- r ) 1 ; @@ -66,7 +50,7 @@ C: segment : ( -- segments ) n-segments simple-segments ; -: sub-tunnel ( from to sements -- segments ) +: 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 ; @@ -97,6 +81,30 @@ C: segment [ nearest-segment-forward ] 3keep nearest-segment-backward r> nearer-segment ; +: get-segment ( segments n -- segment ) + over sequence-index-range clamp-to-range swap nth ; + +: next-segment ( segments current-segment -- segment ) + number>> 1+ get-segment ; + +: previous-segment ( segments current-segment -- segment ) + number>> 1- get-segment ; + +: heading-segment ( segments current-segment heading -- segment ) + #! the next segment on the given heading + over forward>> v. 0 <=> { + { +gt+ [ next-segment ] } + { +lt+ [ previous-segment ] } + { +eq+ [ nip ] } ! current segment + } case ; + +:: distance-to-heading-segment ( segments current location heading -- distance ) + #! the distance on the oint's current heading until it enters the next + #! segment's cross-section + [let* | next [ segments current heading heading-segment location>> ] + cf [ current forward>> ] | + cf next v. cf location v. - cf heading v. / ] ; + : vector-to-centre ( seg loc -- v ) over location>> swap v- swap forward>> proj-perp ; @@ -106,19 +114,17 @@ C: segment : wall-normal ( seg oint -- n ) location>> vector-to-centre normalize ; -: from ( seg loc -- radius d-f-c ) - dupd location>> distance-from-centre [ radius>> ] dip ; - -: distance-from-wall ( seg loc -- distance ) from - ; -: fraction-from-centre ( seg loc -- fraction ) from / ; -: fraction-from-wall ( seg loc -- fraction ) - fraction-from-centre 1 swap - ; +: distant ( -- n ) 1000 ; :: collision-coefficient ( v w r -- c ) - [let* | a [ v dup v. ] - b [ v w v. 2 * ] - c [ w dup v. r sq - ] | - c b a quadratic max ] ; + v norm 0 = [ + distant + ] [ + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. r sq - ] | + c b a quadratic max ] + ] if ; : sideways-heading ( oint segment -- v ) [ forward>> ] bi@ proj-perp ; @@ -126,17 +132,12 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; -: bounce-offset 0.1 ; inline - -: bounce-radius ( segment -- r ) - radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?) - : collision-vector ( oint segment -- v ) [ sideways-heading ] [ sideways-relative-location ] - [ bounce-radius ] 2tri + [ radius>> ] 2tri swap [ collision-coefficient ] dip forward>> n*v ; -: distance-to-collision ( oint segment -- distance ) +: (distance-to-collision) ( oint segment -- distance ) collision-vector norm ; : bounce-forward ( segment oint -- ) @@ -151,6 +152,6 @@ C: segment #! must be done after forward and left! nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; -: bounce ( oint segment -- ) +: bounce-off-wall ( oint segment -- ) swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; From ca8685a2669d1e412e41afbcbc2fea226208aa81 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 30 May 2008 17:38:48 +1000 Subject: [PATCH 2/2] jamshred still buggy, but player now 'slides' on the walls instead of bouncing --- extra/jamshred/jamshred.factor | 4 +-- extra/jamshred/player/player.factor | 51 +++++++++++++++++------------ extra/jamshred/tunnel/tunnel.factor | 37 +++++++++++++-------- 3 files changed, 55 insertions(+), 37 deletions(-) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 078a23f5db..b7764894d1 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -88,7 +88,7 @@ jamshred-gadget H{ { T{ mouse-scroll } [ handle-mouse-scroll ] } } set-gestures -: jamshred-window ( -- ) - [ "Jamshred" open-window ] with-ui ; +: jamshred-window ( -- jamshred ) + [ dup "Jamshred" open-window ] with-ui ; MAIN: jamshred-window diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index ccef69a6e4..c40729e35b 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -56,26 +56,20 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; [ ] } cleave ; -:: move-player-on-heading ( d-left player distance heading -- d-left' player ) - [let* | d-to-move [ d-left distance min ] - move-v [ d-to-move heading n*v ] | - move-v player location+ - player update-nearest-segment - d-left d-to-move - player ] ; +:: (distance) ( heading player -- current next location heading ) + player nearest-segment>> + player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment + player location>> heading ; -: (distance) ( player -- segments current location ) - [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ; +: distance-to-heading-segment ( heading player -- distance ) + (distance) distance-to-next-segment ; -: distance-to-next-segment ( player -- distance ) - [ (distance) ] [ forward>> distance-to-heading-segment ] bi ; +: distance-to-heading-segment-area ( heading player -- distance ) + (distance) distance-to-next-segment-area ; : distance-to-collision ( player -- distance ) dup nearest-segment>> (distance-to-collision) ; -: move-toward-wall ( d-left player d-to-wall -- d-left' player ) - over distance-to-next-segment min - over forward>> move-player-on-heading ; - : from ( player -- radius distance-from-centre ) [ nearest-segment>> dup radius>> swap ] [ location>> ] bi distance-from-centre ; @@ -85,10 +79,28 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : fraction-from-wall ( player -- fraction ) fraction-from-centre 1 swap - ; +: update-nearest-segment2 ( heading player -- ) + 2dup distance-to-heading-segment-area 0 <= [ + [ tunnel>> ] [ nearest-segment>> rot heading-segment ] + [ (>>nearest-segment) ] tri + ] [ + 2drop + ] if ; + +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + heading player update-nearest-segment2 + d-left d-to-move - player ] ; + +: move-toward-wall ( d-left player d-to-wall -- d-left' player ) + over [ forward>> ] keep distance-to-heading-segment-area min + over forward>> move-player-on-heading ; + : ?move-player-freely ( d-left player -- d-left' player ) - ! 2dup [ 0 > ] [ fraction-from-wall 0 > ] bi* and [ over 0 > [ - dup distance-to-collision dup 0 > [ + dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2 move-toward-wall ?move-player-freely ] [ drop ] if ] when ; @@ -96,18 +108,15 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : drag-heading ( player -- heading ) [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; -: drag-distance-to-next-segment ( player -- distance ) - [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ; - : drag-player ( d-left player -- d-left' player ) - dup [ drag-distance-to-next-segment ] + dup [ [ drag-heading ] keep distance-to-heading-segment-area ] [ drag-heading move-player-on-heading ] bi ; : (move-player) ( d-left player -- d-left' player ) ?move-player-freely over 0 > [ ! bounce drag-player - ! (move-player) + (move-player) ] when ; : move-player ( player -- ) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 24b4b6a386..99c396bebd 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Alex Chapman +! 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 @@ -98,12 +98,14 @@ C: segment { +eq+ [ nip ] } ! current segment } case ; -:: distance-to-heading-segment ( segments current location heading -- distance ) - #! the distance on the oint's current heading until it enters the next - #! segment's cross-section - [let* | next [ segments current heading heading-segment location>> ] - cf [ current forward>> ] | - cf next v. cf location v. - cf heading v. / ] ; +:: distance-to-next-segment ( current next location heading -- distance ) + [let | cf [ current forward>> ] | + cf next location>> v. cf location v. - cf heading v. / ] ; + +:: distance-to-next-segment-area ( current next location heading -- distance ) + [let | cf [ current forward>> ] + h [ next current half-way-between-oints ] | + cf h v. cf location v. - cf heading v. / ] ; : vector-to-centre ( seg loc -- v ) over location>> swap v- swap forward>> proj-perp ; @@ -116,6 +118,14 @@ C: segment : distant ( -- n ) 1000 ; +: max-real ( a b -- c ) + #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) + dup real? [ + over real? [ max ] [ nip ] if + ] [ + drop dup real? [ drop distant ] unless + ] if ; + :: collision-coefficient ( v w r -- c ) v norm 0 = [ distant @@ -123,7 +133,7 @@ C: segment [let* | a [ v dup v. ] b [ v w v. 2 * ] c [ w dup v. r sq - ] | - c b a quadratic max ] + c b a quadratic max-real ] ] if ; : sideways-heading ( oint segment -- v ) @@ -132,13 +142,12 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; -: collision-vector ( oint segment -- v ) - [ sideways-heading ] [ sideways-relative-location ] - [ radius>> ] 2tri - swap [ collision-coefficient ] dip forward>> n*v ; - : (distance-to-collision) ( oint segment -- distance ) - collision-vector norm ; + [ sideways-heading ] [ sideways-relative-location ] + [ nip radius>> ] 2tri collision-coefficient ; + +: collision-vector ( oint segment -- v ) + dupd (distance-to-collision) swap forward>> n*v ; : bounce-forward ( segment oint -- ) [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;