Merge branch 'maintenance' into experimental

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
+: min-vertices ( -- n ) 6 ; inline
-: max-vertices 32 ; 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 glPushMatrix
-    GL_PROJECTION glMatrixMode glLoadIdentity
+    GL_MODELVIEW glMatrixMode glPushMatrix
-    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
@@ -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 ;
-

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 )
-    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> >>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
+    dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
-    [ first swap x>radians ] 2keep second swap y>radians
+    rot jamshred>> mouse-moved ;
-    r> 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 ] }
+    { motion [ handle-mouse-motion ] }
-    { T{ mouse-scroll } [ handle-mouse-scroll ] }
+    { mouse-scroll [ handle-mouse-scroll ] }
 } set-gestures
 
-: jamshred-window ( -- gadget )
+: jamshred-window ( -- )
-    [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
+    [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
 
 MAIN: jamshred-window

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> 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 ;

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 ;
 
 : <player> ( 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 ;

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 ;

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 ] [ <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
+[ float-array{ 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> ;

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
+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 ;
-locals math math.constants math.matrices math.order math.ranges
-math.vectors math.quadratic random sequences vectors jamshred.oint ;
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline
@@ -26,20 +24,20 @@ C: <segment> 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 <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
+    [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
     random-color default-segment-radius <segment> ;
 
 : simple-segments ( n -- segments )
@@ -58,12 +56,12 @@ C: <segment> 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> 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
+    number>> over [
-    [ nearest-segment-forward ] 3keep
+        [ nearest-segment-forward ] 3keep nearest-segment-backward
-    nearest-segment-backward r> nearer-segment ;
+    ] dip nearer-segment ;
 
 : get-segment ( segments n -- segment )
     over sequence-index-range clamp-to-range swap nth ;

extra/morse/morse.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lists math
+USING: accessors ascii assocs combinators hashtables kernel lists math
 namespaces make openal parser-combinators promises sequences
-strings symbols synth synth.buffers unicode.case ;
+strings synth synth.buffers unicode.case ;
 IN: morse
 
 <PRIVATE
@@ -135,7 +135,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
 : intra-char-gap ( -- ) intra-char-gap-buffer queue ;
 : letter-gap ( -- ) letter-gap-buffer queue ;
 
-: beep-freq 880 ;
+: beep-freq ( -- n ) 880 ;
 
 : <morse-buffer> ( -- buffer )
     half-sample-freq <8bit-mono-buffer> ;
@@ -160,7 +160,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
         init-openal 1 gen-sources first source set make-buffers
         call
         source get source-play
-    ] with-scope ;
+    ] with-scope ; inline
 
 : play-char ( ch -- )
     [ intra-char-gap ] [
@@ -176,7 +176,7 @@ PRIVATE>
 : play-as-morse* ( str unit-length -- )
     [
         [ letter-gap ] [ ch>morse play-char ] interleave
-    ] swap playing-morse ;
+    ] swap playing-morse ; inline
 
 : play-as-morse ( str -- )
-    0.05 play-as-morse* ;
+    0.05 play-as-morse* ; inline

extra/openal/macosx/macosx.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel alien alien.syntax shuffle
-combinators.lib openal.backend namespaces system ;
+openal.backend namespaces system generalizations ;
 IN: openal.macosx
 
 LIBRARY: alut
@@ -10,5 +10,5 @@ FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data,
 
 M: macosx load-wav-file ( path -- format data size frequency )
     0 <int> f <void*> 0 <int> 0 <int>
-    [ alutLoadWAVFile ] 4keep
+    [ alutLoadWAVFile ] 4 nkeep
     [ [ [ *int ] dip *void* ] dip *int ] dip *int ;

extra/openal/openal.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays alien system combinators alien.syntax namespaces
+USING: kernel accessors arrays alien system combinators alien.syntax namespaces
        alien.c-types sequences vocabs.loader shuffle
-       openal.backend specialized-arrays.uint ;
+       openal.backend specialized-arrays.uint alien.libraries generalizations ;
 IN: openal
 
 << "alut" {
@@ -245,13 +245,11 @@ SYMBOL: init
         f init set-global
     ] unless ;
 
-: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
-
 : gen-sources ( size -- seq )
-    dup <uint-array> 2dup underlying>> alGenSources swap ;
+    dup <uint-array> [ alGenSources ] keep ;
 
 : gen-buffers ( size -- seq )
-    dup <uint-array> 2dup underlying>> alGenBuffers swap ;
+    dup <uint-array> [ alGenBuffers ] keep ;
 
 : gen-buffer ( -- buffer ) 1 gen-buffers first ;
 
@@ -264,10 +262,10 @@ os macosx? "openal.macosx" "openal.other" ? require
 
 : create-buffer-from-wav ( filename -- buffer )
     gen-buffer dup rot load-wav-file
-    [ alBufferData ] 4keep alutUnloadWAV ;
+    [ alBufferData ] 4 nkeep alutUnloadWAV ;
 
 : queue-buffers ( source buffers -- )
-    [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
+    [ length ] [ >uint-array ] bi alSourceQueueBuffers ;
 
 : queue-buffer ( source buffer -- )
     1array queue-buffers ;

extra/synth/buffers/buffers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged ;
+USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged specialized-arrays.uchar specialized-arrays.short ;
 IN: synth.buffers
 
 TUPLE: buffer sample-freq 8bit? id ;
@@ -57,11 +57,11 @@ M: 8bit-stereo-buffer buffer-data
 M: 16bit-stereo-buffer buffer-data
     interleaved-stereo-data 16bit-buffer-data ;
 
-: telephone-sample-freq 8000 ;
+: telephone-sample-freq ( -- n ) 8000 ;
-: half-sample-freq 22050 ;
+: half-sample-freq ( -- n ) 22050 ;
-: cd-sample-freq 44100 ;
+: cd-sample-freq ( -- n ) 44100 ;
-: digital-sample-freq 48000 ;
+: digital-sample-freq ( -- n ) 48000 ;
-: professional-sample-freq 88200 ;
+: professional-sample-freq ( -- n ) 88200 ;
 
 : send-buffer ( buffer -- buffer )
     {