diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor new file mode 100644 index 0000000000..94905947f7 --- /dev/null +++ b/extra/jamshred/game/game.factor @@ -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 ) + "Player 1" 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 ; diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor new file mode 100644 index 0000000000..ef642fcefd --- /dev/null +++ b/extra/jamshred/gl/gl.factor @@ -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 ; + diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor new file mode 100644 index 0000000000..8243db7e2d --- /dev/null +++ b/extra/jamshred/jamshred.factor @@ -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 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 -- ) + 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" open-window ] with-ui ; + +MAIN: jamshred-window diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor new file mode 100644 index 0000000000..cd566ed221 --- /dev/null +++ b/extra/jamshred/oint/oint.factor @@ -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 ; + +: ( 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 ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor new file mode 100644 index 0000000000..f79edf8bdf --- /dev/null +++ b/extra/jamshred/player/player.factor @@ -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 ; + +: ( name -- player ) + 1 f player construct-boa + { 0 0 5 } { 0 0 -1 } { 0 1 0 } { -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 ; + +: 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 ; + diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor new file mode 100644 index 0000000000..52efe31866 --- /dev/null +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -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 } } 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 + +[ 3 ] [ tunnel-segments 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 diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor new file mode 100644 index 0000000000..9320ea84d3 --- /dev/null +++ b/extra/jamshred/tunnel/tunnel.factor @@ -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 ; + +: ( number color radius location forward up left -- segment ) + >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 } ; + +: 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 } ; + +: simple-segments ( n -- segments ) + [ simple-segment ] map ; + +TUPLE: tunnel segments ; + +C: tunnel + +: ( -- tunnel ) + n-segments random-segments ; + +: ( -- tunnel ) + n-segments simple-segments ; + +: 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 ; + +: 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 find-nearest-segment ; + +: nearest-segment-backward ( segments oint start -- segment ) + swapd 1+ 0 swap rot 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 ; diff --git a/extra/math/ranges/ranges-tests.factor b/extra/math/ranges/ranges-tests.factor index 98a7525910..09416814bd 100644 --- a/extra/math/ranges/ranges-tests.factor +++ b/extra/math/ranges/ranges-tests.factor @@ -21,3 +21,14 @@ IN: temporary [ { 0 1/3 2/3 1 } ] [ 0 1 1/3 >array ] unit-test [ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 >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 diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor index b84773b7d4..83a95c312d 100644 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -38,4 +38,25 @@ INSTANCE: range immutable-sequence : [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) ;