From: Alex Chapman Date: Tue, 7 Oct 2008 21:12:52 +0000 (+1100) Subject: Merge branch 'master' of git://factorcode.org/git/factor into maintenance X-Git-Tag: 0.94~2132^2~41^2~2 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=95848c8c684d4f2e908951914577c9231ce75011;hp=d656509e24b82612ff1edc12d09657e0c510723e Merge branch 'master' of git://factorcode.org/git/factor into maintenance --- diff --git a/extra/digraphs/authors.txt b/extra/digraphs/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/digraphs/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/digraphs/digraphs-tests.factor b/extra/digraphs/digraphs-tests.factor new file mode 100644 index 0000000000..64589c1a99 --- /dev/null +++ b/extra/digraphs/digraphs-tests.factor @@ -0,0 +1,11 @@ +USING: digraphs kernel sequences tools.test ; +IN: digraphs.tests + +: test-digraph ( -- digraph ) + + { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } + [ first2 pick add-vertex ] each + { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } + [ first2 pick add-edge ] each ; + +[ 5 ] [ test-digraph topological-sort length ] unit-test diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor new file mode 100755 index 0000000000..5ccc0d5a60 --- /dev/null +++ b/extra/digraphs/digraphs.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs hashtables hashtables.private kernel sequences vectors ; +IN: digraphs + +TUPLE: digraph < hashtable ; + +: ( -- digraph ) + 0 digraph new [ reset-hash ] keep ; + +TUPLE: vertex value edges ; + +: ( value -- vertex ) + V{ } clone vertex boa ; + +: add-vertex ( key value digraph -- ) + [ swap ] dip set-at ; + +: children ( key digraph -- seq ) + at edges>> ; + +: @edges ( from to digraph -- to edges ) swapd at edges>> ; +: add-edge ( from to digraph -- ) @edges push ; +: delete-edge ( from to digraph -- ) @edges delete ; + +: delete-to-edges ( to digraph -- ) + [ nip dupd edges>> delete ] assoc-each drop ; + +: delete-vertex ( key digraph -- ) + 2dup delete-at delete-to-edges ; + +: unvisited? ( unvisited key -- ? ) swap key? ; +: visited ( unvisited key -- ) swap delete-at ; + +DEFER: (topological-sort) +: visit-children ( seq unvisited key -- seq unvisited ) + over children [ (topological-sort) ] each ; + +: (topological-sort) ( seq unvisited key -- seq unvisited ) + 2dup unvisited? [ + [ visit-children ] keep 2dup visited pick push + ] [ + drop + ] if ; + +: topological-sort ( digraph -- seq ) + dup clone V{ } clone spin + [ drop (topological-sort) ] assoc-each drop reverse ; + +: topological-sorted-values ( digraph -- seq ) + dup topological-sort swap [ at value>> ] curry map ; diff --git a/extra/digraphs/summary.txt b/extra/digraphs/summary.txt new file mode 100644 index 0000000000..78e5a53313 --- /dev/null +++ b/extra/digraphs/summary.txt @@ -0,0 +1 @@ +Simple directed graph implementation for topological sorting diff --git a/extra/digraphs/tags.txt b/extra/digraphs/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/digraphs/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/jamshred/authors.txt b/extra/jamshred/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor new file mode 100644 index 0000000000..9a18cf1f9b --- /dev/null +++ b/extra/jamshred/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-name "Jamshred" } +} diff --git a/extra/jamshred/game/authors.txt b/extra/jamshred/game/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/game/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor new file mode 100644 index 0000000000..938605ce9f --- /dev/null +++ b/extra/jamshred/game/game.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2007 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 ; + +: units-per-full-roll ( -- n ) 50 ; + +: jamshred-roll ( jamshred n -- ) + [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ; + +: mouse-scroll-x ( jamshred x -- ) jamshred-roll ; + +: mouse-scroll-y ( jamshred y -- ) + neg swap jamshred-player change-player-speed ; diff --git a/extra/jamshred/gl/authors.txt b/extra/jamshred/gl/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/gl/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor new file mode 100644 index 0000000000..69af7ab986 --- /dev/null +++ b/extra/jamshred/gl/gl.factor @@ -0,0 +1,95 @@ +! 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 sequences float-arrays ; +IN: jamshred.gl + +: min-vertices 6 ; inline +: max-vertices 32 ; inline + +: n-vertices ( -- n ) 32 ; inline + +! render enough of the tunnel that it looks continuous +: n-segments-ahead ( -- n ) 60 ; inline +: n-segments-behind ( -- n ) 40 ; inline + +: wall-drawing-offset ( -- n ) + #! so that we can't see through the wall, we draw it a bit further away + 0.15 ; + +: wall-drawing-radius ( segment -- r ) + radius>> wall-drawing-offset + ; + +: wall-up ( segment -- v ) + [ wall-drawing-radius ] [ up>> ] bi n*v ; + +: wall-left ( segment -- v ) + [ wall-drawing-radius ] [ left>> ] bi n*v ; + +: segment-vertex ( theta segment -- vertex ) + [ + [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+ + ] [ + location>> v+ + ] bi ; + +: segment-vertex-normal ( vertex segment -- normal ) + location>> swap v- normalize ; + +: segment-vertex-and-normal ( segment theta -- vertex normal ) + swap [ segment-vertex ] keep dupd segment-vertex-normal ; + +: equally-spaced-radians ( n -- seq ) + #! return a sequence of n numbers between 0 and 2pi + dup [ / pi 2 * * ] curry map ; +: draw-segment-vertex ( segment theta -- ) + over color>> gl-color segment-vertex-and-normal + gl-normal gl-vertex ; + +: draw-vertex-pair ( theta next-segment segment -- ) + rot tuck draw-segment-vertex draw-segment-vertex ; + +: draw-segment ( next-segment segment -- ) + GL_QUAD_STRIP [ + [ draw-vertex-pair ] 2curry + n-vertices equally-spaced-radians F{ 0.0 } append swap each + ] do-state ; + +: draw-segments ( segments -- ) + 1 over length pick subseq swap [ draw-segment ] 2each ; + +: segments-to-render ( player -- segments ) + dup nearest-segment>> number>> dup n-segments-behind - + swap n-segments-ahead + rot tunnel>> sub-tunnel ; + +: draw-tunnel ( player -- ) + segments-to-render draw-segments ; + +: init-graphics ( width height -- ) + GL_DEPTH_TEST glEnable + GL_SCISSOR_TEST glDisable + 1.0 glClearDepth + 0.0 0.0 0.0 0.0 glClearColor + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_PROJECTION glMatrixMode glLoadIdentity + dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if + GL_MODELVIEW glMatrixMode glLoadIdentity + GL_LEQUAL glDepthFunc + GL_LIGHTING glEnable + GL_LIGHT0 glEnable + GL_FOG glEnable + GL_FOG_DENSITY 0.09 glFogf + GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial + GL_COLOR_MATERIAL glEnable + GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; + +: player-view ( player -- ) + [ location>> ] + [ [ location>> ] [ forward>> ] bi v+ ] + [ up>> ] tri gl-look-at ; + +: draw-jamshred ( jamshred width height -- ) + init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ; + diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor new file mode 100755 index 0000000000..aa9c164b8f --- /dev/null +++ b/extra/jamshred/jamshred.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ; +IN: jamshred + +TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; + +: ( jamshred -- gadget ) + jamshred-gadget new-gadget swap >>jamshred ; + +: default-width ( -- x ) 800 ; +: default-height ( -- y ) 600 ; + +M: jamshred-gadget pref-dim* + drop default-width default-height 2array ; + +M: jamshred-gadget draw-gadget* ( gadget -- ) + [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ; + +: jamshred-loop ( gadget -- ) + dup jamshred>> quit>> [ + drop + ] [ + [ jamshred>> jamshred-update ] + [ relayout-1 ] + [ yield jamshred-loop ] tri + ] if ; + +: fullscreen ( gadget -- ) + find-world t swap set-fullscreen* ; + +: no-fullscreen ( gadget -- ) + find-world f swap set-fullscreen* ; + +: toggle-fullscreen ( world -- ) + [ fullscreen? not ] keep set-fullscreen* ; + +M: jamshred-gadget graft* ( gadget -- ) + [ jamshred-loop ] in-thread drop ; + +M: jamshred-gadget ungraft* ( gadget -- ) + 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 + rect-dim first pix>radians neg ; + +: y>radians ( y gadget -- theta ) + #! translate motion of y pixels to an angle + rect-dim second pix>radians ; + +: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) + over jamshred>> >r + [ first swap x>radians ] 2keep second swap y>radians + r> mouse-moved ; + +: handle-mouse-motion ( jamshred-gadget -- ) + hand-loc get [ + over last-hand-loc>> [ + v- (handle-mouse-motion) + ] [ 2drop ] if* + ] 2keep >>last-hand-loc drop ; + +: handle-mouse-scroll ( jamshred-gadget -- ) + jamshred>> scroll-direction get + [ first mouse-scroll-x ] + [ second mouse-scroll-y ] 2bi ; + +: quit ( gadget -- ) + [ no-fullscreen ] [ close-window ] bi ; + +jamshred-gadget H{ + { T{ key-down f f "r" } [ jamshred-restart ] } + { T{ key-down f f " " } [ jamshred>> toggle-running ] } + { T{ key-down f f "f" } [ find-world toggle-fullscreen ] } + { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] } + { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] } + { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] } + { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] } + { T{ key-down f f "q" } [ quit ] } + { T{ motion } [ handle-mouse-motion ] } + { T{ mouse-scroll } [ handle-mouse-scroll ] } +} set-gestures + +: jamshred-window ( -- gadget ) + [ dup "Jamshred" open-window ] with-ui ; + +MAIN: jamshred-window diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor new file mode 100644 index 0000000000..33498d8a2e --- /dev/null +++ b/extra/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 ; + +: jamshred-log ( message -- ) + [ (jamshred-log) ] with-jamshred-log ; ! ugly... diff --git a/extra/jamshred/oint/authors.txt b/extra/jamshred/oint/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/oint/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor new file mode 100644 index 0000000000..401935fd01 --- /dev/null +++ b/extra/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/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor new file mode 100644 index 0000000000..808e92a1f9 --- /dev/null +++ b/extra/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 float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; +IN: jamshred.oint + +! An oint is a point with three linearly independent unit vectors +! given relative to that point. In jamshred a player's location and +! direction are given by the player's oint. Similarly, a tunnel +! segment's location and orientation are given by an oint. + +TUPLE: oint location forward up left ; +C: oint + +: rotation-quaternion ( theta axis -- quaternion ) + swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; + +: rotate-vector ( q qrecip v -- v ) + v>q swap q* q* q>v ; + +: rotate-oint ( oint theta axis -- ) + rotation-quaternion dup qrecip pick + [ forward>> rotate-vector >>forward ] + [ up>> rotate-vector >>up ] + [ left>> rotate-vector >>left ] 3tri drop ; + +: left-pivot ( oint theta -- ) + over left>> rotate-oint ; + +: up-pivot ( oint theta -- ) + over up>> rotate-oint ; + +: forward-pivot ( oint theta -- ) + over forward>> rotate-oint ; + +: random-float+- ( n -- m ) + #! find a random float between -n/2 and n/2 + dup 10000 * >fixnum random 10000 / swap 2 / - ; + +: random-turn ( oint theta -- ) + 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; + +: location+ ( v oint -- ) + [ location>> v+ ] [ (>>location) ] bi ; + +: go-forward ( distance oint -- ) + [ forward>> n*v ] [ location+ ] bi ; + +: distance-vector ( oint oint -- vector ) + [ location>> ] bi@ swap v- ; + +: distance ( oint oint -- distance ) + distance-vector norm ; + +: scalar-projection ( v1 v2 -- n ) + #! the scalar projection of v1 onto v2 + tuck v. swap norm / ; + +: proj-perp ( u v -- w ) + dupd proj v- ; + +: perpendicular-distance ( oint oint -- distance ) + tuck distance-vector swap 2dup left>> scalar-projection abs + -rot up>> scalar-projection abs + ; + +:: reflect ( v n -- v' ) + #! bounce v on a surface with normal n + v v n v. n n v. / 2 * n n*v v- ; + +: half-way ( p1 p2 -- p3 ) + over v- 2 v/n v+ ; + +: half-way-between-oints ( o1 o2 -- p ) + [ location>> ] bi@ half-way ; diff --git a/extra/jamshred/player/authors.txt b/extra/jamshred/player/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/player/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor new file mode 100644 index 0000000000..418847673b --- /dev/null +++ b/extra/jamshred/player/player.factor @@ -0,0 +1,125 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle system ; +IN: jamshred.player + +TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; + +! speeds are in GL units / second +: default-speed ( -- speed ) 1.0 ; +: max-speed ( -- speed ) 30.0 ; + +: ( name sounds -- player ) + [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip + f f f default-speed player boa ; + +: turn-player ( player x-radians y-radians -- ) + >r over r> left-pivot up-pivot ; + +: roll-player ( player z-radians -- ) + forward-pivot ; + +: to-tunnel-start ( player -- ) + [ tunnel>> first dup location>> ] + [ tuck (>>location) (>>nearest-segment) ] bi ; + +: play-in-tunnel ( player segments -- ) + >>tunnel to-tunnel-start ; + +: update-nearest-segment ( player -- ) + [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] + [ (>>nearest-segment) ] tri ; + +: update-time ( player -- seconds-passed ) + millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; + +: moved ( player -- ) millis swap (>>last-move) ; + +: speed-range ( -- range ) + max-speed [0,b] ; + +: change-player-speed ( inc player -- ) + [ + speed-range clamp-to-range ] change-speed drop ; + +: multiply-player-speed ( n player -- ) + [ * speed-range clamp-to-range ] change-speed drop ; + +: distance-to-move ( seconds-passed player -- distance ) + speed>> * ; + +: bounce ( d-left player -- d-left' player ) + { + [ dup nearest-segment>> bounce-off-wall ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ ] + } cleave ; + +:: (distance) ( heading player -- current next location heading ) + player nearest-segment>> + player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment + player location>> heading ; + +: distance-to-heading-segment ( heading player -- distance ) + (distance) distance-to-next-segment ; + +: distance-to-heading-segment-area ( heading player -- distance ) + (distance) distance-to-next-segment-area ; + +: distance-to-collision ( player -- distance ) + dup nearest-segment>> (distance-to-collision) ; + +: from ( player -- radius distance-from-centre ) + [ nearest-segment>> dup radius>> swap ] [ location>> ] bi + distance-from-centre ; + +: distance-from-wall ( player -- distance ) from - ; +: fraction-from-centre ( player -- fraction ) from swap / ; +: fraction-from-wall ( player -- fraction ) + fraction-from-centre 1 swap - ; + +: update-nearest-segment2 ( heading player -- ) + 2dup distance-to-heading-segment-area 0 <= [ + [ tunnel>> ] [ nearest-segment>> rot heading-segment ] + [ (>>nearest-segment) ] tri + ] [ + 2drop + ] if ; + +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + heading player update-nearest-segment2 + d-left d-to-move - player ] ; + +: move-toward-wall ( d-left player d-to-wall -- d-left' player ) + over [ forward>> ] keep distance-to-heading-segment-area min + over forward>> move-player-on-heading ; + +: ?move-player-freely ( d-left player -- d-left' player ) + over 0 > [ + dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2 + move-toward-wall ?move-player-freely + ] [ drop ] if + ] when ; + +: drag-heading ( player -- heading ) + [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; + +: drag-player ( d-left player -- d-left' player ) + dup [ [ drag-heading ] keep distance-to-heading-segment-area ] + [ drag-heading move-player-on-heading ] bi ; + +: (move-player) ( d-left player -- d-left' player ) + ?move-player-freely over 0 > [ + ! bounce + drag-player + (move-player) + ] when ; + +: move-player ( player -- ) + [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; + +: update-player ( player -- ) + [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; diff --git a/extra/jamshred/sound/bang.wav b/extra/jamshred/sound/bang.wav new file mode 100644 index 0000000000..b15af141ec Binary files /dev/null and b/extra/jamshred/sound/bang.wav differ diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor new file mode 100644 index 0000000000..fd1b1127bd --- /dev/null +++ b/extra/jamshred/sound/sound.factor @@ -0,0 +1,13 @@ +USING: accessors io.files kernel openal sequences ; +IN: jamshred.sound + +TUPLE: sounds bang ; + +: assign-sound ( source wav-path -- ) + resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ; + +: ( -- sounds ) + 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 new file mode 100644 index 0000000000..e26fc1cf8b --- /dev/null +++ b/extra/jamshred/summary.txt @@ -0,0 +1 @@ +A simple 3d tunnel racing game diff --git a/extra/jamshred/tags.txt b/extra/jamshred/tags.txt new file mode 100644 index 0000000000..8ae5957a4b --- /dev/null +++ b/extra/jamshred/tags.txt @@ -0,0 +1,2 @@ +applications +games diff --git a/extra/jamshred/tunnel/authors.txt b/extra/jamshred/tunnel/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/tunnel/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor new file mode 100644 index 0000000000..9486713f55 --- /dev/null +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ; +IN: jamshred.tunnel.tests + +[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } + T{ segment f { 1 1 1 } f f f 1 } + T{ oint f { 0 0 0.25 } } + nearer-segment number>> ] unit-test + +[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment number>> ] unit-test +[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment number>> ] unit-test +[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment number>> ] unit-test + +[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test + +[ F{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test + +: test-segment-oint ( -- oint ) + { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; + +[ { -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 new file mode 100755 index 0000000000..8d2cc8e766 --- /dev/null +++ b/extra/jamshred/tunnel/tunnel.factor @@ -0,0 +1,166 @@ +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; +USE: tools.walker +IN: jamshred.tunnel + +: n-segments ( -- n ) 5000 ; inline + +TUPLE: segment < oint number color radius ; +C: segment + +: segment-number++ ( segment -- ) + [ number>> 1+ ] keep (>>number) ; + +: random-color ( -- color ) + { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ; + +: tunnel-segment-distance ( -- n ) 0.4 ; +: random-rotation-angle ( -- theta ) pi 20 / ; + +: random-segment ( previous-segment -- segment ) + clone dup random-rotation-angle random-turn + tunnel-segment-distance over go-forward + random-color >>color dup segment-number++ ; + +: (random-segments) ( segments n -- segments ) + dup 0 > [ + >r dup peek random-segment over push r> 1- (random-segments) + ] [ drop ] if ; + +: default-segment-radius ( -- r ) 1 ; + +: initial-segment ( -- segment ) + F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } + 0 random-color default-segment-radius ; + +: random-segments ( n -- segments ) + initial-segment 1vector swap (random-segments) ; + +: simple-segment ( n -- segment ) + [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep + random-color default-segment-radius ; + +: 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 + [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; + +: nearer-segment ( segment segment oint -- segment ) + #! return whichever of the two segments is nearer to the oint + >r 2dup r> tuck distance >r distance r> < -rot ? ; + +: (find-nearest-segment) ( nearest next oint -- nearest ? ) + #! find the nearest of 'next' and 'nearest' to 'oint', and return + #! t if the nearest hasn't changed + pick >r nearer-segment dup r> = ; + +: find-nearest-segment ( oint segments -- segment ) + dup first swap rest-slice rot [ (find-nearest-segment) ] curry + find 2drop ; + +: nearest-segment-forward ( segments oint start -- segment ) + rot dup length swap find-nearest-segment ; + +: nearest-segment-backward ( segments oint start -- segment ) + swapd 1+ 0 spin find-nearest-segment ; + +: nearest-segment ( segments oint start-segment -- segment ) + #! find the segment nearest to 'oint', and return it. + #! start looking at segment 'start-segment' + number>> over >r + [ nearest-segment-forward ] 3keep + nearest-segment-backward r> nearer-segment ; + +: get-segment ( segments n -- segment ) + over sequence-index-range clamp-to-range swap nth ; + +: next-segment ( segments current-segment -- segment ) + number>> 1+ get-segment ; + +: previous-segment ( segments current-segment -- segment ) + number>> 1- get-segment ; + +: heading-segment ( segments current-segment heading -- segment ) + #! the next segment on the given heading + over forward>> v. 0 <=> { + { +gt+ [ next-segment ] } + { +lt+ [ previous-segment ] } + { +eq+ [ nip ] } ! current segment + } case ; + +:: distance-to-next-segment ( current next location heading -- distance ) + [let | cf [ current forward>> ] | + cf next location>> v. cf location v. - cf heading v. / ] ; + +:: distance-to-next-segment-area ( current next location heading -- distance ) + [let | cf [ current forward>> ] + h [ next current half-way-between-oints ] | + cf h v. cf location v. - cf heading v. / ] ; + +: vector-to-centre ( seg loc -- v ) + over location>> swap v- swap forward>> proj-perp ; + +: distance-from-centre ( seg loc -- distance ) + vector-to-centre norm ; + +: wall-normal ( seg oint -- n ) + location>> vector-to-centre normalize ; + +: distant ( -- n ) 1000 ; + +: max-real ( a b -- c ) + #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) + dup real? [ + over real? [ max ] [ nip ] if + ] [ + drop dup real? [ drop distant ] unless + ] if ; + +:: collision-coefficient ( v w r -- c ) + v norm 0 = [ + distant + ] [ + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. r sq - ] | + c b a quadratic max-real ] + ] if ; + +: sideways-heading ( oint segment -- v ) + [ forward>> ] bi@ proj-perp ; + +: sideways-relative-location ( oint segment -- loc ) + [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; + +: (distance-to-collision) ( oint segment -- distance ) + [ sideways-heading ] [ sideways-relative-location ] + [ nip radius>> ] 2tri collision-coefficient ; + +: collision-vector ( oint segment -- v ) + dupd (distance-to-collision) swap forward>> n*v ; + +: bounce-forward ( segment oint -- ) + [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; + +: bounce-left ( segment oint -- ) + #! must be done after forward + [ forward>> vneg ] dip [ left>> swap reflect ] + [ forward>> proj-perp normalize ] [ (>>left) ] tri ; + +: bounce-up ( segment oint -- ) + #! must be done after forward and left! + nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; + +: bounce-off-wall ( oint segment -- ) + swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; + diff --git a/extra/tetris/README.txt b/extra/tetris/README.txt new file mode 100644 index 0000000000..e8f81fc831 --- /dev/null +++ b/extra/tetris/README.txt @@ -0,0 +1,17 @@ +This is a simple tetris game. To play, open factor (in GUI mode), and run: + +"tetris" run + +This should open a new window with a running tetris game. The commands are: + +left, right arrows: move the current piece left or right +up arrow: rotate the piece clockwise +down arrow: lower the piece one row +space bar: drop the piece +p: pause/unpause +n: start a new game + +TODO: +- rotation of pieces when they're on the far right of the board +- make blocks prettier +- possibly make piece inherit from tetromino diff --git a/extra/tetris/authors.txt b/extra/tetris/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/board/authors.txt b/extra/tetris/board/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/board/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor new file mode 100644 index 0000000000..518b5544e9 --- /dev/null +++ b/extra/tetris/board/board-tests.factor @@ -0,0 +1,23 @@ +USING: accessors arrays colors kernel tetris.board tetris.piece tools.test ; + +[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test +[ { { f f } { f f } { f f } } ] [ 2 3 rows>> ] unit-test +[ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test +[ f ] [ 2 3 { 1 1 } block ] unit-test +[ 2 3 { 2 3 } block ] must-fail +red 1array [ 2 3 dup { 1 1 } red set-block { 1 1 } block ] unit-test +[ t ] [ 2 3 { 1 1 } block-free? ] unit-test +[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test +[ t ] [ 2 3 { 0 0 } block-in-bounds? ] unit-test +[ f ] [ 2 3 { -1 0 } block-in-bounds? ] unit-test +[ t ] [ 2 3 { 1 2 } block-in-bounds? ] unit-test +[ f ] [ 2 3 { 2 2 } block-in-bounds? ] unit-test +[ t ] [ 2 3 { 1 1 } location-valid? ] unit-test +[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test +[ t ] [ 10 10 10 piece-valid? ] unit-test +[ f ] [ 2 3 10 { 1 2 } >>location piece-valid? ] unit-test +[ { { f } { f } } ] [ 1 1 add-row rows>> ] unit-test +[ { { f } } ] [ 1 2 dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test +[ { { f } { f } } ] [ 1 2 dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor new file mode 100644 index 0000000000..1f12dcabe6 --- /dev/null +++ b/extra/tetris/board/board.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2006, 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel math sequences tetris.piece ; +IN: tetris.board + +TUPLE: board { width integer } { height integer } rows ; + +: make-rows ( width height -- rows ) + [ drop f ] with map ; + +: ( width height -- board ) + 2dup make-rows board boa ; + +#! A block is simply an array of form { x y } where { 0 0 } is the top-left of +#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board. + +: board@block ( board block -- n row ) + [ second swap rows>> nth ] keep first swap ; + +: set-block ( board block colour -- ) -rot board@block set-nth ; + +: block ( board block -- colour ) board@block nth ; + +: block-free? ( board block -- ? ) block not ; + +: block-in-bounds? ( board block -- ? ) + [ first swap width>> bounds-check? ] 2keep + second swap height>> bounds-check? and ; + +: location-valid? ( board block -- ? ) + 2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ; + +: piece-valid? ( board piece -- ? ) + piece-blocks [ location-valid? ] with all? ; + +: row-not-full? ( row -- ? ) f swap member? ; + +: add-row ( board -- board ) + dup rows>> over width>> f prefix >>rows ; + +: top-up-rows ( board -- ) + dup height>> over rows>> length = [ + drop + ] [ + add-row top-up-rows + ] if ; + +: remove-full-rows ( board -- board ) + [ [ row-not-full? ] filter ] change-rows ; + +: check-rows ( board -- n ) + #! remove full rows, then add blank ones at the top, returning the number + #! of rows removed (and added) + remove-full-rows dup height>> over rows>> length - swap top-up-rows ; + diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor new file mode 100755 index 0000000000..57a5eda494 --- /dev/null +++ b/extra/tetris/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-name "Tetris" } +} diff --git a/extra/tetris/game/authors.txt b/extra/tetris/game/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/game/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/game/game-tests.factor b/extra/tetris/game/game-tests.factor new file mode 100644 index 0000000000..047c20d053 --- /dev/null +++ b/extra/tetris/game/game-tests.factor @@ -0,0 +1,16 @@ +USING: accessors kernel tetris.game tetris.board tetris.piece tools.test +sequences ; + +[ t ] [ [ current-piece ] [ next-piece ] bi and t f ? ] unit-test +[ t ] [ { 1 1 } can-move? ] unit-test +[ t ] [ { 1 1 } tetris-move ] unit-test +[ 1 ] [ dup { 1 1 } tetris-move drop current-piece location>> second ] unit-test +[ 1 ] [ level>> ] unit-test +[ 1 ] [ 9 >>rows level>> ] unit-test +[ 2 ] [ 10 >>rows level>> ] unit-test +[ 0 ] [ 3 0 rows-score ] unit-test +[ 80 ] [ 1 1 rows-score ] unit-test +[ 4800 ] [ 3 4 rows-score ] unit-test +[ 1 ] [ dup 3 score-rows dup 3 score-rows dup 3 score-rows level>> ] unit-test +[ 2 ] [ dup 4 score-rows dup 4 score-rows dup 2 score-rows level>> ] unit-test + diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor new file mode 100644 index 0000000000..30622c9e38 --- /dev/null +++ b/extra/tetris/game/game.factor @@ -0,0 +1,114 @@ +! Copyright (C) 2006, 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators kernel lists math math.functions sequences system tetris.board tetris.piece tetris.tetromino ; +IN: tetris.game + +TUPLE: tetris + { board board } + { pieces } + { last-update integer initial: 0 } + { rows integer initial: 0 } + { score integer initial: 0 } + { paused? initial: f } + { running? initial: t } ; + +: default-width 10 ; inline +: default-height 20 ; inline + +: ( width height -- tetris ) + dupd swap + tetris new swap >>pieces swap >>board ; + +: ( -- tetris ) default-width default-height ; + +: ( old -- new ) + board>> [ width>> ] [ height>> ] bi ; + +: current-piece ( tetris -- piece ) pieces>> car ; + +: next-piece ( tetris -- piece ) pieces>> cdr car ; + +: toggle-pause ( tetris -- ) + [ not ] change-paused? drop ; + +: level>> ( tetris -- level ) + rows>> 1+ 10 / ceiling ; + +: update-interval ( tetris -- interval ) + level>> 1- 60 * 1000 swap - ; + +: add-block ( tetris block -- ) + over board>> spin current-piece tetromino>> colour>> set-block ; + +: game-over? ( tetris -- ? ) + [ board>> ] [ next-piece ] bi piece-valid? not ; + +: new-current-piece ( tetris -- tetris ) + dup game-over? [ + f >>running? + ] [ + [ cdr ] change-pieces + ] if ; + +: rows-score ( level n -- score ) + { + { 0 [ 0 ] } + { 1 [ 40 ] } + { 2 [ 100 ] } + { 3 [ 300 ] } + { 4 [ 1200 ] } + } case swap 1+ * ; + +: add-score ( tetris n-rows -- tetris ) + over level>> swap rows-score swap [ + ] change-score ; + +: add-rows ( tetris rows -- tetris ) + swap [ + ] change-rows ; + +: score-rows ( tetris n -- ) + [ add-score ] keep add-rows drop ; + +: lock-piece ( tetris -- ) + [ dup current-piece piece-blocks [ add-block ] with each ] keep + new-current-piece dup board>> check-rows score-rows ; + +: can-rotate? ( tetris -- ? ) + [ board>> ] [ current-piece clone 1 rotate-piece ] bi piece-valid? ; + +: (rotate) ( inc tetris -- ) + dup can-rotate? [ current-piece swap rotate-piece drop ] [ 2drop ] if ; + +: rotate-left ( tetris -- ) -1 swap (rotate) ; + +: rotate-right ( tetris -- ) 1 swap (rotate) ; + +: can-move? ( tetris move -- ? ) + [ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ; + +: tetris-move ( tetris move -- ? ) + #! moves the piece if possible, returns whether the piece was moved + 2dup can-move? [ + >r current-piece r> move-piece drop t + ] [ + 2drop f + ] if ; + +: move-left ( tetris -- ) { -1 0 } tetris-move drop ; + +: move-right ( tetris -- ) { 1 0 } tetris-move drop ; + +: move-down ( tetris -- ) + dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ; + +: move-drop ( tetris -- ) + dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ; + +: update ( tetris -- ) + millis over last-update>> - + over update-interval > [ + dup move-down + millis >>last-update + ] when drop ; + +: ?update ( tetris -- ) + dup [ paused?>> ] [ running?>> not ] bi or [ drop ] [ update ] if ; diff --git a/extra/tetris/gl/authors.txt b/extra/tetris/gl/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/gl/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor new file mode 100644 index 0000000000..d47f027293 --- /dev/null +++ b/extra/tetris/gl/gl.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2006, 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators kernel math math.vectors namespaces opengl opengl.gl sequences tetris.board tetris.game tetris.piece ui.render tetris.tetromino ui.gadgets ; +IN: tetris.gl + +#! OpenGL rendering for tetris + +: draw-block ( block -- ) + dup { 1 1 } v+ gl-fill-rect ; + +: draw-piece-blocks ( piece -- ) + piece-blocks [ draw-block ] each ; + +: draw-piece ( piece -- ) + dup tetromino>> colour>> set-color draw-piece-blocks ; + +: draw-next-piece ( piece -- ) + dup tetromino>> colour>> + clone 0.2 >>alpha set-color draw-piece-blocks ; + +! TODO: move implementation specific stuff into tetris-board +: (draw-row) ( x y row -- ) + >r over r> nth dup + [ set-color 2array draw-block ] [ 3drop ] if ; + +: draw-row ( y row -- ) + dup length -rot [ (draw-row) ] 2curry each ; + +: draw-board ( board -- ) + rows>> dup length swap + [ dupd nth draw-row ] curry each ; + +: scale-board ( width height board -- ) + [ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ; + +: (draw-tetris) ( width height tetris -- ) + #! width and height are in pixels + GL_MODELVIEW [ + { + [ board>> scale-board ] + [ board>> draw-board ] + [ next-piece draw-next-piece ] + [ current-piece draw-piece ] + } cleave + ] do-matrix ; + +: draw-tetris ( width height tetris -- ) + origin get [ (draw-tetris) ] with-translation ; diff --git a/extra/tetris/piece/authors.txt b/extra/tetris/piece/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/piece/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/piece/piece-tests.factor b/extra/tetris/piece/piece-tests.factor new file mode 100644 index 0000000000..05e4faa68f --- /dev/null +++ b/extra/tetris/piece/piece-tests.factor @@ -0,0 +1,23 @@ +USING: accessors kernel tetris.tetromino tetris.piece tools.test sequences arrays namespaces ; + +! Tests for tetris.tetromino and tetris.piece, since there's not much to test in tetris.tetromino + +! these two tests rely on the first rotation of the first tetromino being the +! 'I' tetromino in its vertical orientation. +[ 4 ] [ tetrominoes get first states>> first blocks-width ] unit-test +[ 1 ] [ tetrominoes get first states>> first blocks-height ] unit-test + +[ { 0 0 } ] [ random-tetromino location>> ] unit-test +[ 0 ] [ 10 rotation>> ] unit-test + +[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ] +[ tetrominoes get first piece-blocks ] unit-test + +[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ] +[ tetrominoes get first 1 rotate-piece piece-blocks ] unit-test + +[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ] +[ tetrominoes get first { 1 1 } move-piece piece-blocks ] unit-test + +[ 3 ] [ tetrominoes get second piece-width ] unit-test +[ 2 ] [ tetrominoes get second 1 rotate-piece piece-width ] unit-test diff --git a/extra/tetris/piece/piece.factor b/extra/tetris/piece/piece.factor new file mode 100644 index 0000000000..2ebbfc07d6 --- /dev/null +++ b/extra/tetris/piece/piece.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2006, 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel math math.vectors sequences tetris.tetromino lists.lazy ; +IN: tetris.piece + +#! The rotation is an index into the tetromino's states array, and the +#! position is added to the tetromino's blocks to give them their location on the +#! tetris board. If the location is f then the piece is not yet on the board. + +TUPLE: piece + { tetromino tetromino } + { rotation integer initial: 0 } + { location array initial: { 0 0 } } ; + +: ( tetromino -- piece ) + piece new swap >>tetromino ; + +: (piece-blocks) ( piece -- blocks ) + #! rotates the piece + [ rotation>> ] [ tetromino>> states>> ] bi nth ; + +: piece-blocks ( piece -- blocks ) + #! rotates and positions the piece + [ (piece-blocks) ] [ location>> ] bi [ v+ ] curry map ; + +: piece-width ( piece -- width ) + piece-blocks blocks-width ; + +: set-start-location ( piece board-width -- piece ) + over piece-width [ 2 /i ] bi@ - 0 2array >>location ; + +: ( board-width -- piece ) + random-tetromino swap set-start-location ; + +: ( board-width -- llist ) + [ [ ] curry ] keep [ ] curry lazy-cons ; + +: modulo ( n m -- n ) + #! -2 7 mod => -2, -2 7 modulo => 5 + tuck mod over + swap mod ; + +: (rotate-piece) ( rotation inc n-states -- rotation' ) + [ + ] dip modulo ; + +: rotate-piece ( piece inc -- piece ) + over tetromino>> states>> length + [ (rotate-piece) ] 2curry change-rotation ; + +: move-piece ( piece move -- piece ) + [ v+ ] curry change-location ; diff --git a/extra/tetris/summary.txt b/extra/tetris/summary.txt new file mode 100644 index 0000000000..9352d40cdb --- /dev/null +++ b/extra/tetris/summary.txt @@ -0,0 +1 @@ +Graphical Tetris game diff --git a/extra/tetris/tags.txt b/extra/tetris/tags.txt new file mode 100644 index 0000000000..09934571b3 --- /dev/null +++ b/extra/tetris/tags.txt @@ -0,0 +1,3 @@ +demos +applications +games diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor new file mode 100644 index 0000000000..b200c4d735 --- /dev/null +++ b/extra/tetris/tetris.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2006, 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alarms arrays calendar kernel make math math.geometry.rect math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ; +IN: tetris + +TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ; + +: ( tetris -- gadget ) + tetris-gadget new-gadget swap >>tetris ; + +M: tetris-gadget pref-dim* drop { 200 400 } ; + +: update-status ( gadget -- ) + dup tetris>> [ + "Level: " % dup level>> # + " Score: " % score>> # + ] "" make swap show-status ; + +M: tetris-gadget draw-gadget* ( gadget -- ) + [ + dup rect-dim [ first ] [ second ] bi rot tetris>> draw-tetris + ] keep update-status ; + +: new-tetris ( gadget -- gadget ) + [ ] change-tetris ; + +tetris-gadget H{ + { T{ key-down f f "UP" } [ tetris>> rotate-right ] } + { T{ key-down f f "d" } [ tetris>> rotate-left ] } + { T{ key-down f f "f" } [ tetris>> rotate-right ] } + { T{ key-down f f "e" } [ tetris>> rotate-left ] } ! dvorak d + { T{ key-down f f "u" } [ tetris>> rotate-right ] } ! dvorak f + { T{ key-down f f "LEFT" } [ tetris>> move-left ] } + { T{ key-down f f "RIGHT" } [ tetris>> move-right ] } + { T{ key-down f f "DOWN" } [ tetris>> move-down ] } + { T{ key-down f f " " } [ tetris>> move-drop ] } + { T{ key-down f f "p" } [ tetris>> toggle-pause ] } + { T{ key-down f f "n" } [ new-tetris drop ] } +} set-gestures + +: tick ( gadget -- ) + [ tetris>> ?update ] [ relayout-1 ] bi ; + +M: tetris-gadget graft* ( gadget -- ) + [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ; + +M: tetris-gadget ungraft* ( gadget -- ) + [ cancel-alarm f ] change-alarm drop ; + +: tetris-window ( -- ) + [ + + "Tetris" open-status-window + ] with-ui ; + +MAIN: tetris-window diff --git a/extra/tetris/tetromino/authors.txt b/extra/tetris/tetromino/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/tetromino/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/tetromino/tetromino.factor b/extra/tetris/tetromino/tetromino.factor new file mode 100644 index 0000000000..7e6b2ecf34 --- /dev/null +++ b/extra/tetris/tetromino/tetromino.factor @@ -0,0 +1,114 @@ +! Copyright (C) 2006, 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel arrays namespaces sequences math math.vectors +colors random ; +IN: tetris.tetromino + +TUPLE: tetromino states colour ; + +C: tetromino + +SYMBOL: tetrominoes + +{ + [ + { { + { 0 0 } { 1 0 } { 2 0 } { 3 0 } + } + { { 0 0 } + { 0 1 } + { 0 2 } + { 0 3 } + } + } cyan + ] [ + { + { { 1 0 } + { 0 1 } { 1 1 } { 2 1 } + } { + { 0 0 } + { 0 1 } { 1 1 } + { 0 2 } + } { + { 0 0 } { 1 0 } { 2 0 } + { 1 1 } + } { + { 1 0 } + { 0 1 } { 1 1 } + { 1 2 } + } + } purple + ] [ + { { { 0 0 } { 1 0 } + { 0 1 } { 1 1 } } + } yellow + ] [ + { + { { 0 0 } { 1 0 } { 2 0 } + { 0 1 } + } { + { 0 0 } { 1 0 } + { 1 1 } + { 1 2 } + } { + { 2 0 } + { 0 1 } { 1 1 } { 2 1 } + } { + { 0 0 } + { 0 1 } + { 0 2 } { 1 2 } + } + } orange + ] [ + { + { { 0 0 } { 1 0 } { 2 0 } + { 2 1 } + } { + { 1 0 } + { 1 1 } + { 0 2 } { 1 2 } + } { + { 0 0 } + { 0 1 } { 1 1 } { 2 1 } + } { + { 0 0 } { 1 0 } + { 0 1 } + { 0 2 } + } + } blue + ] [ + { + { { 1 0 } { 2 0 } + { 0 1 } { 1 1 } + } { + { 0 0 } + { 0 1 } { 1 1 } + { 1 2 } + } + } green + ] [ + { + { + { 0 0 } { 1 0 } + { 1 1 } { 2 1 } + } { + { 1 0 } + { 0 1 } { 1 1 } + { 0 2 } + } + } red + ] +} [ call ] map tetrominoes set-global + +: random-tetromino ( -- tetromino ) + tetrominoes get random ; + +: blocks-max ( blocks quot -- max ) + map [ 1+ ] map supremum ; inline + +: blocks-width ( blocks -- width ) + [ first ] blocks-max ; + +: blocks-height ( blocks -- height ) + [ second ] blocks-max ; + diff --git a/unmaintained/digraphs/authors.txt b/unmaintained/digraphs/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/unmaintained/digraphs/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/digraphs/digraphs-tests.factor b/unmaintained/digraphs/digraphs-tests.factor deleted file mode 100644 index b113c18ca7..0000000000 --- a/unmaintained/digraphs/digraphs-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: digraphs kernel sequences tools.test ; -IN: digraphs.tests - -: test-digraph ( -- digraph ) - - { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each - { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ; - -[ 5 ] [ test-digraph topological-sort length ] unit-test diff --git a/unmaintained/digraphs/digraphs.factor b/unmaintained/digraphs/digraphs.factor deleted file mode 100755 index 7d56c96034..0000000000 --- a/unmaintained/digraphs/digraphs.factor +++ /dev/null @@ -1,50 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel sequences vectors ; -IN: digraphs - -TUPLE: digraph ; -TUPLE: vertex value edges ; - -: ( -- digraph ) - digraph new H{ } clone over set-delegate ; - -: ( value -- vertex ) - V{ } clone vertex boa ; - -: add-vertex ( key value digraph -- ) - >r swap r> set-at ; - -: children ( key digraph -- seq ) - at edges>> ; - -: @edges ( from to digraph -- to edges ) swapd at edges>> ; -: add-edge ( from to digraph -- ) @edges push ; -: delete-edge ( from to digraph -- ) @edges delete ; - -: delete-to-edges ( to digraph -- ) - [ nip dupd edges>> delete ] assoc-each drop ; - -: delete-vertex ( key digraph -- ) - 2dup delete-at delete-to-edges ; - -: unvisited? ( unvisited key -- ? ) swap key? ; -: visited ( unvisited key -- ) swap delete-at ; - -DEFER: (topological-sort) -: visit-children ( seq unvisited key -- seq unvisited ) - over children [ (topological-sort) ] each ; - -: (topological-sort) ( seq unvisited key -- seq unvisited ) - 2dup unvisited? [ - [ visit-children ] keep 2dup visited pick push - ] [ - drop - ] if ; - -: topological-sort ( digraph -- seq ) - dup clone V{ } clone spin - [ drop (topological-sort) ] assoc-each drop reverse ; - -: topological-sorted-values ( digraph -- seq ) - dup topological-sort swap [ at value>> ] curry map ; diff --git a/unmaintained/digraphs/summary.txt b/unmaintained/digraphs/summary.txt deleted file mode 100644 index 78e5a53313..0000000000 --- a/unmaintained/digraphs/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Simple directed graph implementation for topological sorting diff --git a/unmaintained/digraphs/tags.txt b/unmaintained/digraphs/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/unmaintained/digraphs/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/unmaintained/jamshred/authors.txt b/unmaintained/jamshred/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/unmaintained/jamshred/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/jamshred/deploy.factor b/unmaintained/jamshred/deploy.factor deleted file mode 100644 index 9a18cf1f9b..0000000000 --- a/unmaintained/jamshred/deploy.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: tools.deploy.config ; -V{ - { deploy-ui? t } - { deploy-io 1 } - { deploy-reflection 1 } - { deploy-compiler? t } - { deploy-math? t } - { deploy-word-props? f } - { deploy-c-types? f } - { "stop-after-last-window?" t } - { deploy-name "Jamshred" } -} diff --git a/unmaintained/jamshred/game/authors.txt b/unmaintained/jamshred/game/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/jamshred/game/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/jamshred/game/game.factor b/unmaintained/jamshred/game/game.factor deleted file mode 100644 index 938605ce9f..0000000000 --- a/unmaintained/jamshred/game/game.factor +++ /dev/null @@ -1,40 +0,0 @@ -! Copyright (C) 2007 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 ; - -: units-per-full-roll ( -- n ) 50 ; - -: jamshred-roll ( jamshred n -- ) - [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ; - -: mouse-scroll-x ( jamshred x -- ) jamshred-roll ; - -: mouse-scroll-y ( jamshred y -- ) - neg swap jamshred-player change-player-speed ; diff --git a/unmaintained/jamshred/gl/authors.txt b/unmaintained/jamshred/gl/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/jamshred/gl/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/jamshred/gl/gl.factor b/unmaintained/jamshred/gl/gl.factor deleted file mode 100644 index 52caaa10c9..0000000000 --- a/unmaintained/jamshred/gl/gl.factor +++ /dev/null @@ -1,98 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types colors jamshred.game -jamshred.oint jamshred.player jamshred.tunnel kernel math -math.constants math.functions math.vectors opengl opengl.gl -opengl.glu sequences float-arrays ; -IN: jamshred.gl - -: min-vertices 6 ; inline -: max-vertices 32 ; inline - -: n-vertices ( -- n ) 32 ; inline - -! render enough of the tunnel that it looks continuous -: n-segments-ahead ( -- n ) 60 ; inline -: n-segments-behind ( -- n ) 40 ; inline - -: wall-drawing-offset ( -- n ) - #! so that we can't see through the wall, we draw it a bit further away - 0.15 ; - -: wall-drawing-radius ( segment -- r ) - radius>> wall-drawing-offset + ; - -: wall-up ( segment -- v ) - [ wall-drawing-radius ] [ up>> ] bi n*v ; - -: wall-left ( segment -- v ) - [ wall-drawing-radius ] [ left>> ] bi n*v ; - -: segment-vertex ( theta segment -- vertex ) - [ - [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+ - ] [ - location>> v+ - ] bi ; - -: segment-vertex-normal ( vertex segment -- normal ) - location>> swap v- normalize ; - -: segment-vertex-and-normal ( segment theta -- vertex normal ) - swap [ segment-vertex ] keep dupd segment-vertex-normal ; - -: equally-spaced-radians ( n -- seq ) - #! return a sequence of n numbers between 0 and 2pi - dup [ / pi 2 * * ] curry map ; -: draw-segment-vertex ( segment theta -- ) - over segment-color gl-color segment-vertex-and-normal - gl-normal gl-vertex ; - -: draw-vertex-pair ( theta next-segment segment -- ) - rot tuck draw-segment-vertex draw-segment-vertex ; - -: draw-segment ( next-segment segment -- ) - GL_QUAD_STRIP [ - [ draw-vertex-pair ] 2curry - n-vertices equally-spaced-radians F{ 0.0 } append swap each - ] do-state ; - -: draw-segments ( segments -- ) - 1 over length pick subseq swap [ draw-segment ] 2each ; - -: segments-to-render ( player -- segments ) - dup player-nearest-segment segment-number dup n-segments-behind - - swap n-segments-ahead + rot player-tunnel sub-tunnel ; - -: draw-tunnel ( player -- ) - segments-to-render draw-segments ; - -: init-graphics ( width height -- ) - GL_DEPTH_TEST glEnable - GL_SCISSOR_TEST glDisable - 1.0 glClearDepth - 0.0 0.0 0.0 0.0 glClearColor - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - GL_PROJECTION glMatrixMode glLoadIdentity - dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if - GL_MODELVIEW glMatrixMode glLoadIdentity - GL_LEQUAL glDepthFunc - GL_LIGHTING glEnable - GL_LIGHT0 glEnable - GL_FOG glEnable - GL_FOG_DENSITY 0.09 glFogf - GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial - GL_COLOR_MATERIAL glEnable - GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; - -: player-view ( player -- ) - [ location>> ] - [ [ location>> ] [ forward>> ] bi v+ ] - [ up>> ] tri gl-look-at ; - -: draw-jamshred ( jamshred width height -- ) - init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ; - diff --git a/unmaintained/jamshred/jamshred.factor b/unmaintained/jamshred/jamshred.factor deleted file mode 100755 index d9a0f84b53..0000000000 --- a/unmaintained/jamshred/jamshred.factor +++ /dev/null @@ -1,97 +0,0 @@ -! Copyright (C) 2007, 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl -jamshred.player jamshred.log kernel math math.constants namespaces -sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds -ui.gestures ui.render math.vectors math.geometry.rect ; -IN: jamshred - -TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; - -: ( jamshred -- gadget ) - jamshred-gadget construct-gadget swap >>jamshred ; - -: default-width ( -- x ) 800 ; -: default-height ( -- y ) 600 ; - -M: jamshred-gadget pref-dim* - drop default-width default-height 2array ; - -M: jamshred-gadget draw-gadget* ( gadget -- ) - [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ; - -: jamshred-loop ( gadget -- ) - dup jamshred>> quit>> [ - drop - ] [ - [ jamshred>> jamshred-update ] - [ relayout-1 ] - [ yield jamshred-loop ] tri - ] if ; - -: fullscreen ( gadget -- ) - find-world t swap set-fullscreen* ; - -: no-fullscreen ( gadget -- ) - find-world f swap set-fullscreen* ; - -: toggle-fullscreen ( world -- ) - [ fullscreen? not ] keep set-fullscreen* ; - -M: jamshred-gadget graft* ( gadget -- ) - [ jamshred-loop ] in-thread drop ; - -M: jamshred-gadget ungraft* ( gadget -- ) - 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 - rect-dim first pix>radians neg ; - -: y>radians ( y gadget -- theta ) - #! translate motion of y pixels to an angle - rect-dim second pix>radians ; - -: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) - over jamshred>> >r - [ first swap x>radians ] 2keep second swap y>radians - r> mouse-moved ; - -: handle-mouse-motion ( jamshred-gadget -- ) - hand-loc get [ - over last-hand-loc>> [ - v- (handle-mouse-motion) - ] [ 2drop ] if* - ] 2keep >>last-hand-loc drop ; - -: handle-mouse-scroll ( jamshred-gadget -- ) - jamshred>> scroll-direction get - [ first mouse-scroll-x ] - [ second mouse-scroll-y ] 2bi ; - -: quit ( gadget -- ) - [ no-fullscreen ] [ close-window ] bi ; - -jamshred-gadget H{ - { T{ key-down f f "r" } [ jamshred-restart ] } - { T{ key-down f f " " } [ jamshred>> toggle-running ] } - { T{ key-down f f "f" } [ find-world toggle-fullscreen ] } - { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] } - { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] } - { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] } - { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] } - { T{ key-down f f "q" } [ quit ] } - { T{ motion } [ handle-mouse-motion ] } - { T{ mouse-scroll } [ handle-mouse-scroll ] } -} set-gestures - -: jamshred-window ( -- jamshred ) - [ dup "Jamshred" open-window ] with-ui ; - -MAIN: jamshred-window diff --git a/unmaintained/jamshred/log/log.factor b/unmaintained/jamshred/log/log.factor deleted file mode 100644 index 33498d8a2e..0000000000 --- a/unmaintained/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 ; - -: jamshred-log ( message -- ) - [ (jamshred-log) ] with-jamshred-log ; ! ugly... diff --git a/unmaintained/jamshred/oint/authors.txt b/unmaintained/jamshred/oint/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/jamshred/oint/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/jamshred/oint/oint-tests.factor b/unmaintained/jamshred/oint/oint-tests.factor deleted file mode 100644 index 401935fd01..0000000000 --- a/unmaintained/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/unmaintained/jamshred/oint/oint.factor b/unmaintained/jamshred/oint/oint.factor deleted file mode 100644 index 7a37646a6d..0000000000 --- a/unmaintained/jamshred/oint/oint.factor +++ /dev/null @@ -1,73 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; -IN: jamshred.oint - -! An oint is a point with three linearly independent unit vectors -! given relative to that point. In jamshred a player's location and -! direction are given by the player's oint. Similarly, a tunnel -! segment's location and orientation are given by an oint. - -TUPLE: oint location forward up left ; -C: oint - -: rotation-quaternion ( theta axis -- quaternion ) - swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; - -: rotate-vector ( q qrecip v -- v ) - v>q swap q* q* q>v ; - -: rotate-oint ( oint theta axis -- ) - rotation-quaternion dup qrecip pick - [ forward>> rotate-vector >>forward ] - [ up>> rotate-vector >>up ] - [ left>> rotate-vector >>left ] 3tri drop ; - -: left-pivot ( oint theta -- ) - over left>> rotate-oint ; - -: up-pivot ( oint theta -- ) - over up>> rotate-oint ; - -: forward-pivot ( oint theta -- ) - over forward>> rotate-oint ; - -: random-float+- ( n -- m ) - #! find a random float between -n/2 and n/2 - dup 10000 * >fixnum random 10000 / swap 2 / - ; - -: random-turn ( oint theta -- ) - 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; - -: location+ ( v oint -- ) - [ location>> v+ ] [ (>>location) ] bi ; - -: go-forward ( distance oint -- ) - [ forward>> n*v ] [ location+ ] bi ; - -: distance-vector ( oint oint -- vector ) - [ location>> ] bi@ swap v- ; - -: distance ( oint oint -- distance ) - distance-vector norm ; - -: scalar-projection ( v1 v2 -- n ) - #! the scalar projection of v1 onto v2 - tuck v. swap norm / ; - -: proj-perp ( u v -- w ) - dupd proj v- ; - -: perpendicular-distance ( oint oint -- distance ) - tuck distance-vector swap 2dup left>> scalar-projection abs - -rot up>> scalar-projection abs + ; - -:: reflect ( v n -- v' ) - #! bounce v on a surface with normal n - v v n v. n n v. / 2 * n n*v v- ; - -: half-way ( p1 p2 -- p3 ) - over v- 2 v/n v+ ; - -: half-way-between-oints ( o1 o2 -- p ) - [ location>> ] bi@ half-way ; diff --git a/unmaintained/jamshred/player/authors.txt b/unmaintained/jamshred/player/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/jamshred/player/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/jamshred/player/player.factor b/unmaintained/jamshred/player/player.factor deleted file mode 100644 index 48ea847db1..0000000000 --- a/unmaintained/jamshred/player/player.factor +++ /dev/null @@ -1,128 +0,0 @@ -! Copyright (C) 2007, 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors combinators jamshred.log jamshred.oint -jamshred.sound jamshred.tunnel kernel locals math math.constants -math.order math.ranges math.vectors math.matrices shuffle -sequences system float-arrays ; -IN: jamshred.player - -TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; - -! speeds are in GL units / second -: default-speed ( -- speed ) 1.0 ; -: max-speed ( -- speed ) 30.0 ; - -: ( name sounds -- player ) - [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip - f f f default-speed player boa ; - -: turn-player ( player x-radians y-radians -- ) - >r over r> left-pivot up-pivot ; - -: roll-player ( player z-radians -- ) - forward-pivot ; - -: to-tunnel-start ( player -- ) - [ tunnel>> first dup location>> ] - [ tuck (>>location) (>>nearest-segment) ] bi ; - -: play-in-tunnel ( player segments -- ) - >>tunnel to-tunnel-start ; - -: update-nearest-segment ( player -- ) - [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] - [ (>>nearest-segment) ] tri ; - -: update-time ( player -- seconds-passed ) - millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; - -: moved ( player -- ) millis swap (>>last-move) ; - -: speed-range ( -- range ) - max-speed [0,b] ; - -: change-player-speed ( inc player -- ) - [ + speed-range clamp-to-range ] change-speed drop ; - -: multiply-player-speed ( n player -- ) - [ * speed-range clamp-to-range ] change-speed drop ; - -: distance-to-move ( seconds-passed player -- distance ) - speed>> * ; - -: bounce ( d-left player -- d-left' player ) - { - [ dup nearest-segment>> bounce-off-wall ] - [ sounds>> bang ] - [ 3/4 swap multiply-player-speed ] - [ ] - } cleave ; - -:: (distance) ( heading player -- current next location heading ) - player nearest-segment>> - player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment - player location>> heading ; - -: distance-to-heading-segment ( heading player -- distance ) - (distance) distance-to-next-segment ; - -: distance-to-heading-segment-area ( heading player -- distance ) - (distance) distance-to-next-segment-area ; - -: distance-to-collision ( player -- distance ) - dup nearest-segment>> (distance-to-collision) ; - -: from ( player -- radius distance-from-centre ) - [ nearest-segment>> dup radius>> swap ] [ location>> ] bi - distance-from-centre ; - -: distance-from-wall ( player -- distance ) from - ; -: fraction-from-centre ( player -- fraction ) from swap / ; -: fraction-from-wall ( player -- fraction ) - fraction-from-centre 1 swap - ; - -: update-nearest-segment2 ( heading player -- ) - 2dup distance-to-heading-segment-area 0 <= [ - [ tunnel>> ] [ nearest-segment>> rot heading-segment ] - [ (>>nearest-segment) ] tri - ] [ - 2drop - ] if ; - -:: move-player-on-heading ( d-left player distance heading -- d-left' player ) - [let* | d-to-move [ d-left distance min ] - move-v [ d-to-move heading n*v ] | - move-v player location+ - heading player update-nearest-segment2 - d-left d-to-move - player ] ; - -: move-toward-wall ( d-left player d-to-wall -- d-left' player ) - over [ forward>> ] keep distance-to-heading-segment-area min - over forward>> move-player-on-heading ; - -: ?move-player-freely ( d-left player -- d-left' player ) - over 0 > [ - dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2 - move-toward-wall ?move-player-freely - ] [ drop ] if - ] when ; - -: drag-heading ( player -- heading ) - [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; - -: drag-player ( d-left player -- d-left' player ) - dup [ [ drag-heading ] keep distance-to-heading-segment-area ] - [ drag-heading move-player-on-heading ] bi ; - -: (move-player) ( d-left player -- d-left' player ) - ?move-player-freely over 0 > [ - ! bounce - drag-player - (move-player) - ] when ; - -: move-player ( player -- ) - [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; - -: update-player ( player -- ) - [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; diff --git a/unmaintained/jamshred/sound/bang.wav b/unmaintained/jamshred/sound/bang.wav deleted file mode 100644 index b15af141ec..0000000000 Binary files a/unmaintained/jamshred/sound/bang.wav and /dev/null differ diff --git a/unmaintained/jamshred/sound/sound.factor b/unmaintained/jamshred/sound/sound.factor deleted file mode 100644 index fd1b1127bd..0000000000 --- a/unmaintained/jamshred/sound/sound.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: accessors io.files kernel openal sequences ; -IN: jamshred.sound - -TUPLE: sounds bang ; - -: assign-sound ( source wav-path -- ) - resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ; - -: ( -- sounds ) - 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 deleted file mode 100644 index e26fc1cf8b..0000000000 --- a/unmaintained/jamshred/summary.txt +++ /dev/null @@ -1 +0,0 @@ -A simple 3d tunnel racing game diff --git a/unmaintained/jamshred/tags.txt b/unmaintained/jamshred/tags.txt deleted file mode 100644 index 8ae5957a4b..0000000000 --- a/unmaintained/jamshred/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -applications -games diff --git a/unmaintained/jamshred/tunnel/authors.txt b/unmaintained/jamshred/tunnel/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/jamshred/tunnel/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/jamshred/tunnel/tunnel-tests.factor b/unmaintained/jamshred/tunnel/tunnel-tests.factor deleted file mode 100644 index 97077bdd67..0000000000 --- a/unmaintained/jamshred/tunnel/tunnel-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -! Copyright (C) 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test float-arrays ; -IN: jamshred.tunnel.tests - -[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } - T{ segment f { 1 1 1 } f f f 1 } - T{ oint f { 0 0 0.25 } } - nearer-segment segment-number ] unit-test - -[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment segment-number ] unit-test -[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment segment-number ] unit-test -[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment segment-number ] unit-test - -[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test - -[ F{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test - -: 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 } ] [ simplest-straight-ahead sideways-heading ] unit-test -[ { 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 1 0 } ] [ simple-collision-up sideways-heading ] unit-test -[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test -[ { 0 1 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 deleted file mode 100755 index 99c396bebd..0000000000 --- a/unmaintained/jamshred/tunnel/tunnel.factor +++ /dev/null @@ -1,166 +0,0 @@ -! Copyright (C) 2007, 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; -USE: tools.walker -IN: jamshred.tunnel - -: n-segments ( -- n ) 5000 ; inline - -TUPLE: segment < oint number color radius ; -C: segment - -: segment-number++ ( segment -- ) - [ number>> 1+ ] keep (>>number) ; - -: random-color ( -- color ) - { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ; - -: tunnel-segment-distance ( -- n ) 0.4 ; -: random-rotation-angle ( -- theta ) pi 20 / ; - -: random-segment ( previous-segment -- segment ) - clone dup random-rotation-angle random-turn - tunnel-segment-distance over go-forward - random-color over set-segment-color dup segment-number++ ; - -: (random-segments) ( segments n -- segments ) - dup 0 > [ - >r dup peek random-segment over push r> 1- (random-segments) - ] [ drop ] if ; - -: default-segment-radius ( -- r ) 1 ; - -: initial-segment ( -- segment ) - F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } - 0 random-color default-segment-radius ; - -: random-segments ( n -- segments ) - initial-segment 1vector swap (random-segments) ; - -: simple-segment ( n -- segment ) - [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep - random-color default-segment-radius ; - -: 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 - [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; - -: nearer-segment ( segment segment oint -- segment ) - #! return whichever of the two segments is nearer to the oint - >r 2dup r> tuck distance >r distance r> < -rot ? ; - -: (find-nearest-segment) ( nearest next oint -- nearest ? ) - #! find the nearest of 'next' and 'nearest' to 'oint', and return - #! t if the nearest hasn't changed - pick >r nearer-segment dup r> = ; - -: find-nearest-segment ( oint segments -- segment ) - dup first swap rest-slice rot [ (find-nearest-segment) ] curry - find 2drop ; - -: nearest-segment-forward ( segments oint start -- segment ) - rot dup length swap find-nearest-segment ; - -: nearest-segment-backward ( segments oint start -- segment ) - swapd 1+ 0 spin find-nearest-segment ; - -: nearest-segment ( segments oint start-segment -- segment ) - #! find the segment nearest to 'oint', and return it. - #! start looking at segment 'start-segment' - segment-number over >r - [ nearest-segment-forward ] 3keep - nearest-segment-backward r> nearer-segment ; - -: get-segment ( segments n -- segment ) - over sequence-index-range clamp-to-range swap nth ; - -: next-segment ( segments current-segment -- segment ) - number>> 1+ get-segment ; - -: previous-segment ( segments current-segment -- segment ) - number>> 1- get-segment ; - -: heading-segment ( segments current-segment heading -- segment ) - #! the next segment on the given heading - over forward>> v. 0 <=> { - { +gt+ [ next-segment ] } - { +lt+ [ previous-segment ] } - { +eq+ [ nip ] } ! current segment - } case ; - -:: distance-to-next-segment ( current next location heading -- distance ) - [let | cf [ current forward>> ] | - cf next location>> v. cf location v. - cf heading v. / ] ; - -:: distance-to-next-segment-area ( current next location heading -- distance ) - [let | cf [ current forward>> ] - h [ next current half-way-between-oints ] | - cf h v. cf location v. - cf heading v. / ] ; - -: vector-to-centre ( seg loc -- v ) - over location>> swap v- swap forward>> proj-perp ; - -: distance-from-centre ( seg loc -- distance ) - vector-to-centre norm ; - -: wall-normal ( seg oint -- n ) - location>> vector-to-centre normalize ; - -: distant ( -- n ) 1000 ; - -: max-real ( a b -- c ) - #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) - dup real? [ - over real? [ max ] [ nip ] if - ] [ - drop dup real? [ drop distant ] unless - ] if ; - -:: collision-coefficient ( v w r -- c ) - v norm 0 = [ - distant - ] [ - [let* | a [ v dup v. ] - b [ v w v. 2 * ] - c [ w dup v. r sq - ] | - c b a quadratic max-real ] - ] if ; - -: sideways-heading ( oint segment -- v ) - [ forward>> ] bi@ proj-perp ; - -: sideways-relative-location ( oint segment -- loc ) - [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; - -: (distance-to-collision) ( oint segment -- distance ) - [ sideways-heading ] [ sideways-relative-location ] - [ nip radius>> ] 2tri collision-coefficient ; - -: collision-vector ( oint segment -- v ) - dupd (distance-to-collision) swap forward>> n*v ; - -: bounce-forward ( segment oint -- ) - [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; - -: bounce-left ( segment oint -- ) - #! must be done after forward - [ forward>> vneg ] dip [ left>> swap reflect ] - [ forward>> proj-perp normalize ] [ (>>left) ] tri ; - -: bounce-up ( segment oint -- ) - #! must be done after forward and left! - nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; - -: bounce-off-wall ( oint segment -- ) - swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; - diff --git a/unmaintained/tetris/README.txt b/unmaintained/tetris/README.txt deleted file mode 100644 index bd34dc3c16..0000000000 --- a/unmaintained/tetris/README.txt +++ /dev/null @@ -1,16 +0,0 @@ -This is a simple tetris game. To play, open factor (in GUI mode), and run: - -"tetris" run - -This should open a new window with a running tetris game. The commands are: - -left, right arrows: move the current piece left or right -up arrow: rotate the piece clockwise -down arrow: lower the piece one row -space bar: drop the piece -p: pause/unpause -n: start a new game - -TODO: -- rotation of pieces when they're on the far right of the board -- make blocks prettier diff --git a/unmaintained/tetris/authors.txt b/unmaintained/tetris/authors.txt deleted file mode 100644 index e9c193bac7..0000000000 --- a/unmaintained/tetris/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/tetris/board/authors.txt b/unmaintained/tetris/board/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/tetris/board/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/tetris/board/board-tests.factor b/unmaintained/tetris/board/board-tests.factor deleted file mode 100644 index bd8789c4d6..0000000000 --- a/unmaintained/tetris/board/board-tests.factor +++ /dev/null @@ -1,24 +0,0 @@ -USING: kernel tetris.board tetris.piece tools.test arrays -colors ; - -[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test -[ { { f f } { f f } { f f } } ] [ 2 3 board-rows ] unit-test -[ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test -[ f ] [ 2 3 { 1 1 } board-block ] unit-test -[ 2 3 { 2 3 } board-block ] must-fail -red 1array [ 2 3 dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test -[ t ] [ 2 3 { 1 1 } block-free? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red board-set-block { 1 2 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red board-set-block { 0 1 } block-free? ] unit-test -[ t ] [ 2 3 { 0 0 } block-in-bounds? ] unit-test -[ f ] [ 2 3 { -1 0 } block-in-bounds? ] unit-test -[ t ] [ 2 3 { 1 2 } block-in-bounds? ] unit-test -[ f ] [ 2 3 { 2 2 } block-in-bounds? ] unit-test -[ t ] [ 2 3 { 1 1 } location-valid? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } location-valid? ] unit-test -[ t ] [ 10 10 10 piece-valid? ] unit-test -[ f ] [ 2 3 10 { 1 2 } over set-piece-location piece-valid? ] unit-test -[ { { f } { f } } ] [ 1 1 dup add-row board-rows ] unit-test -[ { { f } } ] [ 1 2 dup { 0 1 } red board-set-block dup remove-full-rows board-rows ] unit-test -[ { { f } { f } } ] [ 1 2 dup { 0 1 } red board-set-block dup check-rows drop board-rows ] unit-test diff --git a/unmaintained/tetris/board/board.factor b/unmaintained/tetris/board/board.factor deleted file mode 100644 index 3e4548078c..0000000000 --- a/unmaintained/tetris/board/board.factor +++ /dev/null @@ -1,56 +0,0 @@ -! Copyright (C) 2006, 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences arrays tetris.piece math ; -IN: tetris.board - -TUPLE: board width height rows ; - -: make-rows ( width height -- rows ) - [ drop f ] with map ; - -: ( width height -- board ) - 2dup make-rows board boa ; - -#! A block is simply an array of form { x y } where { 0 0 } is the top-left of -#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board. - -: board@block ( board block -- n row ) - [ second swap board-rows nth ] keep first swap ; - -: board-set-block ( board block colour -- ) -rot board@block set-nth ; - -: board-block ( board block -- colour ) board@block nth ; - -: block-free? ( board block -- ? ) board-block not ; - -: block-in-bounds? ( board block -- ? ) - [ first swap board-width bounds-check? ] 2keep - second swap board-height bounds-check? and ; - -: location-valid? ( board block -- ? ) - 2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ; - -: piece-valid? ( board piece -- ? ) - piece-blocks [ location-valid? ] with all? ; - -: row-not-full? ( row -- ? ) f swap member? ; - -: add-row ( board -- ) - dup board-rows over board-width f - prefix swap set-board-rows ; - -: top-up-rows ( board -- ) - dup board-height over board-rows length = [ - drop - ] [ - dup add-row top-up-rows - ] if ; - -: remove-full-rows ( board -- ) - dup board-rows [ row-not-full? ] filter swap set-board-rows ; - -: check-rows ( board -- n ) - #! remove full rows, then add blank ones at the top, returning the number - #! of rows removed (and added) - dup remove-full-rows dup board-height over board-rows length - >r top-up-rows r> ; - diff --git a/unmaintained/tetris/deploy.factor b/unmaintained/tetris/deploy.factor deleted file mode 100755 index 57a5eda494..0000000000 --- a/unmaintained/tetris/deploy.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: tools.deploy.config ; -V{ - { deploy-ui? t } - { deploy-io 1 } - { deploy-reflection 1 } - { deploy-compiler? t } - { deploy-math? t } - { deploy-word-props? f } - { deploy-c-types? f } - { "stop-after-last-window?" t } - { deploy-name "Tetris" } -} diff --git a/unmaintained/tetris/game/authors.txt b/unmaintained/tetris/game/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/tetris/game/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/tetris/game/game-tests.factor b/unmaintained/tetris/game/game-tests.factor deleted file mode 100644 index e5af54803d..0000000000 --- a/unmaintained/tetris/game/game-tests.factor +++ /dev/null @@ -1,16 +0,0 @@ -USING: kernel tetris.game tetris.board tetris.piece tools.test -sequences ; - -[ t ] [ dup tetris-current-piece swap tetris-next-piece and t f ? ] unit-test -[ t ] [ { 1 1 } can-move? ] unit-test -[ t ] [ { 1 1 } tetris-move ] unit-test -[ 1 ] [ dup { 1 1 } tetris-move drop tetris-current-piece piece-location second ] unit-test -[ 1 ] [ tetris-level ] unit-test -[ 1 ] [ 9 over set-tetris-rows tetris-level ] unit-test -[ 2 ] [ 10 over set-tetris-rows tetris-level ] unit-test -[ 0 ] [ 3 0 rows-score ] unit-test -[ 80 ] [ 1 1 rows-score ] unit-test -[ 4800 ] [ 3 4 rows-score ] unit-test -[ 1 ] [ dup 3 score-rows dup 3 score-rows dup 3 score-rows tetris-level ] unit-test -[ 2 ] [ dup 4 score-rows dup 4 score-rows dup 2 score-rows tetris-level ] unit-test - diff --git a/unmaintained/tetris/game/game.factor b/unmaintained/tetris/game/game.factor deleted file mode 100644 index 90df619ff7..0000000000 --- a/unmaintained/tetris/game/game.factor +++ /dev/null @@ -1,113 +0,0 @@ -! Copyright (C) 2006, 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math math.functions tetris.board -tetris.piece tetris.tetromino lists combinators system ; -IN: tetris.game - -TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ; - -: default-width 10 ; inline -: default-height 20 ; inline - -: ( width height -- tetris ) - tetris construct-delegate - dup board-width over set-tetris-pieces - 0 over set-tetris-last-update - 0 over set-tetris-rows - 0 over set-tetris-score - f over set-tetris-paused? - t over set-tetris-running? ; - -: ( -- tetris ) default-width default-height ; - -: ( old -- new ) - [ board-width ] keep board-height ; - -: tetris-board ( tetris -- board ) delegate ; - -: tetris-current-piece ( tetris -- piece ) tetris-pieces car ; - -: tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ; - -: toggle-pause ( tetris -- ) - dup tetris-paused? not swap set-tetris-paused? ; - -: tetris-level ( tetris -- level ) - tetris-rows 1+ 10 / ceiling ; - -: tetris-update-interval ( tetris -- interval ) - tetris-level 1- 60 * 1000 swap - ; - -: add-block ( tetris block -- ) - over tetris-current-piece tetromino-colour board-set-block ; - -: game-over? ( tetris -- ? ) - dup tetris-next-piece piece-valid? not ; - -: new-current-piece ( tetris -- ) - dup game-over? [ - f swap set-tetris-running? - ] [ - dup tetris-pieces cdr swap set-tetris-pieces - ] if ; - -: rows-score ( level n -- score ) - { - { 0 [ 0 ] } - { 1 [ 40 ] } - { 2 [ 100 ] } - { 3 [ 300 ] } - { 4 [ 1200 ] } - } case swap 1+ * ; - -: add-score ( tetris score -- ) - over tetris-score + swap set-tetris-score ; - -: score-rows ( tetris n -- ) - 2dup >r dup tetris-level r> rows-score add-score - over tetris-rows + swap set-tetris-rows ; - -: lock-piece ( tetris -- ) - [ dup tetris-current-piece piece-blocks [ add-block ] with each ] keep - dup new-current-piece dup check-rows score-rows ; - -: can-rotate? ( tetris -- ? ) - dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ; - -: (rotate) ( inc tetris -- ) - dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ; - -: rotate-left ( tetris -- ) -1 swap (rotate) ; - -: rotate-right ( tetris -- ) 1 swap (rotate) ; - -: can-move? ( tetris move -- ? ) - >r dup tetris-current-piece clone dup r> move-piece piece-valid? ; - -: tetris-move ( tetris move -- ? ) - #! moves the piece if possible, returns whether the piece was moved - 2dup can-move? [ - >r tetris-current-piece r> move-piece t - ] [ - 2drop f - ] if ; - -: move-left ( tetris -- ) { -1 0 } tetris-move drop ; - -: move-right ( tetris -- ) { 1 0 } tetris-move drop ; - -: move-down ( tetris -- ) - dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ; - -: move-drop ( tetris -- ) - dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ; - -: update ( tetris -- ) - millis over tetris-last-update - - over tetris-update-interval > [ - dup move-down - millis swap set-tetris-last-update - ] [ drop ] if ; - -: maybe-update ( tetris -- ) - dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ; diff --git a/unmaintained/tetris/gl/authors.txt b/unmaintained/tetris/gl/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/tetris/gl/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/tetris/gl/gl.factor b/unmaintained/tetris/gl/gl.factor deleted file mode 100644 index e425c4766f..0000000000 --- a/unmaintained/tetris/gl/gl.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2006, 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences arrays math math.vectors namespaces -opengl opengl.gl ui.render ui.gadgets tetris.game tetris.board -tetris.piece tetris.tetromino ; -IN: tetris.gl - -#! OpenGL rendering for tetris - -: draw-block ( block -- ) - dup { 1 1 } v+ gl-fill-rect ; - -: draw-piece-blocks ( piece -- ) - piece-blocks [ draw-block ] each ; - -: draw-piece ( piece -- ) - dup tetromino-colour gl-color draw-piece-blocks ; - -: draw-next-piece ( piece -- ) - dup tetromino-colour clone 0.2 3 pick set-nth gl-color draw-piece-blocks ; - -! TODO: move implementation specific stuff into tetris-board -: (draw-row) ( x y row -- ) - >r over r> nth dup - [ gl-color 2array draw-block ] [ 3drop ] if ; - -: draw-row ( y row -- ) - dup length -rot [ (draw-row) ] 2curry each ; - -: draw-board ( board -- ) - board-rows dup length swap - [ dupd nth draw-row ] curry each ; - -: scale-tetris ( width height tetris -- ) - [ board-width swap ] keep board-height / -rot / swap 1 glScalef ; - -: (draw-tetris) ( width height tetris -- ) - #! width and height are in pixels - GL_MODELVIEW [ - [ scale-tetris ] keep - dup tetris-board draw-board - dup tetris-next-piece draw-next-piece - tetris-current-piece draw-piece - ] do-matrix ; - -: draw-tetris ( width height tetris -- ) - origin get [ (draw-tetris) ] with-translation ; diff --git a/unmaintained/tetris/piece/authors.txt b/unmaintained/tetris/piece/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/tetris/piece/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/tetris/piece/piece-tests.factor b/unmaintained/tetris/piece/piece-tests.factor deleted file mode 100644 index d4d19fe822..0000000000 --- a/unmaintained/tetris/piece/piece-tests.factor +++ /dev/null @@ -1,23 +0,0 @@ -USING: kernel tetris.tetromino tetris.piece tools.test sequences arrays namespaces ; - -! Tests for tetris.tetromino and tetris.piece, since there's not much to test in tetris.tetromino - -! these two tests rely on the first rotation of the first tetromino being the -! 'I' tetromino in its vertical orientation. -[ 4 ] [ tetrominoes get first tetromino-states first blocks-width ] unit-test -[ 1 ] [ tetrominoes get first tetromino-states first blocks-height ] unit-test - -[ { 0 0 } ] [ random-tetromino piece-location ] unit-test -[ 0 ] [ 10 piece-rotation ] unit-test - -[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ] -[ tetrominoes get first piece-blocks ] unit-test - -[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ] -[ tetrominoes get first dup 1 rotate-piece piece-blocks ] unit-test - -[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ] -[ tetrominoes get first dup { 1 1 } move-piece piece-blocks ] unit-test - -[ 3 ] [ tetrominoes get second piece-width ] unit-test -[ 2 ] [ tetrominoes get second dup 1 rotate-piece piece-width ] unit-test diff --git a/unmaintained/tetris/piece/piece.factor b/unmaintained/tetris/piece/piece.factor deleted file mode 100644 index 55215dbf6a..0000000000 --- a/unmaintained/tetris/piece/piece.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2006, 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays tetris.tetromino math math.vectors -sequences quotations lists.lazy ; -IN: tetris.piece - -#! A piece adds state to the tetromino that is the piece's delegate. The -#! rotation is an index into the tetromino's states array, and the position is -#! added to the tetromino's blocks to give them their location on the tetris -#! board. If the location is f then the piece is not yet on the board. -TUPLE: piece rotation location ; - -: ( tetromino -- piece ) - piece construct-delegate - 0 over set-piece-rotation - { 0 0 } over set-piece-location ; - -: (piece-blocks) ( piece -- blocks ) - #! rotates the tetromino - dup piece-rotation swap tetromino-states nth ; - -: piece-blocks ( piece -- blocks ) - #! rotates and positions the tetromino - dup (piece-blocks) swap piece-location [ v+ ] curry map ; - -: piece-width ( piece -- width ) - piece-blocks blocks-width ; - -: set-start-location ( piece board-width -- ) - 2 /i over piece-width 2 /i - 0 2array swap set-piece-location ; - -: ( board-width -- piece ) - random-tetromino [ swap set-start-location ] keep ; - -: ( board-width -- llist ) - [ [ ] curry ] keep [ ] curry lazy-cons ; - -: modulo ( n m -- n ) - #! -2 7 mod => -2, -2 7 modulo => 5 - tuck mod over + swap mod ; - -: rotate-piece ( piece inc -- ) - over piece-rotation + over tetromino-states length modulo swap set-piece-rotation ; - -: move-piece ( piece move -- ) - over piece-location v+ swap set-piece-location ; - diff --git a/unmaintained/tetris/summary.txt b/unmaintained/tetris/summary.txt deleted file mode 100644 index 9352d40cdb..0000000000 --- a/unmaintained/tetris/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Graphical Tetris game diff --git a/unmaintained/tetris/tags.txt b/unmaintained/tetris/tags.txt deleted file mode 100644 index 09934571b3..0000000000 --- a/unmaintained/tetris/tags.txt +++ /dev/null @@ -1,3 +0,0 @@ -demos -applications -games diff --git a/unmaintained/tetris/tetris.factor b/unmaintained/tetris/tetris.factor deleted file mode 100644 index d01cec3790..0000000000 --- a/unmaintained/tetris/tetris.factor +++ /dev/null @@ -1,61 +0,0 @@ -! Copyright (C) 2006, 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels -ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui -tetris.game tetris.gl sequences system math math.parser namespaces -math.geometry.rect ; -IN: tetris - -TUPLE: tetris-gadget tetris alarm ; - -: ( tetris -- gadget ) - tetris-gadget construct-gadget - [ set-tetris-gadget-tetris ] keep ; - -M: tetris-gadget pref-dim* drop { 200 400 } ; - -: update-status ( gadget -- ) - dup tetris-gadget-tetris [ - "Level: " % dup tetris-level # - " Score: " % tetris-score # - ] "" make swap show-status ; - -M: tetris-gadget draw-gadget* ( gadget -- ) - [ - dup rect-dim dup first swap second rot tetris-gadget-tetris draw-tetris - ] keep update-status ; - -: new-tetris ( gadget -- ) - dup tetris-gadget-tetris swap set-tetris-gadget-tetris ; - -tetris-gadget H{ - { T{ key-down f f "UP" } [ tetris-gadget-tetris rotate-right ] } - { T{ key-down f f "d" } [ tetris-gadget-tetris rotate-left ] } - { T{ key-down f f "f" } [ tetris-gadget-tetris rotate-right ] } - { T{ key-down f f "e" } [ tetris-gadget-tetris rotate-left ] } ! dvorak d - { T{ key-down f f "u" } [ tetris-gadget-tetris rotate-right ] } ! dvorak f - { T{ key-down f f "LEFT" } [ tetris-gadget-tetris move-left ] } - { T{ key-down f f "RIGHT" } [ tetris-gadget-tetris move-right ] } - { T{ key-down f f "DOWN" } [ tetris-gadget-tetris move-down ] } - { T{ key-down f f " " } [ tetris-gadget-tetris move-drop ] } - { T{ key-down f f "p" } [ tetris-gadget-tetris toggle-pause ] } - { T{ key-down f f "n" } [ new-tetris ] } -} set-gestures - -: tick ( gadget -- ) - dup tetris-gadget-tetris maybe-update relayout-1 ; - -M: tetris-gadget graft* ( gadget -- ) - dup [ tick ] curry 100 milliseconds every - swap set-tetris-gadget-alarm ; - -M: tetris-gadget ungraft* ( gadget -- ) - [ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ; - -: tetris-window ( -- ) - [ - - "Tetris" open-status-window - ] with-ui ; - -MAIN: tetris-window diff --git a/unmaintained/tetris/tetromino/authors.txt b/unmaintained/tetris/tetromino/authors.txt deleted file mode 100755 index e9c193bac7..0000000000 --- a/unmaintained/tetris/tetromino/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Alex Chapman diff --git a/unmaintained/tetris/tetromino/tetromino.factor b/unmaintained/tetris/tetromino/tetromino.factor deleted file mode 100644 index 957f808aae..0000000000 --- a/unmaintained/tetris/tetromino/tetromino.factor +++ /dev/null @@ -1,114 +0,0 @@ -! Copyright (C) 2006, 2007 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays namespaces sequences math math.vectors -colors random ; -IN: tetris.tetromino - -TUPLE: tetromino states colour ; - -C: tetromino - -SYMBOL: tetrominoes - -{ - [ - { { - { 0 0 } { 1 0 } { 2 0 } { 3 0 } - } - { { 0 0 } - { 0 1 } - { 0 2 } - { 0 3 } - } - } cyan - ] [ - { - { { 1 0 } - { 0 1 } { 1 1 } { 2 1 } - } { - { 0 0 } - { 0 1 } { 1 1 } - { 0 2 } - } { - { 0 0 } { 1 0 } { 2 0 } - { 1 1 } - } { - { 1 0 } - { 0 1 } { 1 1 } - { 1 2 } - } - } purple - ] [ - { { { 0 0 } { 1 0 } - { 0 1 } { 1 1 } } - } yellow - ] [ - { - { { 0 0 } { 1 0 } { 2 0 } - { 0 1 } - } { - { 0 0 } { 1 0 } - { 1 1 } - { 1 2 } - } { - { 2 0 } - { 0 1 } { 1 1 } { 2 1 } - } { - { 0 0 } - { 0 1 } - { 0 2 } { 1 2 } - } - } orange - ] [ - { - { { 0 0 } { 1 0 } { 2 0 } - { 2 1 } - } { - { 1 0 } - { 1 1 } - { 0 2 } { 1 2 } - } { - { 0 0 } - { 0 1 } { 1 1 } { 2 1 } - } { - { 0 0 } { 1 0 } - { 0 1 } - { 0 2 } - } - } blue - ] [ - { - { { 1 0 } { 2 0 } - { 0 1 } { 1 1 } - } { - { 0 0 } - { 0 1 } { 1 1 } - { 1 2 } - } - } green - ] [ - { - { - { 0 0 } { 1 0 } - { 1 1 } { 2 1 } - } { - { 1 0 } - { 0 1 } { 1 1 } - { 0 2 } - } - } red - ] -} [ call ] map tetrominoes set-global - -: random-tetromino ( -- tetromino ) - tetrominoes get random ; - -: blocks-max ( blocks quot -- max ) - map [ 1+ ] map supremum ; inline - -: blocks-width ( blocks -- width ) - [ first ] blocks-max ; - -: blocks-height ( blocks -- height ) - [ second ] blocks-max ; -