! 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
: 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 ;
: 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- ;
:: 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 ;
-! 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 ;
[ 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 )
: 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>> * ;
+
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-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) ( 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) ;
-DEFER: (move-player)
+: move-toward-wall ( d-left player d-to-wall -- d-left' player )
+ over distance-to-next-segment min
+ over forward>> move-player-on-heading ;
-: ?bounce ( distance-remaining player -- )
+: 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 ;
-
-: move-player-distance ( distance-remaining player distance -- distance-remaining player )
- pick min tuck over go-forward [ - ] dip ;
-
-: (move-player) ( distance-remaining player -- )
- over 0 <= [
- 2drop
- ] [
- dup dup nearest-segment>> distance-to-collision
- move-player-distance ?bounce
- ] if ;
+ dup distance-to-collision dup 0 > [
+ move-toward-wall ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: 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 ]
+ [ 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 ;
[ { 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
! 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
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) ;
: (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 ;
: <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> ;
[ 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 ;
: 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 ;
: 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 -- )
#! 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 ;
projects / factor.git / commitdiff