diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 94905947f7..667d81aeb4 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -14,7 +14,7 @@ TUPLE: jamshred tunnel players running ; : jamshred-update ( jamshred -- ) dup jamshred-running [ - dup jamshred-tunnel swap jamshred-player update-player + jamshred-player update-player ] [ drop ] if ; : toggle-running ( jamshred -- ) diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index ef642fcefd..f20d8d2bd8 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -9,8 +9,8 @@ IN: jamshred.gl : n-vertices ( -- n ) 32 ; inline ! render enough of the tunnel that it looks continuous -: n-segments-ahead ( -- n ) 50 ; inline -: n-segments-behind ( -- n ) 50 ; inline +: n-segments-ahead ( -- n ) 60 ; inline +: n-segments-behind ( -- n ) 40 ; inline : draw-segment-vertex ( segment theta -- ) over segment-color gl-color segment-vertex-and-normal @@ -22,15 +22,22 @@ IN: jamshred.gl : draw-segment ( next-segment segment -- ) GL_QUAD_STRIP [ [ draw-vertex-pair ] 2curry - n-vertices equally-spaced-radians { 0.0 } append swap each + n-vertices equally-spaced-radians F{ 0.0 } append swap each ] do-state ; : draw-segments ( segments -- ) 1 over length pick subseq swap [ draw-segment ] 2each ; -: draw-tunnel ( player tunnel -- ) - tuck swap player-nearest-segment segment-number dup n-segments-behind - - swap n-segments-ahead + rot sub-tunnel draw-segments ; +: segments-to-render ( player -- segments ) + dup player-nearest-segment segment-number dup n-segments-behind - + swap n-segments-ahead + rot player-tunnel sub-tunnel ; + +: draw-tunnel ( player -- ) + segments-to-render draw-segments ; + +! : draw-tunnel ( player tunnel -- ) +! tuck swap player-nearest-segment segment-number dup n-segments-behind - +! swap n-segments-ahead + rot sub-tunnel draw-segments ; : init-graphics ( width height -- ) GL_DEPTH_TEST glEnable @@ -39,21 +46,19 @@ IN: jamshred.gl 0.0 0.0 0.0 0.0 glClearColor GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear GL_PROJECTION glMatrixMode glLoadIdentity - ! / >float 45.0 swap 0.1 100.0 gluPerspective - 2drop 45.0 1024 768 / >float 0.1 100.0 gluPerspective + dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if GL_MODELVIEW glMatrixMode glLoadIdentity GL_LEQUAL glDepthFunc GL_LIGHTING glEnable GL_LIGHT0 glEnable GL_FOG glEnable - GL_FOG_DENSITY 0.06 glFogf + GL_FOG_DENSITY 0.09 glFogf GL_COLOR_MATERIAL glEnable GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial - GL_LIGHT0 GL_POSITION { 0.0 0.0 -3.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_AMBIENT { 0.2 0.2 0.2 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_DIFFUSE { 1.0 1.0 1.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_SPECULAR { 1.0 1.0 1.0 1.0 } >c-float-array glLightfv - ; + GL_LIGHT0 GL_POSITION F{ 0.0 0.0 -3.0 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; : player-view ( player -- ) [ oint-location first3 ] keep @@ -61,6 +66,5 @@ IN: jamshred.gl oint-up first3 gluLookAt ; : draw-jamshred ( jamshred width height -- ) - init-graphics dup jamshred-player dup player-view - swap jamshred-tunnel draw-tunnel ; + init-graphics jamshred-player dup player-view draw-tunnel ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 8243db7e2d..36dd0619f0 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -29,7 +29,7 @@ M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ; swap set-jamshred-gadget-jamshred ; : pix>radians ( n m -- theta ) - 2 / / pi * ; + 2 / / pi 2 * * ; : x>radians ( x gadget -- theta ) #! translate motion of x pixels to an angle diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index cd566ed221..254be2057a 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,4 +1,4 @@ -USING: arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; +USING: arrays float-arrays kernel 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 @@ -16,9 +16,9 @@ TUPLE: oint location forward up left ; ! #! { { 1 0 0 } ! #! { 0 cos(theta) sin(theta) } ! #! { 0 -sin(theta) cos(theta) } } -! dup sin neg swap cos 2dup 0 -rot 3array >r -! swap neg 0 -rot 3array >r -! { 1 0 0 } r> r> 3array ; +! 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: @@ -26,9 +26,9 @@ TUPLE: oint location forward up left ; ! #! { 0 1 0 } ! #! { sin(theta) 0 cos(theta) } } ! dup sin swap cos 2dup -! 0 swap 3array >r +! 0 swap 3float-array >r ! { 0 1 0 } >r -! 0 rot neg 3array r> r> 3array ; +! 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 @@ -59,5 +59,16 @@ TUPLE: oint location forward up left ; : go-forward ( distance oint -- ) tuck oint-forward n*v over oint-location v+ swap set-oint-location ; +: distance-vector ( oint oint -- vector ) + oint-location swap oint-location v- ; + : distance ( oint oint -- distance ) - oint-location swap oint-location v- norm ; + distance-vector norm ; + +: scalar-projection ( v1 v2 -- n ) + #! the scalar projection of v1 onto v2 + tuck v. swap norm / ; + +: perpendicular-distance ( oint oint -- distance ) + tuck distance-vector swap 2dup oint-left scalar-projection abs + -rot oint-up scalar-projection abs + ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index f79edf8bdf..ddbd03eeb9 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,25 +1,36 @@ USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel -math.constants sequences ; +math math.constants sequences ; IN: jamshred.player -TUPLE: player name speed last-segment ; +TUPLE: player name tunnel nearest-segment ; : ( name -- player ) - 1 f player construct-boa - { 0 0 5 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } over set-delegate ; + f f player construct-boa + F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } over set-delegate ; : turn-player ( player x-radians y-radians -- ) >r over r> left-pivot up-pivot ; -: play-in-tunnel ( player tunnel -- ) - tunnel-segments first dup oint-location pick set-oint-location - swap set-player-last-segment ; +: to-tunnel-start ( player -- ) + dup player-tunnel first dup oint-location pick set-oint-location + swap set-player-nearest-segment ; -: player-nearest-segment ( tunnel player -- segment ) - [ - dup player-last-segment nearest-segment - ] keep dupd set-player-last-segment ; +: play-in-tunnel ( player segments -- ) + over set-player-tunnel to-tunnel-start ; -: update-player ( tunnel player -- ) - 0.1 over go-forward player-nearest-segment white swap set-segment-color ; +: update-nearest-segment ( player -- ) + dup player-tunnel over dup player-nearest-segment nearest-segment + swap set-player-nearest-segment ; +: max-speed ( -- speed ) + 0.3 ; + +: player-speed ( player -- speed ) + dup player-nearest-segment fraction-from-wall sq max-speed * ; + +: move-player ( player -- ) + dup player-speed over go-forward update-nearest-segment ; + +: update-player ( player -- ) + dup move-player player-nearest-segment + white swap set-segment-color ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 52efe31866..e78ced83e0 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -6,10 +6,10 @@ IN: temporary T{ oint f { 0 0 0.25 } } nearer-segment segment-number ] unit-test -[ 0 ] [ T{ oint f { 0 0 0 } } tunnel-segments find-nearest-segment segment-number ] unit-test -[ 1 ] [ T{ oint f { 0 0 -1 } } tunnel-segments find-nearest-segment segment-number ] unit-test -[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } tunnel-segments find-nearest-segment segment-number ] unit-test +[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment segment-number ] unit-test +[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment segment-number ] unit-test +[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment segment-number ] unit-test -[ 3 ] [ tunnel-segments T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test +[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test -[ { 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over tunnel-segments first nearest-segment oint-location ] unit-test +[ { 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 9320ea84d3..149170eb53 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,5 +1,5 @@ -USING: arrays kernel jamshred.oint math math.functions math.ranges math.vectors -math.constants random sequences vectors ; +USING: arrays float-arrays kernel jamshred.oint math math.functions +math.ranges math.vectors math.constants random sequences vectors ; IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline @@ -30,8 +30,8 @@ TUPLE: segment number color radius ; : random-color ( -- color ) { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ; -: tunnel-segment-distance ( -- n ) 0.5 ; -: random-rotation-angle ( -- theta ) pi 6 / ; +: tunnel-segment-distance ( -- n ) 0.4 ; +: random-rotation-angle ( -- theta ) pi 20 / ; : random-segment ( previous-segment -- segment ) clone dup random-rotation-angle random-turn @@ -49,34 +49,28 @@ TUPLE: segment number color radius ; : initial-segment ( -- segment ) 0 random-color default-segment-radius - { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; + F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ; : random-segments ( n -- segments ) initial-segment 1vector swap (random-segments) ; : simple-segment ( n -- segment ) - random-color default-segment-radius pick { 0 0 -1 } n*v - { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; + random-color default-segment-radius pick F{ 0 0 -1 } n*v + F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ; : simple-segments ( n -- segments ) [ simple-segment ] map ; -TUPLE: tunnel segments ; +: ( -- segments ) + n-segments random-segments ; -C: tunnel +: ( -- segments ) + n-segments simple-segments ; -: ( -- tunnel ) - n-segments random-segments ; - -: ( -- tunnel ) - n-segments simple-segments ; - -: sub-tunnel ( from to tunnel -- segments ) +: sub-tunnel ( from to sements -- segments ) #! return segments between from and to, after clamping from and to to #! valid values - tunnel-segments [ - sequence-index-range [ clamp-to-range ] curry 2apply - ] keep ; + [ sequence-index-range [ clamp-to-range ] curry 2apply ] keep ; : nearer-segment ( segment segment oint -- segment ) #! return whichever of the two segments is nearer to the oint @@ -97,10 +91,21 @@ C: tunnel : nearest-segment-backward ( segments oint start -- segment ) swapd 1+ 0 swap rot find-nearest-segment ; -: nearest-segment ( tunnel oint start-segment -- segment ) +: nearest-segment ( segments oint start-segment -- segment ) #! find the segment nearest to 'oint', and return it. #! start looking at segment 'start-segment' segment-number over >r - >r >r tunnel-segments r> r> [ nearest-segment-forward ] 3keep nearest-segment-backward r> nearer-segment ; + +: distance-from-centre ( oint segment -- distance ) + perpendicular-distance ; + +: distance-from-wall ( oint segment -- distance ) + tuck distance-from-centre swap segment-radius swap - ; + +: fraction-from-centre ( oint segment -- fraction ) + tuck distance-from-centre swap segment-radius / ; + +: fraction-from-wall ( oint segment -- fraction ) + fraction-from-centre 1 swap - ;