--- /dev/null
+Alex Chapman
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Jamshred" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 ;
+
+CONSTANT: units-per-full-roll 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 ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 locals ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+IN: jamshred.gl
+
+CONSTANT: min-vertices 6
+CONSTANT: max-vertices 32
+
+CONSTANT: n-vertices 32
+
+! render enough of the tunnel that it looks continuous
+CONSTANT: n-segments-ahead 60
+CONSTANT: n-segments-behind 40
+
+! so that we can't see through the wall, we draw it a bit further away
+CONSTANT: wall-drawing-offset 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
+ [ iota ] keep [ / 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 -- )
+ segment theta draw-segment-vertex
+ next-segment theta draw-segment-vertex ;
+
+: draw-segment ( next-segment segment -- )
+ GL_QUAD_STRIP [
+ [ draw-vertex-pair ] 2curry
+ n-vertices equally-spaced-radians float-array{ 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 ( -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_PROJECTION glMatrixMode glPushMatrix
+ GL_MODELVIEW glMatrixMode glPushMatrix
+ 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 ;
+
+: cleanup-graphics ( -- )
+ GL_DEPTH_TEST glDisable
+ GL_SCISSOR_TEST glEnable
+ GL_MODELVIEW glMatrixMode glPopMatrix
+ GL_PROJECTION glMatrixMode glPopMatrix
+ GL_LIGHTING glDisable
+ GL_LIGHT0 glDisable
+ GL_FOG glDisable
+ GL_COLOR_MATERIAL glDisable ;
+
+: pre-draw ( width height -- )
+ 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 ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ;
--- /dev/null
+! 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.rectangles 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 swap >>jamshred ;
+
+CONSTANT: default-width 800
+CONSTANT: default-height 600
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 100 milliseconds sleep jamshred-loop ] tri
+ ] if ;
+
+M: jamshred-gadget graft* ( gadget -- )
+ [ find-gl-context init-graphics ]
+ [ [ jamshred-loop ] curry in-thread ] bi ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ dup find-gl-context cleanup-graphics 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
+ dim>> first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ dim>> second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
+ rot jamshred>> 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 -- )
+ [ f set-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" } [ 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 ] }
+ { motion [ handle-mouse-motion ] }
+ { mouse-scroll [ handle-mouse-scroll ] }
+} set-gestures
+
+MAIN-WINDOW: jamshred-window { { title "Jamshred" } }
+ <jamshred> <jamshred-gadget> >>gadgets ;
--- /dev/null
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+ "jamshred" swap with-logging ; inline
+
+: jamshred-log ( message -- )
+ [ (jamshred-log) ] with-jamshred-log ; ! ugly...
--- /dev/null
+Alex Chapman
--- /dev/null
+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
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors 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> [ rect> ] dip 2array ;
+
+<PRIVATE
+
+! inline old math.quaternions to get this to work, eww.
+
+: ** ( x y -- z ) conjugate * ; inline
+
+: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
+
+: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
+
+: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
+
+: q* ( u v -- u*v )
+ [ q*a ] [ q*b ] 2bi 2array ;
+
+: v>q ( v -- q )
+ first3 rect> [ 0 swap rect> ] dip 2array ;
+
+: q>v ( q -- v )
+ first2 [ imaginary-part ] dip >rect 3array ;
+
+: qconjugate ( u -- u' )
+ first2 [ conjugate ] [ neg ] bi* 2array ;
+
+: qrecip ( u -- 1/u )
+ qconjugate dup norm-sq v/n ;
+
+PRIVATE>
+
+: 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 * >integer 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
+ [ v. ] [ norm ] bi / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ [ distance-vector ] keep 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 ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar.unix colors.constants combinators jamshred.log
+jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
+math.constants math.order math.ranges math.vectors math.matrices
+sequences shuffle specialized-arrays strings system ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
+IN: jamshred.player
+
+TUPLE: player < oint
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+CONSTANT: default-speed 1.0
+CONSTANT: max-speed 30.0
+
+: <player> ( name sounds -- player )
+ [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ [ over ] dip left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ dup tunnel>> first
+ [ >>nearest-segment ]
+ [ location>> >>location ] bi drop ;
+
+: play-in-tunnel ( player segments -- )
+ >>tunnel to-tunnel-start ;
+
+: update-time ( player -- seconds-passed )
+ system-micros swap [ last-move>> - 1000000 / ] [ last-move<< ] 2bi ;
+
+: moved ( player -- ) system-micros swap last-move<< ;
+
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + 0 max-speed clamp ] change-speed drop ;
+
+: multiply-player-speed ( n player -- )
+ [ * 0 max-speed clamp ] 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 )
+ d-left distance min :> d-to-move
+ d-to-move heading n*v :> move-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" named-color swap color<< ] bi ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.pathnames kernel openal openal.alut 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 ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
+demos
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays jamshred.oint jamshred.tunnel kernel
+math.vectors sequences specialized-arrays tools.test
+alien.c-types ;
+SPECIALIZED-ARRAY: float
+IN: jamshred.tunnel.tests
+
+: 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
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators fry jamshred.oint
+kernel literals locals math math.constants math.matrices
+math.order math.quadratic math.ranges math.vectors random
+sequences specialized-arrays vectors ;
+FROM: jamshred.oint => distance ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+IN: jamshred.tunnel
+
+CONSTANT: n-segments 5000
+
+TUPLE: segment < oint number color radius ;
+C: <segment> segment
+
+: segment-number++ ( segment -- )
+ [ number>> 1 + ] keep number<< ;
+
+: clamp-length ( n seq -- n' )
+ 0 swap length clamp ;
+
+: random-color ( -- color )
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+
+CONSTANT: tunnel-segment-distance 0.4
+CONSTANT: random-rotation-angle $[ 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 > [
+ [ dup last random-segment over push ] dip 1 - (random-segments)
+ ] [ drop ] if ;
+
+CONSTANT: default-segment-radius 1
+
+: initial-segment ( -- segment )
+ float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -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
+ [ '[ _ clamp-length ] bi@ ] keep <slice> ;
+
+: get-segment ( segments n -- segment )
+ over clamp-length 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 )
+ current forward>> :> cf
+ cf next location>> v. cf location v. - cf heading v. / ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ current forward>> :> cf
+ next current half-way-between-oints :> h
+ 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 ;
+
+CONSTANT: distant 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
+ ] [
+ v dup v. :> a
+ v w v. 2 * :> b
+ w dup v. r sq - :> c
+ 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 ;
+
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Jamshred" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 ;
-
-CONSTANT: units-per-full-roll 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 ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 locals ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-IN: jamshred.gl
-
-CONSTANT: min-vertices 6
-CONSTANT: max-vertices 32
-
-CONSTANT: n-vertices 32
-
-! render enough of the tunnel that it looks continuous
-CONSTANT: n-segments-ahead 60
-CONSTANT: n-segments-behind 40
-
-! so that we can't see through the wall, we draw it a bit further away
-CONSTANT: wall-drawing-offset 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
- [ iota ] keep [ / 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 -- )
- segment theta draw-segment-vertex
- next-segment theta draw-segment-vertex ;
-
-: draw-segment ( next-segment segment -- )
- GL_QUAD_STRIP [
- [ draw-vertex-pair ] 2curry
- n-vertices equally-spaced-radians float-array{ 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 ( -- )
- GL_DEPTH_TEST glEnable
- GL_SCISSOR_TEST glDisable
- 1.0 glClearDepth
- 0.0 0.0 0.0 0.0 glClearColor
- GL_PROJECTION glMatrixMode glPushMatrix
- GL_MODELVIEW glMatrixMode glPushMatrix
- 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 ;
-
-: cleanup-graphics ( -- )
- GL_DEPTH_TEST glDisable
- GL_SCISSOR_TEST glEnable
- GL_MODELVIEW glMatrixMode glPopMatrix
- GL_PROJECTION glMatrixMode glPopMatrix
- GL_LIGHTING glDisable
- GL_LIGHT0 glDisable
- GL_FOG glDisable
- GL_COLOR_MATERIAL glDisable ;
-
-: pre-draw ( width height -- )
- 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 ;
-
-: player-view ( player -- )
- [ location>> ]
- [ [ location>> ] [ forward>> ] bi v+ ]
- [ up>> ] tri gl-look-at ;
-
-: draw-jamshred ( jamshred width height -- )
- pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ;
+++ /dev/null
-! 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.rectangles 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 swap >>jamshred ;
-
-CONSTANT: default-width 800
-CONSTANT: default-height 600
-
-M: jamshred-gadget pref-dim*
- drop default-width default-height 2array ;
-
-M: jamshred-gadget draw-gadget* ( gadget -- )
- [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
-
-: jamshred-loop ( gadget -- )
- dup jamshred>> quit>> [
- drop
- ] [
- [ jamshred>> jamshred-update ]
- [ relayout-1 ]
- [ 100 milliseconds sleep jamshred-loop ] tri
- ] if ;
-
-M: jamshred-gadget graft* ( gadget -- )
- [ find-gl-context init-graphics ]
- [ [ jamshred-loop ] curry in-thread ] bi ;
-
-M: jamshred-gadget ungraft* ( gadget -- )
- dup find-gl-context cleanup-graphics 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
- dim>> first pix>radians neg ;
-
-: y>radians ( y gadget -- theta )
- #! translate motion of y pixels to an angle
- dim>> second pix>radians ;
-
-: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
- dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
- rot jamshred>> 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 -- )
- [ f set-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" } [ 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 ] }
- { motion [ handle-mouse-motion ] }
- { mouse-scroll [ handle-mouse-scroll ] }
-} set-gestures
-
-MAIN-WINDOW: jamshred-window { { title "Jamshred" } }
- <jamshred> <jamshred-gadget> >>gadgets ;
+++ /dev/null
-USING: kernel logging ;
-IN: jamshred.log
-
-LOG: (jamshred-log) DEBUG
-
-: with-jamshred-log ( quot -- )
- "jamshred" swap with-logging ; inline
-
-: jamshred-log ( message -- )
- [ (jamshred-log) ] with-jamshred-log ; ! ugly...
+++ /dev/null
-Alex Chapman
+++ /dev/null
-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
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors 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> [ rect> ] dip 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 * >integer 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
- [ v. ] [ norm ] bi / ;
-
-: proj-perp ( u v -- w )
- dupd proj v- ;
-
-: perpendicular-distance ( oint oint -- distance )
- [ distance-vector ] keep 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 ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors.constants combinators jamshred.log
-jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
-math.constants math.order math.ranges math.vectors math.matrices
-sequences shuffle specialized-arrays strings system ;
-QUALIFIED-WITH: alien.c-types c
-SPECIALIZED-ARRAY: c:float
-IN: jamshred.player
-
-TUPLE: player < oint
- { name string }
- { sounds sounds }
- tunnel
- nearest-segment
- { last-move integer }
- { speed float } ;
-
-! speeds are in GL units / second
-CONSTANT: default-speed 1.0
-CONSTANT: max-speed 30.0
-
-: <player> ( name sounds -- player )
- [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
- f f 0 default-speed player boa ;
-
-: turn-player ( player x-radians y-radians -- )
- [ over ] dip left-pivot up-pivot ;
-
-: roll-player ( player z-radians -- )
- forward-pivot ;
-
-: to-tunnel-start ( player -- )
- dup tunnel>> first
- [ >>nearest-segment ]
- [ location>> >>location ] bi drop ;
-
-: play-in-tunnel ( player segments -- )
- >>tunnel to-tunnel-start ;
-
-: update-time ( player -- seconds-passed )
- system-micros swap [ last-move>> - 1000000 / ] [ (>>last-move) ] 2bi ;
-
-: moved ( player -- ) system-micros swap (>>last-move) ;
-
-: speed-range ( -- range )
- max-speed [0,b] ;
-
-: change-player-speed ( inc player -- )
- [ + 0 max-speed clamp ] change-speed drop ;
-
-: multiply-player-speed ( n player -- )
- [ * 0 max-speed clamp ] 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 )
- d-left distance min :> d-to-move
- d-to-move heading n*v :> move-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" named-color swap (>>color) ] bi ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.pathnames 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 ;
+++ /dev/null
-A simple 3d tunnel racing game
+++ /dev/null
-applications
-games
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays jamshred.oint jamshred.tunnel kernel
-math.vectors sequences specialized-arrays tools.test
-alien.c-types ;
-SPECIALIZED-ARRAY: float
-IN: jamshred.tunnel.tests
-
-: 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
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators fry jamshred.oint
-kernel literals locals math math.constants math.matrices
-math.order math.quadratic math.ranges math.vectors random
-sequences specialized-arrays vectors ;
-FROM: jamshred.oint => distance ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-IN: jamshred.tunnel
-
-CONSTANT: n-segments 5000
-
-TUPLE: segment < oint number color radius ;
-C: <segment> segment
-
-: segment-number++ ( segment -- )
- [ number>> 1 + ] keep (>>number) ;
-
-: clamp-length ( n seq -- n' )
- 0 swap length clamp ;
-
-: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
-
-CONSTANT: tunnel-segment-distance 0.4
-CONSTANT: random-rotation-angle $[ 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 > [
- [ dup last random-segment over push ] dip 1 - (random-segments)
- ] [ drop ] if ;
-
-CONSTANT: default-segment-radius 1
-
-: initial-segment ( -- segment )
- float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
- 0 random-color default-segment-radius <segment> ;
-
-: random-segments ( n -- segments )
- initial-segment 1vector swap (random-segments) ;
-
-: simple-segment ( n -- segment )
- [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -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
- [ '[ _ clamp-length ] bi@ ] keep <slice> ;
-
-: get-segment ( segments n -- segment )
- over clamp-length 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 )
- current forward>> :> cf
- cf next location>> v. cf location v. - cf heading v. / ;
-
-:: distance-to-next-segment-area ( current next location heading -- distance )
- current forward>> :> cf
- next current half-way-between-oints :> h
- 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 ;
-
-CONSTANT: distant 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
- ] [
- v dup v. :> a
- v w v. 2 * :> b
- w dup v. r sq - :> c
- 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 ;
-