From: Doug Coleman Date: Thu, 4 Feb 2010 22:03:00 +0000 (-0600) Subject: Move jamshred to unmaintained X-Git-Tag: 0.97~4980^2~1 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=c52c69fe1d6e28b41a260af925b1145fe28fdad1 Move jamshred to unmaintained --- diff --git a/extra/jamshred/authors.txt b/extra/jamshred/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/extra/jamshred/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor deleted file mode 100644 index 867fb8d626..0000000000 --- a/extra/jamshred/deploy.factor +++ /dev/null @@ -1,11 +0,0 @@ -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" } -} diff --git a/extra/jamshred/game/authors.txt b/extra/jamshred/game/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/extra/jamshred/game/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor deleted file mode 100644 index 14bf18a9c1..0000000000 --- a/extra/jamshred/game/game.factor +++ /dev/null @@ -1,40 +0,0 @@ -! 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 ) - "Player 1" pick - 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 ; diff --git a/extra/jamshred/gl/authors.txt b/extra/jamshred/gl/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/extra/jamshred/gl/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor deleted file mode 100644 index 9e5d248c98..0000000000 --- a/extra/jamshred/gl/gl.factor +++ /dev/null @@ -1,114 +0,0 @@ -! 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 ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor deleted file mode 100644 index 96e88cb662..0000000000 --- a/extra/jamshred/jamshred.factor +++ /dev/null @@ -1,83 +0,0 @@ -! 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 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 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" } } - >>gadgets ; diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor deleted file mode 100644 index f2517d1ec3..0000000000 --- a/extra/jamshred/log/log.factor +++ /dev/null @@ -1,10 +0,0 @@ -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... diff --git a/extra/jamshred/oint/authors.txt b/extra/jamshred/oint/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/extra/jamshred/oint/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor deleted file mode 100644 index 401935fd01..0000000000 --- a/extra/jamshred/oint/oint-tests.factor +++ /dev/null @@ -1,8 +0,0 @@ -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 diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor deleted file mode 100644 index 1b1d87fbab..0000000000 --- a/extra/jamshred/oint/oint.factor +++ /dev/null @@ -1,73 +0,0 @@ -! 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 - -: 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 ; diff --git a/extra/jamshred/player/authors.txt b/extra/jamshred/player/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/extra/jamshred/player/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor deleted file mode 100644 index 49536e2570..0000000000 --- a/extra/jamshred/player/player.factor +++ /dev/null @@ -1,140 +0,0 @@ -! 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 - -: ( 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 ; diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor deleted file mode 100644 index 6a9b331f33..0000000000 --- a/extra/jamshred/sound/sound.factor +++ /dev/null @@ -1,15 +0,0 @@ -! 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 ) - init-openal 1 gen-sources first sounds boa - dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ; - -: bang ( sounds -- ) bang>> source-play check-error ; diff --git a/extra/jamshred/summary.txt b/extra/jamshred/summary.txt deleted file mode 100644 index e26fc1cf8b..0000000000 --- a/extra/jamshred/summary.txt +++ /dev/null @@ -1 +0,0 @@ -A simple 3d tunnel racing game diff --git a/extra/jamshred/tags.txt b/extra/jamshred/tags.txt deleted file mode 100644 index 8ae5957a4b..0000000000 --- a/extra/jamshred/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -applications -games diff --git a/extra/jamshred/tunnel/authors.txt b/extra/jamshred/tunnel/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/extra/jamshred/tunnel/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor deleted file mode 100644 index ac696f5444..0000000000 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ /dev/null @@ -1,35 +0,0 @@ -! 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 } ; - -[ { -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 } - 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 } - 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 diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor deleted file mode 100644 index f94fc979ce..0000000000 --- a/extra/jamshred/tunnel/tunnel.factor +++ /dev/null @@ -1,148 +0,0 @@ -! 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-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 ; - -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 ; - -: 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 ; - -: simple-segments ( n -- segments ) - [ simple-segment ] map ; - -: ( -- segments ) - n-segments random-segments ; - -: ( -- 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 ; - -: 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 ; - diff --git a/unmaintained/jamshred/authors.txt b/unmaintained/jamshred/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/deploy.factor b/unmaintained/jamshred/deploy.factor new file mode 100644 index 0000000000..867fb8d626 --- /dev/null +++ b/unmaintained/jamshred/deploy.factor @@ -0,0 +1,11 @@ +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" } +} diff --git a/unmaintained/jamshred/game/authors.txt b/unmaintained/jamshred/game/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/game/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/game/game.factor b/unmaintained/jamshred/game/game.factor new file mode 100644 index 0000000000..14bf18a9c1 --- /dev/null +++ b/unmaintained/jamshred/game/game.factor @@ -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 ) + "Player 1" pick + 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 ; diff --git a/unmaintained/jamshred/gl/authors.txt b/unmaintained/jamshred/gl/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/gl/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/gl/gl.factor b/unmaintained/jamshred/gl/gl.factor new file mode 100644 index 0000000000..9e5d248c98 --- /dev/null +++ b/unmaintained/jamshred/gl/gl.factor @@ -0,0 +1,114 @@ +! 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 ; diff --git a/unmaintained/jamshred/jamshred.factor b/unmaintained/jamshred/jamshred.factor new file mode 100644 index 0000000000..96e88cb662 --- /dev/null +++ b/unmaintained/jamshred/jamshred.factor @@ -0,0 +1,83 @@ +! 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 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 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" } } + >>gadgets ; diff --git a/unmaintained/jamshred/log/log.factor b/unmaintained/jamshred/log/log.factor new file mode 100644 index 0000000000..f2517d1ec3 --- /dev/null +++ b/unmaintained/jamshred/log/log.factor @@ -0,0 +1,10 @@ +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... diff --git a/unmaintained/jamshred/oint/authors.txt b/unmaintained/jamshred/oint/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/oint/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/oint/oint-tests.factor b/unmaintained/jamshred/oint/oint-tests.factor new file mode 100644 index 0000000000..401935fd01 --- /dev/null +++ b/unmaintained/jamshred/oint/oint-tests.factor @@ -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 diff --git a/unmaintained/jamshred/oint/oint.factor b/unmaintained/jamshred/oint/oint.factor new file mode 100644 index 0000000000..1b1d87fbab --- /dev/null +++ b/unmaintained/jamshred/oint/oint.factor @@ -0,0 +1,73 @@ +! 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 + +: 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 ; diff --git a/unmaintained/jamshred/player/authors.txt b/unmaintained/jamshred/player/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/player/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/player/player.factor b/unmaintained/jamshred/player/player.factor new file mode 100644 index 0000000000..49536e2570 --- /dev/null +++ b/unmaintained/jamshred/player/player.factor @@ -0,0 +1,140 @@ +! 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 + +: ( 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 ; diff --git a/unmaintained/jamshred/sound/sound.factor b/unmaintained/jamshred/sound/sound.factor new file mode 100644 index 0000000000..6a9b331f33 --- /dev/null +++ b/unmaintained/jamshred/sound/sound.factor @@ -0,0 +1,15 @@ +! 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 ) + init-openal 1 gen-sources first sounds boa + dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ; + +: bang ( sounds -- ) bang>> source-play check-error ; diff --git a/unmaintained/jamshred/summary.txt b/unmaintained/jamshred/summary.txt new file mode 100644 index 0000000000..e26fc1cf8b --- /dev/null +++ b/unmaintained/jamshred/summary.txt @@ -0,0 +1 @@ +A simple 3d tunnel racing game diff --git a/unmaintained/jamshred/tags.txt b/unmaintained/jamshred/tags.txt new file mode 100644 index 0000000000..8ae5957a4b --- /dev/null +++ b/unmaintained/jamshred/tags.txt @@ -0,0 +1,2 @@ +applications +games diff --git a/unmaintained/jamshred/tunnel/authors.txt b/unmaintained/jamshred/tunnel/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/unmaintained/jamshred/tunnel/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/jamshred/tunnel/tunnel-tests.factor b/unmaintained/jamshred/tunnel/tunnel-tests.factor new file mode 100644 index 0000000000..ac696f5444 --- /dev/null +++ b/unmaintained/jamshred/tunnel/tunnel-tests.factor @@ -0,0 +1,35 @@ +! 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 } ; + +[ { -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 } + 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 } + 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 diff --git a/unmaintained/jamshred/tunnel/tunnel.factor b/unmaintained/jamshred/tunnel/tunnel.factor new file mode 100644 index 0000000000..f94fc979ce --- /dev/null +++ b/unmaintained/jamshred/tunnel/tunnel.factor @@ -0,0 +1,148 @@ +! 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-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 ; + +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 ; + +: 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 ; + +: simple-segments ( n -- segments ) + [ simple-segment ] map ; + +: ( -- segments ) + n-segments random-segments ; + +: ( -- 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 ; + +: 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 ; +