From f02bbb6f4baba7f556e3f821d9b8903e4fb7d0ef Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 16 Apr 2009 11:06:28 +1000 Subject: [PATCH] jamshred fixes, but still has an endless recursion bug --- extra/jamshred/gl/gl.factor | 33 ++++++++++++++++------- extra/jamshred/jamshred.factor | 30 ++++++++++----------- extra/jamshred/oint/oint.factor | 4 +-- extra/jamshred/player/player.factor | 8 +++--- extra/jamshred/sound/sound.factor | 2 +- extra/jamshred/tunnel/tunnel-tests.factor | 4 +-- extra/jamshred/tunnel/tunnel.factor | 20 +++++++------- 7 files changed, 56 insertions(+), 45 deletions(-) diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index b78e7de88e..bae275e96a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -6,8 +6,8 @@ math.functions math.vectors opengl opengl.gl opengl.glu opengl.demo-support sequences specialized-arrays.float ; IN: jamshred.gl -: min-vertices 6 ; inline -: max-vertices 32 ; inline +: min-vertices ( -- n ) 6 ; inline +: max-vertices ( -- n ) 32 ; inline : n-vertices ( -- n ) 32 ; inline @@ -55,7 +55,7 @@ IN: jamshred.gl : draw-segment ( next-segment segment -- ) GL_QUAD_STRIP [ [ draw-vertex-pair ] 2curry - n-vertices equally-spaced-radians F{ 0.0 } append swap each + n-vertices equally-spaced-radians float-array{ 0.0 } append swap each ] do-state ; : draw-segments ( segments -- ) @@ -68,15 +68,13 @@ IN: jamshred.gl : draw-tunnel ( player -- ) segments-to-render draw-segments ; -: init-graphics ( width height -- ) +: init-graphics ( -- ) 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_PROJECTION glMatrixMode glPushMatrix + GL_MODELVIEW glMatrixMode glPushMatrix GL_LEQUAL glDepthFunc GL_LIGHTING glEnable GL_LIGHT0 glEnable @@ -89,11 +87,26 @@ IN: jamshred.gl GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ; +: cleanup-graphics ( -- ) + GL_DEPTH_TEST glDisable + GL_SCISSOR_TEST glEnable + GL_MODELVIEW glMatrixMode glPopMatrix + GL_PROJECTION glMatrixMode glPopMatrix + GL_LIGHTING glDisable + GL_LIGHT0 glDisable + GL_FOG glDisable + GL_COLOR_MATERIAL glDisable ; + +: pre-draw ( width height -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_PROJECTION glMatrixMode glLoadIdentity + dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if + GL_MODELVIEW glMatrixMode glLoadIdentity ; + : player-view ( player -- ) [ location>> ] [ [ location>> ] [ forward>> ] bi v+ ] [ up>> ] tri gl-look-at ; : draw-jamshred ( jamshred width height -- ) - init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ; - + pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index d0b74417d1..49624e2947 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,12 +1,12 @@ ! 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 ; +USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ; IN: jamshred TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; : ( jamshred -- gadget ) - jamshred-gadget new-gadget swap >>jamshred ; + jamshred-gadget new swap >>jamshred ; : default-width ( -- x ) 800 ; : default-height ( -- y ) 600 ; @@ -15,7 +15,7 @@ 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>> ] [ dim>> first2 draw-jamshred ] bi ; : jamshred-loop ( gadget -- ) dup jamshred>> quit>> [ @@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) ] [ [ jamshred>> jamshred-update ] [ relayout-1 ] - [ 10 milliseconds sleep yield jamshred-loop ] tri + [ 100 milliseconds sleep jamshred-loop ] tri ] if ; : fullscreen ( gadget -- ) @@ -36,10 +36,11 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) [ fullscreen? not ] keep set-fullscreen* ; M: jamshred-gadget graft* ( gadget -- ) - [ jamshred-loop ] curry in-thread ; + [ find-gl-context init-graphics ] + [ [ jamshred-loop ] curry in-thread ] bi ; M: jamshred-gadget ungraft* ( gadget -- ) - jamshred>> t swap (>>quit) ; + dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ; : jamshred-restart ( jamshred-gadget -- ) >>jamshred drop ; @@ -49,16 +50,15 @@ M: jamshred-gadget ungraft* ( gadget -- ) : x>radians ( x gadget -- theta ) #! translate motion of x pixels to an angle - rect-dim first pix>radians neg ; + dim>> first pix>radians neg ; : y>radians ( y gadget -- theta ) #! translate motion of y pixels to an angle - rect-dim second pix>radians ; + 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 ; + dupd [ first swap x>radians ] [ second swap y>radians ] 2bi + rot jamshred>> mouse-moved ; : handle-mouse-motion ( jamshred-gadget -- ) hand-loc get [ @@ -84,11 +84,11 @@ jamshred-gadget H{ { 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 ] } + { motion [ handle-mouse-motion ] } + { mouse-scroll [ handle-mouse-scroll ] } } set-gestures -: jamshred-window ( -- gadget ) - [ dup "Jamshred" open-window ] with-ui ; +: jamshred-window ( -- ) + [ "Jamshred" open-window ] with-ui ; MAIN: jamshred-window diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 808e92a1f9..ae72bd847c 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,6 +1,6 @@ ! 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 ; +USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; IN: jamshred.oint ! An oint is a point with three linearly independent unit vectors @@ -12,7 +12,7 @@ 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 ; + swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ; : rotate-vector ( q qrecip v -- v ) v>q swap q* q* q>v ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 72f26a2c79..d33b78f29c 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ; +USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ; IN: jamshred.player TUPLE: player < oint @@ -16,11 +16,11 @@ TUPLE: player < oint : 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 + [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip f f 0 default-speed player boa ; : turn-player ( player x-radians y-radians -- ) - >r over r> left-pivot up-pivot ; + [ over ] dip left-pivot up-pivot ; : roll-player ( player z-radians -- ) forward-pivot ; @@ -134,4 +134,4 @@ TUPLE: player < oint [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; : update-player ( player -- ) - [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; + [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ; diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor index c19c67671f..6a9b331f33 100644 --- a/extra/jamshred/sound/sound.factor +++ b/extra/jamshred/sound/sound.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.files kernel openal sequences ; +USING: accessors io.pathnames kernel openal sequences ; IN: jamshred.sound TUPLE: sounds bang ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 9486713f55..8e2f1a6fab 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,6 +1,6 @@ ! 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 ; +USING: accessors arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences specialized-arrays.float tools.test ; IN: jamshred.tunnel.tests [ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } @@ -14,7 +14,7 @@ IN: jamshred.tunnel.tests [ 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 +[ float-array{ 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 } ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 52f2d38dd1..4c4b3e6812 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays colors combinators float-arrays kernel -locals math math.constants math.matrices math.order math.ranges -math.vectors math.quadratic random sequences vectors jamshred.oint ; +USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline @@ -26,20 +24,20 @@ C: segment : (random-segments) ( segments n -- segments ) dup 0 > [ - >r dup peek random-segment over push r> 1- (random-segments) + [ dup peek random-segment over push ] dip 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 } + float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } 0 random-color default-segment-radius ; : random-segments ( n -- segments ) initial-segment 1vector swap (random-segments) ; : simple-segment ( n -- segment ) - [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep + [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep random-color default-segment-radius ; : simple-segments ( n -- segments ) @@ -58,12 +56,12 @@ C: segment : 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 ? ; + [ 2dup ] dip tuck distance [ distance ] dip < -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> = ; + pick [ nearer-segment dup ] dip = ; : find-nearest-segment ( oint segments -- segment ) dup first swap rest-slice rot [ (find-nearest-segment) ] curry @@ -78,9 +76,9 @@ C: 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 ; + number>> over [ + [ nearest-segment-forward ] 3keep nearest-segment-backward + ] dip nearer-segment ; : get-segment ( segments n -- segment ) over sequence-index-range clamp-to-range swap nth ; -- 2.34.1