Retrieving jamshred from repository history
Alex Chapman
parent
8bbc3d577e
commit
d34539bca1
|
|
@ -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