Merge branch 'master' of git://factorcode.org/git/wrunt

db4
Slava Pestov 2008-06-05 04:22:30 -05:00
commit 520fc019cc
6 changed files with 171 additions and 77 deletions

View File

@ -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 ;

View File

@ -88,7 +88,7 @@ jamshred-gadget H{
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
} set-gestures
: jamshred-window ( -- )
[ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
: jamshred-window ( -- jamshred )
[ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
MAIN: jamshred-window

View File

@ -39,8 +39,11 @@ C: <oint> 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> 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 ;

View File

@ -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,82 @@ 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 -- )
:: (distance) ( heading player -- current next location heading )
player nearest-segment>>
player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
player location>> heading ;
: distance-to-heading-segment ( heading player -- distance )
(distance) distance-to-next-segment ;
: 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) ;
: 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 - ;
: 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 )
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.2 > [ ! bug! should be 0, not 0.2
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-player ( d-left player -- d-left' player )
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)
] 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 ;

View File

@ -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

View File

@ -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 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
: 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> 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> segment
: <straight-tunnel> ( -- 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 <slice> ;
@ -97,6 +81,32 @@ C: <segment> 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-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 ;
@ -106,19 +116,25 @@ C: <segment> 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 ;
: distant ( -- n ) 1000 ;
: 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 - ;
: 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 )
[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-real ]
] if ;
: sideways-heading ( oint segment -- v )
[ forward>> ] bi@ proj-perp ;
@ -126,18 +142,12 @@ C: <segment> 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?)
: (distance-to-collision) ( oint segment -- distance )
[ sideways-heading ] [ sideways-relative-location ]
[ nip radius>> ] 2tri collision-coefficient ;
: collision-vector ( oint segment -- v )
[ sideways-heading ] [ sideways-relative-location ]
[ bounce-radius ] 2tri
swap [ collision-coefficient ] dip forward>> n*v ;
: distance-to-collision ( oint segment -- distance )
collision-vector norm ;
dupd (distance-to-collision) swap forward>> n*v ;
: bounce-forward ( segment oint -- )
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
@ -151,6 +161,6 @@ C: <segment> 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 ;