Merge branch 'master' of git://factorcode.org/git/wrunt
Slava Pestov
commit
520fc019cc
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue