Merge commit 'wrunt/master'
Slava Pestov
commit
d4a241d35b
|
|
@ -0,0 +1,24 @@
|
||||||
|
USING: kernel opengl arrays sequences jamshred jamshred.tunnel
|
||||||
|
jamshred.player math.vectors ;
|
||||||
|
IN: jamshred.game
|
||||||
|
|
||||||
|
TUPLE: jamshred tunnel players running ;
|
||||||
|
|
||||||
|
: <jamshred> ( -- jamshred )
|
||||||
|
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
|
||||||
|
jamshred construct-boa ;
|
||||||
|
|
||||||
|
: jamshred-player ( jamshred -- player )
|
||||||
|
! TODO: support more than one player
|
||||||
|
jamshred-players first ;
|
||||||
|
|
||||||
|
: jamshred-update ( jamshred -- )
|
||||||
|
dup jamshred-running [
|
||||||
|
dup jamshred-tunnel swap jamshred-player update-player
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
: toggle-running ( jamshred -- )
|
||||||
|
dup jamshred-running not swap set-jamshred-running ;
|
||||||
|
|
||||||
|
: mouse-moved ( x-radians y-radians jamshred -- )
|
||||||
|
jamshred-player -rot turn-player ;
|
||||||
|
|
@ -0,0 +1,66 @@
|
||||||
|
USING: alien.c-types colors jamshred.game jamshred.oint
|
||||||
|
jamshred.player jamshred.tunnel kernel math math.vectors opengl
|
||||||
|
opengl.gl opengl.glu sequences ;
|
||||||
|
IN: jamshred.gl
|
||||||
|
|
||||||
|
: min-vertices 6 ; inline
|
||||||
|
: max-vertices 32 ; inline
|
||||||
|
|
||||||
|
: 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
|
||||||
|
|
||||||
|
: draw-segment-vertex ( segment theta -- )
|
||||||
|
over segment-color gl-color segment-vertex-and-normal
|
||||||
|
first3 glNormal3d first3 glVertex3d ;
|
||||||
|
|
||||||
|
: draw-vertex-pair ( theta next-segment segment -- )
|
||||||
|
rot tuck draw-segment-vertex draw-segment-vertex ;
|
||||||
|
|
||||||
|
: draw-segment ( next-segment segment -- )
|
||||||
|
GL_QUAD_STRIP [
|
||||||
|
[ draw-vertex-pair ] 2curry
|
||||||
|
n-vertices equally-spaced-radians { 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 ;
|
||||||
|
|
||||||
|
: init-graphics ( width height -- )
|
||||||
|
GL_DEPTH_TEST glEnable
|
||||||
|
GL_SCISSOR_TEST glDisable
|
||||||
|
1.0 glClearDepth
|
||||||
|
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
|
||||||
|
GL_MODELVIEW glMatrixMode glLoadIdentity
|
||||||
|
GL_LEQUAL glDepthFunc
|
||||||
|
GL_LIGHTING glEnable
|
||||||
|
GL_LIGHT0 glEnable
|
||||||
|
GL_FOG glEnable
|
||||||
|
GL_FOG_DENSITY 0.06 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
|
||||||
|
;
|
||||||
|
|
||||||
|
: player-view ( player -- )
|
||||||
|
[ oint-location first3 ] keep
|
||||||
|
[ dup oint-location swap oint-forward v+ first3 ] keep
|
||||||
|
oint-up first3 gluLookAt ;
|
||||||
|
|
||||||
|
: draw-jamshred ( jamshred width height -- )
|
||||||
|
init-graphics dup jamshred-player dup player-view
|
||||||
|
swap jamshred-tunnel draw-tunnel ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,64 @@
|
||||||
|
USING: arrays jamshred.game jamshred.gl kernel math math.constants
|
||||||
|
namespaces sequences timers ui ui.gadgets ui.gestures ui.render
|
||||||
|
math.vectors ;
|
||||||
|
IN: jamshred
|
||||||
|
|
||||||
|
TUPLE: jamshred-gadget jamshred last-hand-loc ;
|
||||||
|
|
||||||
|
: <jamshred-gadget> ( jamshred -- gadget )
|
||||||
|
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
|
||||||
|
|
||||||
|
: default-width ( -- x ) 1024 ;
|
||||||
|
: default-height ( -- y ) 768 ;
|
||||||
|
|
||||||
|
M: jamshred-gadget pref-dim*
|
||||||
|
drop default-width default-height 2array ;
|
||||||
|
|
||||||
|
M: jamshred-gadget draw-gadget* ( gadget -- )
|
||||||
|
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
|
||||||
|
|
||||||
|
M: jamshred-gadget tick ( gadget -- )
|
||||||
|
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
|
||||||
|
|
||||||
|
M: jamshred-gadget graft* ( gadget -- )
|
||||||
|
10 1 add-timer ;
|
||||||
|
|
||||||
|
M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ;
|
||||||
|
|
||||||
|
: jamshred-restart ( jamshred-gadget -- )
|
||||||
|
<jamshred> swap set-jamshred-gadget-jamshred ;
|
||||||
|
|
||||||
|
: pix>radians ( n m -- theta )
|
||||||
|
2 / / pi * ;
|
||||||
|
|
||||||
|
: x>radians ( x gadget -- theta )
|
||||||
|
#! translate motion of x pixels to an angle
|
||||||
|
rect-dim first pix>radians neg ;
|
||||||
|
|
||||||
|
: y>radians ( y gadget -- theta )
|
||||||
|
#! translate motion of y pixels to an angle
|
||||||
|
rect-dim second pix>radians ;
|
||||||
|
|
||||||
|
: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
|
||||||
|
over jamshred-gadget-jamshred >r
|
||||||
|
[ first swap x>radians ] 2keep second swap y>radians
|
||||||
|
r> mouse-moved ;
|
||||||
|
|
||||||
|
: handle-mouse-motion ( jamshred-gadget -- )
|
||||||
|
hand-loc get [
|
||||||
|
over jamshred-gadget-last-hand-loc [
|
||||||
|
v- (handle-mouse-motion)
|
||||||
|
] [ 2drop ] if*
|
||||||
|
] 2keep swap set-jamshred-gadget-last-hand-loc ;
|
||||||
|
|
||||||
|
USE: vocabs.loader
|
||||||
|
jamshred-gadget H{
|
||||||
|
{ T{ key-down f f "r" } [ jamshred-restart refresh-all ] }
|
||||||
|
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
|
||||||
|
{ T{ motion } [ handle-mouse-motion ] }
|
||||||
|
} set-gestures
|
||||||
|
|
||||||
|
: jamshred-window ( -- )
|
||||||
|
[ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
|
||||||
|
|
||||||
|
MAIN: jamshred-window
|
||||||
|
|
@ -0,0 +1,63 @@
|
||||||
|
USING: 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
|
||||||
|
! given relative to that point. In jamshred a player's location and
|
||||||
|
! direction are given by the player's oint. Similarly, a tunnel
|
||||||
|
! segment's location and orientation are given by an oint.
|
||||||
|
|
||||||
|
TUPLE: oint location forward up left ;
|
||||||
|
|
||||||
|
: <oint> ( location forward up left -- oint )
|
||||||
|
oint construct-boa ;
|
||||||
|
|
||||||
|
! : x-rotation ( theta -- matrix )
|
||||||
|
! #! construct this matrix:
|
||||||
|
! #! { { 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 ;
|
||||||
|
!
|
||||||
|
! : y-rotation ( theta -- matrix )
|
||||||
|
! #! costruct this matrix:
|
||||||
|
! #! { { cos(theta) 0 -sin(theta) }
|
||||||
|
! #! { 0 1 0 }
|
||||||
|
! #! { sin(theta) 0 cos(theta) } }
|
||||||
|
! dup sin swap cos 2dup
|
||||||
|
! 0 swap 3array >r
|
||||||
|
! { 0 1 0 } >r
|
||||||
|
! 0 rot neg 3array r> r> 3array ;
|
||||||
|
|
||||||
|
: apply-to-oint ( oint quot -- )
|
||||||
|
#! apply quot to each of forward, up, and left, storing the results
|
||||||
|
over oint-forward over call pick set-oint-forward
|
||||||
|
over oint-up over call pick set-oint-up
|
||||||
|
over oint-left swap call swap set-oint-left ;
|
||||||
|
|
||||||
|
: rotation-quaternion ( theta axis -- quaternion )
|
||||||
|
swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
|
||||||
|
|
||||||
|
: rotate-oint ( oint theta axis -- )
|
||||||
|
rotation-quaternion dup qrecip
|
||||||
|
[ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
|
||||||
|
|
||||||
|
: left-pivot ( oint theta -- )
|
||||||
|
over oint-left rotate-oint ;
|
||||||
|
|
||||||
|
: up-pivot ( oint theta -- )
|
||||||
|
over oint-up rotate-oint ;
|
||||||
|
|
||||||
|
: random-float+- ( n -- m )
|
||||||
|
#! find a random float between -n/2 and n/2
|
||||||
|
dup 10000 * >fixnum random 10000 / swap 2 / - ;
|
||||||
|
|
||||||
|
: random-turn ( oint theta -- )
|
||||||
|
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
|
||||||
|
|
||||||
|
: go-forward ( distance oint -- )
|
||||||
|
tuck oint-forward n*v over oint-location v+ swap set-oint-location ;
|
||||||
|
|
||||||
|
: distance ( oint oint -- distance )
|
||||||
|
oint-location swap oint-location v- norm ;
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel
|
||||||
|
math.constants sequences ;
|
||||||
|
IN: jamshred.player
|
||||||
|
|
||||||
|
TUPLE: player name speed last-segment ;
|
||||||
|
|
||||||
|
: <player> ( name -- player )
|
||||||
|
1 f player construct-boa
|
||||||
|
{ 0 0 5 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> 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 ;
|
||||||
|
|
||||||
|
: player-nearest-segment ( tunnel player -- segment )
|
||||||
|
[
|
||||||
|
dup player-last-segment nearest-segment
|
||||||
|
] keep dupd set-player-last-segment ;
|
||||||
|
|
||||||
|
: update-player ( tunnel player -- )
|
||||||
|
0.1 over go-forward player-nearest-segment white swap set-segment-color ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
|
||||||
|
IN: temporary
|
||||||
|
|
||||||
|
[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
|
||||||
|
T{ segment T{ oint f { 1 1 1 } } 1 }
|
||||||
|
T{ oint f { 0 0 0.25 } }
|
||||||
|
nearer-segment segment-number ] unit-test
|
||||||
|
|
||||||
|
[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> tunnel-segments find-nearest-segment segment-number ] unit-test
|
||||||
|
[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> tunnel-segments find-nearest-segment segment-number ] unit-test
|
||||||
|
[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> tunnel-segments find-nearest-segment segment-number ] unit-test
|
||||||
|
|
||||||
|
[ 3 ] [ <straight-tunnel> tunnel-segments T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
|
||||||
|
|
||||||
|
[ { 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over tunnel-segments first nearest-segment oint-location ] unit-test
|
||||||
|
|
@ -0,0 +1,106 @@
|
||||||
|
USING: arrays kernel jamshred.oint math math.functions math.ranges math.vectors
|
||||||
|
math.constants random sequences vectors ;
|
||||||
|
IN: jamshred.tunnel
|
||||||
|
|
||||||
|
: n-segments ( -- n ) 5000 ; inline
|
||||||
|
|
||||||
|
TUPLE: segment number color radius ;
|
||||||
|
|
||||||
|
: <segment> ( number color radius location forward up left -- segment )
|
||||||
|
<oint> >r segment construct-boa r> over set-delegate ;
|
||||||
|
|
||||||
|
: segment-vertex ( theta segment -- vertex )
|
||||||
|
tuck 2dup oint-up swap sin v*n
|
||||||
|
>r oint-left swap cos v*n r> v+
|
||||||
|
swap oint-location v+ ;
|
||||||
|
|
||||||
|
: segment-vertex-normal ( vertex segment -- normal )
|
||||||
|
oint-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 -- )
|
||||||
|
dup segment-number 1+ swap set-segment-number ;
|
||||||
|
|
||||||
|
: 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 / ;
|
||||||
|
|
||||||
|
: random-segment ( previous-segment -- segment )
|
||||||
|
clone dup random-rotation-angle random-turn
|
||||||
|
tunnel-segment-distance over go-forward
|
||||||
|
random-color over set-segment-color dup segment-number++ ;
|
||||||
|
|
||||||
|
: (random-segments) ( segments n -- segments )
|
||||||
|
dup 0 > [
|
||||||
|
>r dup peek random-segment over push r> 1- (random-segments)
|
||||||
|
] [
|
||||||
|
drop
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: default-segment-radius ( -- r ) 1 ;
|
||||||
|
|
||||||
|
: initial-segment ( -- segment )
|
||||||
|
0 random-color default-segment-radius
|
||||||
|
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <segment> ;
|
||||||
|
|
||||||
|
: 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 } <segment> ;
|
||||||
|
|
||||||
|
: simple-segments ( n -- segments )
|
||||||
|
[ simple-segment ] map ;
|
||||||
|
|
||||||
|
TUPLE: tunnel segments ;
|
||||||
|
|
||||||
|
C: <tunnel> tunnel
|
||||||
|
|
||||||
|
: <random-tunnel> ( -- tunnel )
|
||||||
|
n-segments random-segments <tunnel> ;
|
||||||
|
|
||||||
|
: <straight-tunnel> ( -- tunnel )
|
||||||
|
n-segments simple-segments <tunnel> ;
|
||||||
|
|
||||||
|
: sub-tunnel ( from to tunnel -- 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 <slice> ;
|
||||||
|
|
||||||
|
: nearer-segment ( segment segment oint -- segment )
|
||||||
|
#! return whichever of the two segments is nearer to the oint
|
||||||
|
>r 2dup r> tuck distance >r distance r> < -rot ? ;
|
||||||
|
|
||||||
|
: (find-nearest-segment) ( nearest next oint -- nearest ? )
|
||||||
|
#! find the nearest of 'next' and 'nearest' to 'oint', and return
|
||||||
|
#! t if the nearest hasn't changed
|
||||||
|
pick >r nearer-segment dup r> = ;
|
||||||
|
|
||||||
|
: find-nearest-segment ( oint segments -- segment )
|
||||||
|
dup first swap 1 tail-slice rot [ (find-nearest-segment) ] curry
|
||||||
|
find 2drop ;
|
||||||
|
|
||||||
|
: nearest-segment-forward ( segments oint start -- segment )
|
||||||
|
rot dup length swap <slice> find-nearest-segment ;
|
||||||
|
|
||||||
|
: nearest-segment-backward ( segments oint start -- segment )
|
||||||
|
swapd 1+ 0 swap rot <slice> <reversed> find-nearest-segment ;
|
||||||
|
|
||||||
|
: nearest-segment ( tunnel 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 ;
|
||||||
|
|
@ -21,3 +21,14 @@ IN: temporary
|
||||||
|
|
||||||
[ { 0 1/3 2/3 1 } ] [ 0 1 1/3 <range> >array ] unit-test
|
[ { 0 1/3 2/3 1 } ] [ 0 1 1/3 <range> >array ] unit-test
|
||||||
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >array reverse ] unit-test
|
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >array reverse ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ 5 [0,b] range-increasing? ] unit-test
|
||||||
|
[ f ] [ 5 [0,b] range-decreasing? ] unit-test
|
||||||
|
[ f ] [ -5 [0,b] range-increasing? ] unit-test
|
||||||
|
[ t ] [ -5 [0,b] range-decreasing? ] unit-test
|
||||||
|
[ 0 ] [ 5 [0,b] range-min ] unit-test
|
||||||
|
[ 5 ] [ 5 [0,b] range-max ] unit-test
|
||||||
|
[ 3 ] [ 3 5 [0,b] clamp-to-range ] unit-test
|
||||||
|
[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test
|
||||||
|
[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test
|
||||||
|
[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -38,4 +38,25 @@ INSTANCE: range immutable-sequence
|
||||||
|
|
||||||
: [1,b] 1 swap [a,b] ;
|
: [1,b] 1 swap [a,b] ;
|
||||||
|
|
||||||
: [0,b) 0 swap (a,b] ;
|
: [0,b) 0 swap [a,b) ;
|
||||||
|
|
||||||
|
: range-increasing? ( range -- ? )
|
||||||
|
range-step 0 > ;
|
||||||
|
|
||||||
|
: range-decreasing? ( range -- ? )
|
||||||
|
range-step 0 < ;
|
||||||
|
|
||||||
|
: first-or-peek ( seq head? -- elt )
|
||||||
|
[ first ] [ peek ] if ;
|
||||||
|
|
||||||
|
: range-min ( range -- min )
|
||||||
|
dup range-increasing? first-or-peek ;
|
||||||
|
|
||||||
|
: range-max ( range -- max )
|
||||||
|
dup range-decreasing? first-or-peek ;
|
||||||
|
|
||||||
|
: clamp-to-range ( n range -- n )
|
||||||
|
tuck range-min max swap range-max min ;
|
||||||
|
|
||||||
|
: sequence-index-range ( seq -- range )
|
||||||
|
length [0,b) ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue