--- /dev/null
+Alex Chapman
--- /dev/null
+USING: digraphs kernel sequences tools.test ;
+IN: digraphs.tests
+
+: test-digraph ( -- 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
--- /dev/null
+! 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> ( -- digraph )
+ 0 digraph new [ reset-hash ] keep ;
+
+TUPLE: vertex value edges ;
+
+: <vertex> ( value -- vertex )
+ V{ } clone vertex boa ;
+
+: add-vertex ( key value digraph -- )
+ [ <vertex> 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 ;
--- /dev/null
+Simple directed graph implementation for topological sorting
--- /dev/null
+collections
--- /dev/null
+Alex Chapman
--- /dev/null
+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" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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> ( -- jamshred )
+ <sounds> <random-tunnel> "Player 1" pick <player>
+ 2dup swap play-in-tunnel 1array f f jamshred boa ;
+
+: jamshred-player ( jamshred -- player )
+ ! TODO: support more than one player
+ players>> first ;
+
+: jamshred-update ( jamshred -- )
+ dup running>> [
+ jamshred-player update-player
+ ] [ drop ] if ;
+
+: toggle-running ( jamshred -- )
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
+
+: mouse-moved ( x-radians y-radians jamshred -- )
+ jamshred-player -rot turn-player ;
+
+: units-per-full-roll ( -- n ) 50 ;
+
+: jamshred-roll ( jamshred n -- )
+ [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
+
+: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
+
+: mouse-scroll-y ( jamshred y -- )
+ neg swap jamshred-player change-player-speed ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu 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 ;
+
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+IN: jamshred
+
+TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
+
+: <jamshred-gadget> ( jamshred -- gadget )
+ jamshred-gadget new-gadget swap >>jamshred ;
+
+: default-width ( -- x ) 800 ;
+: default-height ( -- y ) 600 ;
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 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> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ rect-dim first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ rect-dim second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ over jamshred>> >r
+ [ first swap x>radians ] 2keep second swap y>radians
+ r> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ no-fullscreen ] [ close-window ] bi ;
+
+jamshred-gadget H{
+ { T{ key-down f f "r" } [ jamshred-restart ] }
+ { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+ { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+ { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
+ { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
+ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
+ { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
+ { T{ key-down f f "q" } [ quit ] }
+ { T{ motion } [ handle-mouse-motion ] }
+ { T{ mouse-scroll } [ handle-mouse-scroll ] }
+} set-gestures
+
+: jamshred-window ( -- gadget )
+ [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
+
+MAIN: jamshred-window
--- /dev/null
+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...
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >fixnum random 10000 / swap 2 / - ;
+
+: random-turn ( oint theta -- )
+ 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
+: go-forward ( distance oint -- )
+ [ forward>> n*v ] [ location+ ] bi ;
+
+: distance-vector ( oint oint -- vector )
+ [ location>> ] bi@ swap v- ;
+
+: distance ( oint oint -- distance )
+ distance-vector norm ;
+
+: scalar-projection ( v1 v2 -- n )
+ #! the scalar projection of v1 onto v2
+ tuck v. swap norm / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ tuck distance-vector swap 2dup left>> scalar-projection abs
+ -rot up>> scalar-projection abs + ;
+
+:: reflect ( v n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 ;
+
+: <player> ( 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 ;
--- /dev/null
+USING: accessors io.files kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- sounds )
+ init-openal 1 gen-sources first sounds boa
+ dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
+IN: jamshred.tunnel.tests
+
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+ T{ segment f { 1 1 1 } f f f 1 }
+ T{ oint f { 0 0 0.25 } }
+ nearer-segment number>> ] unit-test
+
+[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+
+[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
+
+[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0.0 1.0 0.0 } ]
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
--- /dev/null
+! 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
+
+: 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 <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
+
+: simple-segments ( n -- segments )
+ [ simple-segment ] map ;
+
+: <random-tunnel> ( -- segments )
+ n-segments random-segments ;
+
+: <straight-tunnel> ( -- segments )
+ n-segments simple-segments ;
+
+: sub-tunnel ( from to segments -- segments )
+ #! return segments between from and to, after clamping from and to to
+ #! valid values
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+
+: nearer-segment ( segment segment oint -- segment )
+ #! return whichever of the two segments is nearer to the oint
+ >r 2dup r> tuck distance >r distance r> < -rot ? ;
+
+: (find-nearest-segment) ( nearest next oint -- nearest ? )
+ #! find the nearest of 'next' and 'nearest' to 'oint', and return
+ #! t if the nearest hasn't changed
+ pick >r nearer-segment dup r> = ;
+
+: find-nearest-segment ( oint segments -- segment )
+ dup first swap rest-slice rot [ (find-nearest-segment) ] curry
+ find 2drop ;
+
+: nearest-segment-forward ( segments oint start -- segment )
+ rot dup length swap <slice> find-nearest-segment ;
+
+: nearest-segment-backward ( segments oint start -- segment )
+ swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+
+: nearest-segment ( segments oint start-segment -- segment )
+ #! find the segment nearest to 'oint', and return it.
+ #! start looking at segment 'start-segment'
+ number>> over >r
+ [ nearest-segment-forward ] 3keep
+ nearest-segment-backward r> nearer-segment ;
+
+: get-segment ( segments n -- segment )
+ over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
+
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
+
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
+
+: distant ( -- n ) 1000 ;
+
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
+
+:: collision-coefficient ( v w r -- c )
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: (distance-to-collision) ( oint segment -- distance )
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce-off-wall ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
--- /dev/null
+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
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+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 <board> rows>> ] unit-test
+[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
+[ f ] [ 2 3 <board> { 1 1 } block ] unit-test
+[ 2 3 <board> { 2 3 } block ] must-fail
+red 1array [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block ] unit-test
+[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test
+[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
+[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
+[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
+[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
+[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test
+[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
+[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test
+[ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test
+[ { { f } } ] [ 1 2 <board> dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test
+[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test
--- /dev/null
+! 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 <array> ] with map ;
+
+: <board> ( 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 <array> 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 ;
+
--- /dev/null
+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" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors kernel tetris.game tetris.board tetris.piece tools.test
+sequences ;
+
+[ t ] [ <default-tetris> [ current-piece ] [ next-piece ] bi and t f ? ] unit-test
+[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
+[ t ] [ <default-tetris> { 1 1 } tetris-move ] unit-test
+[ 1 ] [ <default-tetris> dup { 1 1 } tetris-move drop current-piece location>> second ] unit-test
+[ 1 ] [ <default-tetris> level>> ] unit-test
+[ 1 ] [ <default-tetris> 9 >>rows level>> ] unit-test
+[ 2 ] [ <default-tetris> 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 ] [ <default-tetris> dup 3 score-rows dup 3 score-rows dup 3 score-rows level>> ] unit-test
+[ 2 ] [ <default-tetris> dup 4 score-rows dup 4 score-rows dup 2 score-rows level>> ] unit-test
+
--- /dev/null
+! 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
+
+: <tetris> ( width height -- tetris )
+ dupd <board> swap <piece-llist>
+ tetris new swap >>pieces swap >>board ;
+
+: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
+
+: <new-tetris> ( old -- new )
+ board>> [ width>> ] [ height>> ] bi <tetris> ;
+
+: 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 ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 ;
--- /dev/null
+Alex Chapman
--- /dev/null
+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 <piece> location>> ] unit-test
+[ 0 ] [ 10 <random-piece> rotation>> ] unit-test
+
+[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ]
+[ tetrominoes get first <piece> piece-blocks ] unit-test
+
+[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ]
+[ tetrominoes get first <piece> 1 rotate-piece piece-blocks ] unit-test
+
+[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ]
+[ tetrominoes get first <piece> { 1 1 } move-piece piece-blocks ] unit-test
+
+[ 3 ] [ tetrominoes get second <piece> piece-width ] unit-test
+[ 2 ] [ tetrominoes get second <piece> 1 rotate-piece piece-width ] unit-test
--- /dev/null
+! 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 } } ;
+
+: <piece> ( 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 ;
+
+: <random-piece> ( board-width -- piece )
+ random-tetromino <piece> swap set-start-location ;
+
+: <piece-llist> ( board-width -- llist )
+ [ [ <random-piece> ] curry ] keep [ <piece-llist> ] 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 ;
--- /dev/null
+Graphical Tetris game
--- /dev/null
+demos
+applications
+games
--- /dev/null
+! 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 )
+ 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 )
+ [ <new-tetris> ] 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 ( -- )
+ [
+ <default-tetris> <tetris-gadget>
+ "Tetris" open-status-window
+ ] with-ui ;
+
+MAIN: tetris-window
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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> 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 <tetromino> ] 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 ;
+
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: digraphs kernel sequences tools.test ;
-IN: digraphs.tests
-
-: test-digraph ( -- 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
+++ /dev/null
-! 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 )
- digraph new H{ } clone over set-delegate ;
-
-: <vertex> ( value -- vertex )
- V{ } clone vertex boa ;
-
-: add-vertex ( key value digraph -- )
- >r <vertex> 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 ;
+++ /dev/null
-Simple directed graph implementation for topological sorting
+++ /dev/null
-collections
+++ /dev/null
-Alex Chapman
+++ /dev/null
-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" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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> ( -- jamshred )
- <sounds> <random-tunnel> "Player 1" pick <player>
- 2dup swap play-in-tunnel 1array f f jamshred boa ;
-
-: jamshred-player ( jamshred -- player )
- ! TODO: support more than one player
- players>> first ;
-
-: jamshred-update ( jamshred -- )
- dup running>> [
- jamshred-player update-player
- ] [ drop ] if ;
-
-: toggle-running ( jamshred -- )
- dup running>> [
- f >>running drop
- ] [
- [ jamshred-player moved ]
- [ t >>running drop ] bi
- ] if ;
-
-: mouse-moved ( x-radians y-radians jamshred -- )
- jamshred-player -rot turn-player ;
-
-: units-per-full-roll ( -- n ) 50 ;
-
-: jamshred-roll ( jamshred n -- )
- [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
-
-: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
-
-: mouse-scroll-y ( jamshred y -- )
- neg swap jamshred-player change-player-speed ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 ;
-
+++ /dev/null
-! 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 )
- 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> >>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 )
- [ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
-
-MAIN: jamshred-window
+++ /dev/null
-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...
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: jamshred.oint tools.test ;
-IN: jamshred.oint-tests
-
-[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
-[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
-[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
-[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
-[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
-IN: jamshred.oint
-
-! An oint is a point with three linearly independent unit vectors
-! given relative to that point. In jamshred a player's location and
-! direction are given by the player's oint. Similarly, a tunnel
-! segment's location and orientation are given by an oint.
-
-TUPLE: oint location forward up left ;
-C: <oint> oint
-
-: rotation-quaternion ( theta axis -- quaternion )
- swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
-
-: rotate-vector ( q qrecip v -- v )
- v>q swap q* q* q>v ;
-
-: rotate-oint ( oint theta axis -- )
- rotation-quaternion dup qrecip pick
- [ forward>> rotate-vector >>forward ]
- [ up>> rotate-vector >>up ]
- [ left>> rotate-vector >>left ] 3tri drop ;
-
-: left-pivot ( oint theta -- )
- over left>> rotate-oint ;
-
-: up-pivot ( oint theta -- )
- over up>> rotate-oint ;
-
-: forward-pivot ( oint theta -- )
- over forward>> rotate-oint ;
-
-: random-float+- ( n -- m )
- #! find a random float between -n/2 and n/2
- dup 10000 * >fixnum random 10000 / swap 2 / - ;
-
-: random-turn ( oint theta -- )
- 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
-
-: location+ ( v oint -- )
- [ location>> v+ ] [ (>>location) ] bi ;
-
-: go-forward ( distance oint -- )
- [ forward>> n*v ] [ location+ ] bi ;
-
-: distance-vector ( oint oint -- vector )
- [ location>> ] bi@ swap v- ;
-
-: distance ( oint oint -- distance )
- distance-vector norm ;
-
-: scalar-projection ( v1 v2 -- n )
- #! the scalar projection of v1 onto v2
- tuck v. swap norm / ;
-
-: proj-perp ( u v -- w )
- dupd proj v- ;
-
-: perpendicular-distance ( oint oint -- distance )
- tuck distance-vector swap 2dup left>> scalar-projection abs
- -rot up>> scalar-projection abs + ;
-
-:: reflect ( v n -- v' )
- #! bounce v on a surface with normal n
- v v n v. n n v. / 2 * n n*v v- ;
-
-: half-way ( p1 p2 -- p3 )
- over v- 2 v/n v+ ;
-
-: half-way-between-oints ( o1 o2 -- p )
- [ location>> ] bi@ half-way ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 ;
-
-: <player> ( 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 ;
+++ /dev/null
-USING: accessors io.files kernel openal sequences ;
-IN: jamshred.sound
-
-TUPLE: sounds bang ;
-
-: assign-sound ( source wav-path -- )
- resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
-
-: <sounds> ( -- sounds )
- init-openal 1 gen-sources first sounds boa
- dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
-
-: bang ( sounds -- ) bang>> source-play check-error ;
+++ /dev/null
-A simple 3d tunnel racing game
+++ /dev/null
-applications
-games
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-
-[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
-
-[ F{ 0 0 0 } ] [ <straight-tunnel> 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 } <oint> ;
-
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
-
-: simplest-straight-ahead ( -- oint segment )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0 0 0 } ] [ 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 } <oint>
- 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
+++ /dev/null
-! 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
-
-: 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 <segment> ;
-
-: random-segments ( n -- segments )
- initial-segment 1vector swap (random-segments) ;
-
-: simple-segment ( n -- segment )
- [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
- random-color default-segment-radius <segment> ;
-
-: simple-segments ( n -- segments )
- [ simple-segment ] map ;
-
-: <random-tunnel> ( -- segments )
- n-segments random-segments ;
-
-: <straight-tunnel> ( -- segments )
- n-segments simple-segments ;
-
-: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
-
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- >r 2dup r> tuck distance >r distance r> < -rot ? ;
-
-: (find-nearest-segment) ( nearest next oint -- nearest ? )
- #! find the nearest of 'next' and 'nearest' to 'oint', and return
- #! t if the nearest hasn't changed
- pick >r nearer-segment dup r> = ;
-
-: find-nearest-segment ( oint segments -- segment )
- dup first swap rest-slice rot [ (find-nearest-segment) ] curry
- find 2drop ;
-
-: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
-
-: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
-
-: nearest-segment ( segments oint start-segment -- segment )
- #! find the segment nearest to 'oint', and return it.
- #! start looking at segment 'start-segment'
- 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 ;
-
+++ /dev/null
-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
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-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> board-rows ] unit-test
-[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
-[ f ] [ 2 3 <board> { 1 1 } board-block ] unit-test
-[ 2 3 <board> { 2 3 } board-block ] must-fail
-red 1array [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test
-[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 2 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 0 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
-[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
-[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
-[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
-[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } location-valid? ] unit-test
-[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
-[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } over set-piece-location piece-valid? ] unit-test
-[ { { f } { f } } ] [ 1 1 <board> dup add-row board-rows ] unit-test
-[ { { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup remove-full-rows board-rows ] unit-test
-[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup check-rows drop board-rows ] unit-test
+++ /dev/null
-! 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 <array> ] with map ;
-
-: <board> ( 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 <array>
- 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> ;
-
+++ /dev/null
-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" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel tetris.game tetris.board tetris.piece tools.test
-sequences ;
-
-[ t ] [ <default-tetris> dup tetris-current-piece swap tetris-next-piece and t f ? ] unit-test
-[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
-[ t ] [ <default-tetris> { 1 1 } tetris-move ] unit-test
-[ 1 ] [ <default-tetris> dup { 1 1 } tetris-move drop tetris-current-piece piece-location second ] unit-test
-[ 1 ] [ <default-tetris> tetris-level ] unit-test
-[ 1 ] [ <default-tetris> 9 over set-tetris-rows tetris-level ] unit-test
-[ 2 ] [ <default-tetris> 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 ] [ <default-tetris> dup 3 score-rows dup 3 score-rows dup 3 score-rows tetris-level ] unit-test
-[ 2 ] [ <default-tetris> dup 4 score-rows dup 4 score-rows dup 2 score-rows tetris-level ] unit-test
-
+++ /dev/null
-! 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
-
-: <tetris> ( width height -- tetris )
- <board> tetris construct-delegate
- dup board-width <piece-llist> 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? ;
-
-: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
-
-: <new-tetris> ( old -- new )
- [ board-width ] keep board-height <tetris> ;
-
-: 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 ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-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> piece-location ] unit-test
-[ 0 ] [ 10 <random-piece> piece-rotation ] unit-test
-
-[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ]
-[ tetrominoes get first <piece> piece-blocks ] unit-test
-
-[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ]
-[ tetrominoes get first <piece> dup 1 rotate-piece piece-blocks ] unit-test
-
-[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ]
-[ tetrominoes get first <piece> dup { 1 1 } move-piece piece-blocks ] unit-test
-
-[ 3 ] [ tetrominoes get second <piece> piece-width ] unit-test
-[ 2 ] [ tetrominoes get second <piece> dup 1 rotate-piece piece-width ] unit-test
+++ /dev/null
-! 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 ;
-
-: <piece> ( 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 ;
-
-: <random-piece> ( board-width -- piece )
- random-tetromino <piece> [ swap set-start-location ] keep ;
-
-: <piece-llist> ( board-width -- llist )
- [ [ <random-piece> ] curry ] keep [ <piece-llist> ] 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 ;
-
+++ /dev/null
-Graphical Tetris game
+++ /dev/null
-demos
-applications
-games
+++ /dev/null
-! 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 )
- 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 <new-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 ( -- )
- [
- <default-tetris> <tetris-gadget>
- "Tetris" open-status-window
- ] with-ui ;
-
-MAIN: tetris-window
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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> 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 <tetromino> ] 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 ;
-
projects / factor.git / commitdiff