Merge branch 'master' into maintenance
Alex Chapman
commit
205a293417
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Jamshred" }
|
||||
}
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
|
||||
IN: jamshred.game
|
||||
|
||||
TUPLE: jamshred sounds tunnel players running quit ;
|
||||
|
||||
: <jamshred> ( -- jamshred )
|
||||
<sounds> <random-tunnel> "Player 1" pick <player>
|
||||
2dup swap play-in-tunnel 1array f f jamshred boa ;
|
||||
|
||||
: jamshred-player ( jamshred -- player )
|
||||
! TODO: support more than one player
|
||||
players>> first ;
|
||||
|
||||
: jamshred-update ( jamshred -- )
|
||||
dup running>> [
|
||||
jamshred-player update-player
|
||||
] [ drop ] if ;
|
||||
|
||||
: toggle-running ( jamshred -- )
|
||||
dup running>> [
|
||||
f >>running drop
|
||||
] [
|
||||
[ jamshred-player moved ]
|
||||
[ t >>running drop ] bi
|
||||
] if ;
|
||||
|
||||
: mouse-moved ( x-radians y-radians jamshred -- )
|
||||
jamshred-player -rot turn-player ;
|
||||
|
||||
: units-per-full-roll ( -- n ) 50 ;
|
||||
|
||||
: jamshred-roll ( jamshred n -- )
|
||||
[ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
|
||||
|
||||
: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
|
||||
|
||||
: mouse-scroll-y ( jamshred y -- )
|
||||
neg swap jamshred-player change-player-speed ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -0,0 +1,99 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types jamshred.game jamshred.oint
|
||||
jamshred.player jamshred.tunnel kernel math math.constants
|
||||
math.functions math.vectors opengl opengl.gl opengl.glu
|
||||
opengl.demo-support sequences specialized-arrays.float ;
|
||||
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 ) 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 color>> gl-color segment-vertex-and-normal
|
||||
gl-normal gl-vertex ;
|
||||
|
||||
: 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 F{ 0.0 } append swap each
|
||||
] do-state ;
|
||||
|
||||
: draw-segments ( segments -- )
|
||||
1 over length pick subseq swap [ draw-segment ] 2each ;
|
||||
|
||||
: segments-to-render ( player -- segments )
|
||||
dup nearest-segment>> number>> dup n-segments-behind -
|
||||
swap n-segments-ahead + rot tunnel>> sub-tunnel ;
|
||||
|
||||
: draw-tunnel ( player -- )
|
||||
segments-to-render 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
|
||||
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.09 glFogf
|
||||
GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
|
||||
GL_COLOR_MATERIAL glEnable
|
||||
GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
|
||||
GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
|
||||
GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
|
||||
GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
|
||||
|
||||
: player-view ( player -- )
|
||||
[ location>> ]
|
||||
[ [ location>> ] [ forward>> ] bi v+ ]
|
||||
[ up>> ] tri gl-look-at ;
|
||||
|
||||
: draw-jamshred ( jamshred width height -- )
|
||||
init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
|
||||
|
||||
|
|
@ -0,0 +1,94 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
|
||||
IN: jamshred
|
||||
|
||||
TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
|
||||
|
||||
: <jamshred-gadget> ( jamshred -- gadget )
|
||||
jamshred-gadget new-gadget swap >>jamshred ;
|
||||
|
||||
: default-width ( -- x ) 800 ;
|
||||
: default-height ( -- y ) 600 ;
|
||||
|
||||
M: jamshred-gadget pref-dim*
|
||||
drop default-width default-height 2array ;
|
||||
|
||||
M: jamshred-gadget draw-gadget* ( gadget -- )
|
||||
[ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
|
||||
|
||||
: jamshred-loop ( gadget -- )
|
||||
dup jamshred>> quit>> [
|
||||
drop
|
||||
] [
|
||||
[ jamshred>> jamshred-update ]
|
||||
[ relayout-1 ]
|
||||
[ 10 milliseconds sleep yield jamshred-loop ] tri
|
||||
] if ;
|
||||
|
||||
: fullscreen ( gadget -- )
|
||||
find-world t swap set-fullscreen* ;
|
||||
|
||||
: no-fullscreen ( gadget -- )
|
||||
find-world f swap set-fullscreen* ;
|
||||
|
||||
: toggle-fullscreen ( world -- )
|
||||
[ fullscreen? not ] keep set-fullscreen* ;
|
||||
|
||||
M: jamshred-gadget graft* ( gadget -- )
|
||||
[ jamshred-loop ] curry in-thread ;
|
||||
|
||||
M: jamshred-gadget ungraft* ( gadget -- )
|
||||
jamshred>> t swap (>>quit) ;
|
||||
|
||||
: jamshred-restart ( jamshred-gadget -- )
|
||||
<jamshred> >>jamshred drop ;
|
||||
|
||||
: pix>radians ( n m -- theta )
|
||||
/ pi 4 * * ; ! 2 / / pi 2 * * ;
|
||||
|
||||
: 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>> >r
|
||||
[ first swap x>radians ] 2keep second swap y>radians
|
||||
r> mouse-moved ;
|
||||
|
||||
: handle-mouse-motion ( jamshred-gadget -- )
|
||||
hand-loc get [
|
||||
over last-hand-loc>> [
|
||||
v- (handle-mouse-motion)
|
||||
] [ 2drop ] if*
|
||||
] 2keep >>last-hand-loc drop ;
|
||||
|
||||
: handle-mouse-scroll ( jamshred-gadget -- )
|
||||
jamshred>> scroll-direction get
|
||||
[ first mouse-scroll-x ]
|
||||
[ second mouse-scroll-y ] 2bi ;
|
||||
|
||||
: quit ( gadget -- )
|
||||
[ no-fullscreen ] [ close-window ] bi ;
|
||||
|
||||
jamshred-gadget H{
|
||||
{ T{ key-down f f "r" } [ jamshred-restart ] }
|
||||
{ T{ key-down f f " " } [ jamshred>> toggle-running ] }
|
||||
{ T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
|
||||
{ T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
|
||||
{ T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
|
||||
{ T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
|
||||
{ T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
|
||||
{ T{ key-down f f "q" } [ quit ] }
|
||||
{ T{ motion } [ handle-mouse-motion ] }
|
||||
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: jamshred-window ( -- gadget )
|
||||
[ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
|
||||
|
||||
MAIN: jamshred-window
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
USING: kernel logging ;
|
||||
IN: jamshred.log
|
||||
|
||||
LOG: (jamshred-log) DEBUG
|
||||
|
||||
: with-jamshred-log ( quot -- )
|
||||
"jamshred" swap with-logging ;
|
||||
|
||||
: jamshred-log ( message -- )
|
||||
[ (jamshred-log) ] with-jamshred-log ; ! ugly...
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
USING: jamshred.oint tools.test ;
|
||||
IN: jamshred.oint-tests
|
||||
|
||||
[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
|
||||
[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
|
||||
[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
|
||||
[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
|
||||
[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays float-arrays kernel locals 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 ;
|
||||
C: <oint> oint
|
||||
|
||||
: rotation-quaternion ( theta axis -- quaternion )
|
||||
swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
|
||||
|
||||
: rotate-vector ( q qrecip v -- v )
|
||||
v>q swap q* q* q>v ;
|
||||
|
||||
: rotate-oint ( oint theta axis -- )
|
||||
rotation-quaternion dup qrecip pick
|
||||
[ forward>> rotate-vector >>forward ]
|
||||
[ up>> rotate-vector >>up ]
|
||||
[ left>> rotate-vector >>left ] 3tri drop ;
|
||||
|
||||
: left-pivot ( oint theta -- )
|
||||
over left>> rotate-oint ;
|
||||
|
||||
: up-pivot ( oint theta -- )
|
||||
over up>> rotate-oint ;
|
||||
|
||||
: forward-pivot ( oint theta -- )
|
||||
over forward>> 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 ;
|
||||
|
||||
: location+ ( v oint -- )
|
||||
[ location>> v+ ] [ (>>location) ] bi ;
|
||||
|
||||
: go-forward ( distance oint -- )
|
||||
[ forward>> n*v ] [ location+ ] bi ;
|
||||
|
||||
: distance-vector ( oint oint -- vector )
|
||||
[ location>> ] bi@ swap v- ;
|
||||
|
||||
: distance ( oint oint -- distance )
|
||||
distance-vector norm ;
|
||||
|
||||
: scalar-projection ( v1 v2 -- n )
|
||||
#! the scalar projection of v1 onto v2
|
||||
tuck v. swap norm / ;
|
||||
|
||||
: proj-perp ( u v -- w )
|
||||
dupd proj v- ;
|
||||
|
||||
: perpendicular-distance ( oint oint -- distance )
|
||||
tuck distance-vector swap 2dup left>> scalar-projection abs
|
||||
-rot up>> scalar-projection abs + ;
|
||||
|
||||
:: 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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -0,0 +1,137 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ;
|
||||
IN: jamshred.player
|
||||
|
||||
TUPLE: player < oint
|
||||
{ name string }
|
||||
{ sounds sounds }
|
||||
tunnel
|
||||
nearest-segment
|
||||
{ last-move integer }
|
||||
{ speed float } ;
|
||||
|
||||
! speeds are in GL units / second
|
||||
: default-speed ( -- speed ) 1.0 ;
|
||||
: max-speed ( -- speed ) 30.0 ;
|
||||
|
||||
: <player> ( name sounds -- player )
|
||||
[ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
|
||||
f f 0 default-speed player boa ;
|
||||
|
||||
: turn-player ( player x-radians y-radians -- )
|
||||
>r over r> left-pivot up-pivot ;
|
||||
|
||||
: roll-player ( player z-radians -- )
|
||||
forward-pivot ;
|
||||
|
||||
: to-tunnel-start ( player -- )
|
||||
[ tunnel>> first dup location>> ]
|
||||
[ tuck (>>location) (>>nearest-segment) ] bi ;
|
||||
|
||||
: play-in-tunnel ( player segments -- )
|
||||
>>tunnel to-tunnel-start ;
|
||||
|
||||
: update-nearest-segment ( player -- )
|
||||
[ 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 )
|
||||
max-speed [0,b] ;
|
||||
|
||||
: change-player-speed ( inc player -- )
|
||||
[ + speed-range clamp-to-range ] change-speed drop ;
|
||||
|
||||
: multiply-player-speed ( n player -- )
|
||||
[ * speed-range clamp-to-range ] change-speed drop ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
:: (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) ;
|
||||
|
||||
: almost-to-collision ( player -- distance )
|
||||
distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
|
||||
|
||||
: 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 ] ;
|
||||
|
||||
: distance-to-move-freely ( player -- distance )
|
||||
[ almost-to-collision ]
|
||||
[ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
|
||||
|
||||
: ?move-player-freely ( d-left player -- d-left' player )
|
||||
over 0 > [
|
||||
! must make sure we are moving a significant distance, otherwise
|
||||
! we can recurse endlessly due to floating-point imprecision.
|
||||
! (at least I /think/ that's what causes it...)
|
||||
dup distance-to-move-freely dup 0.1 > [
|
||||
over forward>> move-player-on-heading ?move-player-freely
|
||||
] [ drop ] if
|
||||
] when ;
|
||||
|
||||
: drag-heading ( player -- heading )
|
||||
[ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
|
||||
|
||||
: 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 -- )
|
||||
[ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
|
||||
|
||||
: update-player ( player -- )
|
||||
[ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors io.files kernel openal sequences ;
|
||||
IN: jamshred.sound
|
||||
|
||||
TUPLE: sounds bang ;
|
||||
|
||||
: assign-sound ( source wav-path -- )
|
||||
resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
|
||||
|
||||
: <sounds> ( -- sounds )
|
||||
init-openal 1 gen-sources first sounds boa
|
||||
dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
|
||||
|
||||
: bang ( sounds -- ) bang>> source-play check-error ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
A simple 3d tunnel racing game
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
applications
|
||||
games
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alex Chapman
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
|
||||
IN: jamshred.tunnel.tests
|
||||
|
||||
[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
|
||||
T{ segment f { 1 1 1 } f f f 1 }
|
||||
T{ oint f { 0 0 0.25 } }
|
||||
nearer-segment number>> ] unit-test
|
||||
|
||||
[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
|
||||
[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
|
||||
[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
|
||||
|
||||
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
|
||||
|
||||
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
|
||||
|
||||
: test-segment-oint ( -- oint )
|
||||
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
|
||||
|
||||
[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
|
||||
[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
|
||||
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
|
||||
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
|
||||
[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
|
||||
[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
|
||||
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
|
||||
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
|
||||
|
||||
: simplest-straight-ahead ( -- oint segment )
|
||||
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
|
||||
initial-segment ;
|
||||
|
||||
[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
|
||||
[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
|
||||
|
||||
: simple-collision-up ( -- oint segment )
|
||||
{ 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
|
||||
initial-segment ;
|
||||
|
||||
[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
|
||||
[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
|
||||
[ { 0.0 1.0 0.0 } ]
|
||||
[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
|
||||
|
|
@ -0,0 +1,167 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays colors combinators float-arrays kernel
|
||||
locals math math.constants math.matrices math.order math.ranges
|
||||
math.vectors math.quadratic random sequences vectors jamshred.oint ;
|
||||
IN: jamshred.tunnel
|
||||
|
||||
: n-segments ( -- n ) 5000 ; inline
|
||||
|
||||
TUPLE: segment < oint number color radius ;
|
||||
C: <segment> segment
|
||||
|
||||
: segment-number++ ( segment -- )
|
||||
[ number>> 1+ ] keep (>>number) ;
|
||||
|
||||
: random-color ( -- color )
|
||||
{ 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
|
||||
|
||||
: tunnel-segment-distance ( -- n ) 0.4 ;
|
||||
: random-rotation-angle ( -- theta ) pi 20 / ;
|
||||
|
||||
: random-segment ( previous-segment -- segment )
|
||||
clone dup random-rotation-angle random-turn
|
||||
tunnel-segment-distance over go-forward
|
||||
random-color >>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 )
|
||||
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
|
||||
0 random-color default-segment-radius <segment> ;
|
||||
|
||||
: random-segments ( n -- segments )
|
||||
initial-segment 1vector swap (random-segments) ;
|
||||
|
||||
: simple-segment ( n -- segment )
|
||||
[ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
|
||||
random-color default-segment-radius <segment> ;
|
||||
|
||||
: simple-segments ( n -- segments )
|
||||
[ simple-segment ] map ;
|
||||
|
||||
: <random-tunnel> ( -- segments )
|
||||
n-segments random-segments ;
|
||||
|
||||
: <straight-tunnel> ( -- segments )
|
||||
n-segments simple-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> ;
|
||||
|
||||
: 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 rest-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 spin <slice> <reversed> find-nearest-segment ;
|
||||
|
||||
: nearest-segment ( segments oint start-segment -- segment )
|
||||
#! find the segment nearest to 'oint', and return it.
|
||||
#! start looking at segment 'start-segment'
|
||||
number>> over >r
|
||||
[ 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 ;
|
||||
|
||||
: distance-from-centre ( seg loc -- distance )
|
||||
vector-to-centre norm ;
|
||||
|
||||
: wall-normal ( seg oint -- n )
|
||||
location>> vector-to-centre normalize ;
|
||||
|
||||
: distant ( -- n ) 1000 ;
|
||||
|
||||
: 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 )
|
||||
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 ;
|
||||
|
||||
: sideways-relative-location ( oint segment -- loc )
|
||||
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
|
||||
|
||||
: (distance-to-collision) ( oint segment -- distance )
|
||||
[ sideways-heading ] [ sideways-relative-location ]
|
||||
[ nip radius>> ] 2tri collision-coefficient ;
|
||||
|
||||
: collision-vector ( oint segment -- v )
|
||||
dupd (distance-to-collision) swap forward>> n*v ;
|
||||
|
||||
: bounce-forward ( segment oint -- )
|
||||
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
|
||||
|
||||
: bounce-left ( segment oint -- )
|
||||
#! must be done after forward
|
||||
[ forward>> vneg ] dip [ left>> swap reflect ]
|
||||
[ forward>> proj-perp normalize ] [ (>>left) ] tri ;
|
||||
|
||||
: bounce-up ( segment oint -- )
|
||||
#! must be done after forward and left!
|
||||
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
|
||||
|
||||
: bounce-off-wall ( oint segment -- )
|
||||
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
|
||||
|
||||
Loading…
Reference in New Issue