--- /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, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
+IN: jamshred.game
+
+TUPLE: jamshred sounds tunnel players running quit ;
+
+: <jamshred> ( -- 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
+opengl.demo-support sequences specialized-arrays.float ;
+IN: jamshred.gl
+
+: min-vertices ( -- n ) 6 ; inline
+: max-vertices ( -- n ) 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 float-array{ 0.0 } append swap each
+ ] do-state ;
+
+: draw-segments ( segments -- )
+ 1 over length pick subseq swap [ draw-segment ] 2each ;
+
+: segments-to-render ( player -- segments )
+ dup nearest-segment>> number>> dup n-segments-behind -
+ swap n-segments-ahead + rot tunnel>> sub-tunnel ;
+
+: draw-tunnel ( player -- )
+ segments-to-render draw-segments ;
+
+: init-graphics ( -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_PROJECTION glMatrixMode glPushMatrix
+ GL_MODELVIEW glMatrixMode glPushMatrix
+ GL_LEQUAL glDepthFunc
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_FOG glEnable
+ GL_FOG_DENSITY 0.09 glFogf
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
+
+: cleanup-graphics ( -- )
+ GL_DEPTH_TEST glDisable
+ GL_SCISSOR_TEST glEnable
+ GL_MODELVIEW glMatrixMode glPopMatrix
+ GL_PROJECTION glMatrixMode glPopMatrix
+ GL_LIGHTING glDisable
+ GL_LIGHT0 glDisable
+ GL_FOG glDisable
+ GL_COLOR_MATERIAL glDisable ;
+
+: pre-draw ( width height -- )
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_PROJECTION glMatrixMode glLoadIdentity
+ dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
+ GL_MODELVIEW glMatrixMode glLoadIdentity ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ;
--- /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.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 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>> ] [ dim>> first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 100 milliseconds sleep 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 -- )
+ [ find-gl-context init-graphics ]
+ [ [ jamshred-loop ] curry in-thread ] bi ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ;
+
+: jamshred-restart ( jamshred-gadget -- )
+ <jamshred> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ dim>> first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ dim>> second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
+ rot jamshred>> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ 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 ] }
+ { motion [ handle-mouse-motion ] }
+ { mouse-scroll [ handle-mouse-scroll ] }
+} set-gestures
+
+: jamshred-window ( -- )
+ [ <jamshred> <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, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >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.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
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 30.0 ;
+
+: <player> ( name sounds -- player )
+ [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ [ over ] dip left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ [ 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) ;
+
+: almost-to-collision ( player -- distance )
+ distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [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 ] ;
+
+: distance-to-move-freely ( player -- distance )
+ [ almost-to-collision ]
+ [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ ! must make sure we are moving a significant distance, otherwise
+ ! we can recurse endlessly due to floating-point imprecision.
+ ! (at least I /think/ that's what causes it...)
+ dup distance-to-move-freely dup 0.1 > [
+ over forward>> move-player-on-heading ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
+
+: move-player ( player -- )
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
+
+: update-player ( player -- )
+ [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.pathnames kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- 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 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 }
+ 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
+
+[ 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> ;
+
+[ { -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 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
+
+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 first3 1.0 <rgba> ;
+
+: 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 > [
+ [ dup peek random-segment over push ] dip 1- (random-segments)
+ ] [ drop ] if ;
+
+: default-segment-radius ( -- r ) 1 ;
+
+: initial-segment ( -- segment )
+ float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
+ random-color default-segment-radius <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
+ [ 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 [ nearer-segment dup ] dip = ;
+
+: 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 [
+ [ nearest-segment-forward ] 3keep nearest-segment-backward
+ ] dip 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
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: morse
+
+HELP: ch>morse
+{ $values
+ { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
+{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
+
+HELP: morse>ch
+{ $values
+ { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
+{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
+
+HELP: >morse
+{ $values
+ { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
+{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
+{ $see-also morse> ch>morse } ;
+
+HELP: morse>
+{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
+{ $description "Translates morse code into ASCII text" }
+{ $see-also >morse morse>ch } ;
+
+HELP: play-as-morse*
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } }
+{ $description "Plays a string as morse code" } ;
+
+HELP: play-as-morse
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } }
+{ $description "Plays a string as morse code" } ;
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays morse strings tools.test ;
+
+[ "" ] [ CHAR: \\ ch>morse ] unit-test
+[ "..." ] [ CHAR: s ch>morse ] unit-test
+[ CHAR: s ] [ "..." morse>ch ] unit-test
+[ f ] [ "..--..--.." morse>ch ] unit-test
+[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
+[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
+[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
+! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
+! [ ] [ "Factor rocks!" play-as-morse ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ascii assocs combinators hashtables kernel lists math
+namespaces make openal parser-combinators promises sequences
+strings synth synth.buffers unicode.case ;
+IN: morse
+
+<PRIVATE
+: morse-codes ( -- array )
+ {
+ { CHAR: a ".-" }
+ { CHAR: b "-..." }
+ { CHAR: c "-.-." }
+ { CHAR: d "-.." }
+ { CHAR: e "." }
+ { CHAR: f "..-." }
+ { CHAR: g "--." }
+ { CHAR: h "...." }
+ { CHAR: i ".." }
+ { CHAR: j ".---" }
+ { CHAR: k "-.-" }
+ { CHAR: l ".-.." }
+ { CHAR: m "--" }
+ { CHAR: n "-." }
+ { CHAR: o "---" }
+ { CHAR: p ".--." }
+ { CHAR: q "--.-" }
+ { CHAR: r ".-." }
+ { CHAR: s "..." }
+ { CHAR: t "-" }
+ { CHAR: u "..-" }
+ { CHAR: v "...-" }
+ { CHAR: w ".--" }
+ { CHAR: x "-..-" }
+ { CHAR: y "-.--" }
+ { CHAR: z "--.." }
+ { CHAR: 1 ".----" }
+ { CHAR: 2 "..---" }
+ { CHAR: 3 "...--" }
+ { CHAR: 4 "....-" }
+ { CHAR: 5 "....." }
+ { CHAR: 6 "-...." }
+ { CHAR: 7 "--..." }
+ { CHAR: 8 "---.." }
+ { CHAR: 9 "----." }
+ { CHAR: 0 "-----" }
+ { CHAR: . ".-.-.-" }
+ { CHAR: , "--..--" }
+ { CHAR: ? "..--.." }
+ { CHAR: ' ".----." }
+ { CHAR: ! "-.-.--" }
+ { CHAR: / "-..-." }
+ { CHAR: ( "-.--." }
+ { CHAR: ) "-.--.-" }
+ { CHAR: & ".-..." }
+ { CHAR: : "---..." }
+ { CHAR: ; "-.-.-." }
+ { CHAR: = "-...- " }
+ { CHAR: + ".-.-." }
+ { CHAR: - "-....-" }
+ { CHAR: _ "..--.-" }
+ { CHAR: " ".-..-." }
+ { CHAR: $ "...-..-" }
+ { CHAR: @ ".--.-." }
+ { CHAR: \s "/" }
+ } ;
+
+: ch>morse-assoc ( -- assoc )
+ morse-codes >hashtable ;
+
+: morse>ch-assoc ( -- assoc )
+ morse-codes [ reverse ] map >hashtable ;
+
+PRIVATE>
+
+: ch>morse ( ch -- str )
+ ch>lower ch>morse-assoc at* swap "" ? ;
+
+: morse>ch ( str -- ch )
+ morse>ch-assoc at* swap f ? ;
+
+: >morse ( str -- str )
+ [
+ [ CHAR: \s , ] [ ch>morse % ] interleave
+ ] "" make ;
+
+<PRIVATE
+
+: dot-char ( -- ch ) CHAR: . ;
+: dash-char ( -- ch ) CHAR: - ;
+: char-gap-char ( -- ch ) CHAR: \s ;
+: word-gap-char ( -- ch ) CHAR: / ;
+
+: =parser ( obj -- parser )
+ [ = ] curry satisfy ;
+
+LAZY: 'dot' ( -- parser )
+ dot-char =parser ;
+
+LAZY: 'dash' ( -- parser )
+ dash-char =parser ;
+
+LAZY: 'char-gap' ( -- parser )
+ char-gap-char =parser ;
+
+LAZY: 'word-gap' ( -- parser )
+ word-gap-char =parser ;
+
+LAZY: 'morse-char' ( -- parser )
+ 'dot' 'dash' <|> <+> ;
+
+LAZY: 'morse-word' ( -- parser )
+ 'morse-char' 'char-gap' list-of ;
+
+LAZY: 'morse-words' ( -- parser )
+ 'morse-word' 'word-gap' list-of ;
+
+PRIVATE>
+
+: morse> ( str -- str )
+ 'morse-words' parse car parsed>> [
+ [
+ >string morse>ch
+ ] map >string
+ ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
+
+<PRIVATE
+SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
+
+: queue ( symbol -- )
+ get source get swap queue-buffer ;
+
+: dot ( -- ) dot-buffer queue ;
+: dash ( -- ) dash-buffer queue ;
+: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
+: letter-gap ( -- ) letter-gap-buffer queue ;
+
+: beep-freq ( -- n ) 880 ;
+
+: <morse-buffer> ( -- buffer )
+ half-sample-freq <8bit-mono-buffer> ;
+
+: sine-buffer ( seconds -- id )
+ beep-freq swap <morse-buffer> >sine-wave-buffer
+ send-buffer id>> ;
+
+: silent-buffer ( seconds -- id )
+ <morse-buffer> >silent-buffer send-buffer id>> ;
+
+: make-buffers ( unit-length -- )
+ {
+ [ sine-buffer dot-buffer set ]
+ [ 3 * sine-buffer dash-buffer set ]
+ [ silent-buffer intra-char-gap-buffer set ]
+ [ 3 * silent-buffer letter-gap-buffer set ]
+ } cleave ;
+
+: playing-morse ( quot unit-length -- )
+ [
+ init-openal 1 gen-sources first source set make-buffers
+ call
+ source get source-play
+ ] with-scope ; inline
+
+: play-char ( ch -- )
+ [ intra-char-gap ] [
+ {
+ { dot-char [ dot ] }
+ { dash-char [ dash ] }
+ { word-gap-char [ intra-char-gap ] }
+ } case
+ ] interleave ;
+
+PRIVATE>
+
+: play-as-morse* ( str unit-length -- )
+ [
+ [ letter-gap ] [ ch>morse play-char ] interleave
+ ] swap playing-morse ; inline
+
+: play-as-morse ( str -- )
+ 0.05 play-as-morse* ; inline
--- /dev/null
+Converts between text and morse code, and plays morse code.
--- /dev/null
+Chris Double
--- /dev/null
+Chris Double
--- /dev/null
+USING: namespaces system ;
+IN: openal.backend
+
+HOOK: load-wav-file os ( filename -- format data size frequency )
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+!\r
+IN: openal.example\r
+USING: openal kernel alien threads sequences calendar ;\r
+\r
+: play-hello ( -- )\r
+ init-openal\r
+ 1 gen-sources\r
+ first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
+ source-play\r
+ 1000 milliseconds sleep ;\r
+ \r
+: (play-file) ( source -- )\r
+ 100 milliseconds sleep\r
+ dup source-playing? [ (play-file) ] [ drop ] if ;\r
+\r
+: play-file ( filename -- )\r
+ init-openal\r
+ create-buffer-from-file \r
+ 1 gen-sources\r
+ first dup >r AL_BUFFER rot set-source-param r>\r
+ dup source-play\r
+ check-error\r
+ (play-file) ;\r
+\r
+: play-wav ( filename -- )\r
+ init-openal\r
+ create-buffer-from-wav \r
+ 1 gen-sources\r
+ first dup >r AL_BUFFER rot set-source-param r>\r
+ dup source-play\r
+ check-error\r
+ (play-file) ;
\ No newline at end of file
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel alien alien.syntax shuffle
+openal.backend namespaces system generalizations ;
+IN: openal.macosx
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
+
+M: macosx load-wav-file ( path -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ alutLoadWAVFile ] 4 nkeep
+ [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors arrays alien system combinators alien.syntax namespaces
+ alien.c-types sequences vocabs.loader shuffle
+ openal.backend specialized-arrays.uint alien.libraries generalizations ;
+IN: openal
+
+<< "alut" {
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libalut.so" ] }
+ } cond "cdecl" add-library >>
+
+<< "openal" {
+ { [ os windows? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libopenal.so" ] }
+ } cond "cdecl" add-library >>
+
+LIBRARY: openal
+
+TYPEDEF: char ALboolean
+TYPEDEF: char ALchar
+TYPEDEF: char ALbyte
+TYPEDEF: uchar ALubyte
+TYPEDEF: short ALshort
+TYPEDEF: ushort ALushort
+TYPEDEF: int ALint
+TYPEDEF: uint ALuint
+TYPEDEF: int ALsizei
+TYPEDEF: int ALenum
+TYPEDEF: float ALfloat
+TYPEDEF: double ALdouble
+
+CONSTANT: AL_INVALID -1
+CONSTANT: AL_NONE 0
+CONSTANT: AL_FALSE 0
+CONSTANT: AL_TRUE 1
+CONSTANT: AL_SOURCE_RELATIVE HEX: 202
+CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
+CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
+CONSTANT: AL_PITCH HEX: 1003
+CONSTANT: AL_POSITION HEX: 1004
+CONSTANT: AL_DIRECTION HEX: 1005
+CONSTANT: AL_VELOCITY HEX: 1006
+CONSTANT: AL_LOOPING HEX: 1007
+CONSTANT: AL_BUFFER HEX: 1009
+CONSTANT: AL_GAIN HEX: 100A
+CONSTANT: AL_MIN_GAIN HEX: 100D
+CONSTANT: AL_MAX_GAIN HEX: 100E
+CONSTANT: AL_ORIENTATION HEX: 100F
+CONSTANT: AL_CHANNEL_MASK HEX: 3000
+CONSTANT: AL_SOURCE_STATE HEX: 1010
+CONSTANT: AL_INITIAL HEX: 1011
+CONSTANT: AL_PLAYING HEX: 1012
+CONSTANT: AL_PAUSED HEX: 1013
+CONSTANT: AL_STOPPED HEX: 1014
+CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
+CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
+CONSTANT: AL_SEC_OFFSET HEX: 1024
+CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
+CONSTANT: AL_BYTE_OFFSET HEX: 1026
+CONSTANT: AL_SOURCE_TYPE HEX: 1027
+CONSTANT: AL_STATIC HEX: 1028
+CONSTANT: AL_STREAMING HEX: 1029
+CONSTANT: AL_UNDETERMINED HEX: 1030
+CONSTANT: AL_FORMAT_MONO8 HEX: 1100
+CONSTANT: AL_FORMAT_MONO16 HEX: 1101
+CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
+CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
+CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
+CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
+CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
+CONSTANT: AL_MAX_DISTANCE HEX: 1023
+CONSTANT: AL_FREQUENCY HEX: 2001
+CONSTANT: AL_BITS HEX: 2002
+CONSTANT: AL_CHANNELS HEX: 2003
+CONSTANT: AL_SIZE HEX: 2004
+CONSTANT: AL_UNUSED HEX: 2010
+CONSTANT: AL_PENDING HEX: 2011
+CONSTANT: AL_PROCESSED HEX: 2012
+CONSTANT: AL_NO_ERROR AL_FALSE
+CONSTANT: AL_INVALID_NAME HEX: A001
+CONSTANT: AL_ILLEGAL_ENUM HEX: A002
+CONSTANT: AL_INVALID_ENUM HEX: A002
+CONSTANT: AL_INVALID_VALUE HEX: A003
+CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
+CONSTANT: AL_INVALID_OPERATION HEX: A004
+CONSTANT: AL_OUT_OF_MEMORY HEX: A005
+CONSTANT: AL_VENDOR HEX: B001
+CONSTANT: AL_VERSION HEX: B002
+CONSTANT: AL_RENDERER HEX: B003
+CONSTANT: AL_EXTENSIONS HEX: B004
+CONSTANT: AL_DOPPLER_FACTOR HEX: C000
+CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
+CONSTANT: AL_SPEED_OF_SOUND HEX: C003
+CONSTANT: AL_DISTANCE_MODEL HEX: D000
+CONSTANT: AL_INVERSE_DISTANCE HEX: D001
+CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
+CONSTANT: AL_LINEAR_DISTANCE HEX: D003
+CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
+CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
+CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
+
+FUNCTION: void alEnable ( ALenum capability ) ;
+FUNCTION: void alDisable ( ALenum capability ) ;
+FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
+FUNCTION: ALchar* alGetString ( ALenum param ) ;
+FUNCTION: void alGetBooleanv ( ALenum param, ALboolean* data ) ;
+FUNCTION: void alGetIntegerv ( ALenum param, ALint* data ) ;
+FUNCTION: void alGetFloatv ( ALenum param, ALfloat* data ) ;
+FUNCTION: void alGetDoublev ( ALenum param, ALdouble* data ) ;
+FUNCTION: ALboolean alGetBoolean ( ALenum param ) ;
+FUNCTION: ALint alGetInteger ( ALenum param ) ;
+FUNCTION: ALfloat alGetFloat ( ALenum param ) ;
+FUNCTION: ALdouble alGetDouble ( ALenum param ) ;
+FUNCTION: ALenum alGetError ( ) ;
+FUNCTION: ALboolean alIsExtensionPresent ( ALchar* extname ) ;
+FUNCTION: void* alGetProcAddress ( ALchar* fname ) ;
+FUNCTION: ALenum alGetEnumValue ( ALchar* ename ) ;
+FUNCTION: void alListenerf ( ALenum param, ALfloat value ) ;
+FUNCTION: void alListener3f ( ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
+FUNCTION: void alListeneri ( ALenum param, ALint value ) ;
+FUNCTION: void alListener3i ( ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alListeneriv ( ALenum param, ALint* values ) ;
+FUNCTION: void alGetListenerf ( ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetListener3f ( ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3 ) ;
+FUNCTION: void alGetListenerfv ( ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetListeneri ( ALenum param, ALint* value ) ;
+FUNCTION: void alGetListener3i ( ALenum param, ALint* value1, ALint* value2, ALint* value3 ) ;
+FUNCTION: void alGetListeneriv ( ALenum param, ALint* values ) ;
+FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
+FUNCTION: void alDeleteSources ( ALsizei n, ALuint* sources ) ;
+FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
+FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
+FUNCTION: void alSource3f ( ALuint sid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
+FUNCTION: void alSource3i ( ALuint sid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
+FUNCTION: void alGetSourcef ( ALuint sid, ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetSource3f ( ALuint sid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
+FUNCTION: void alGetSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetSourcei ( ALuint sid, ALenum param, ALint* value ) ;
+FUNCTION: void alGetSource3i ( ALuint sid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
+FUNCTION: void alGetSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
+FUNCTION: void alSourcePlayv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourceStopv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourceRewindv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourcePausev ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourcePlay ( ALuint sid ) ;
+FUNCTION: void alSourceStop ( ALuint sid ) ;
+FUNCTION: void alSourceRewind ( ALuint sid ) ;
+FUNCTION: void alSourcePause ( ALuint sid ) ;
+FUNCTION: void alSourceQueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
+FUNCTION: void alSourceUnqueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
+FUNCTION: void alGenBuffers ( ALsizei n, ALuint* buffers ) ;
+FUNCTION: void alDeleteBuffers ( ALsizei n, ALuint* buffers ) ;
+FUNCTION: ALboolean alIsBuffer ( ALuint bid ) ;
+FUNCTION: void alBufferData ( ALuint bid, ALenum format, void* data, ALsizei size, ALsizei freq ) ;
+FUNCTION: void alBufferf ( ALuint bid, ALenum param, ALfloat value ) ;
+FUNCTION: void alBuffer3f ( ALuint bid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alBufferi ( ALuint bid, ALenum param, ALint value ) ;
+FUNCTION: void alBuffer3i ( ALuint bid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
+FUNCTION: void alGetBufferf ( ALuint bid, ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetBuffer3f ( ALuint bid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
+FUNCTION: void alGetBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetBufferi ( ALuint bid, ALenum param, ALint* value ) ;
+FUNCTION: void alGetBuffer3i ( ALuint bid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
+FUNCTION: void alGetBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
+FUNCTION: void alDopplerFactor ( ALfloat value ) ;
+FUNCTION: void alDopplerVelocity ( ALfloat value ) ;
+FUNCTION: void alSpeedOfSound ( ALfloat value ) ;
+FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
+
+LIBRARY: alut
+
+CONSTANT: ALUT_API_MAJOR_VERSION 1
+CONSTANT: ALUT_API_MINOR_VERSION 1
+CONSTANT: ALUT_ERROR_NO_ERROR 0
+CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
+CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
+CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
+CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
+CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
+CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
+CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
+CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
+CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
+CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
+CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
+CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
+CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
+CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
+CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
+CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
+CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
+CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
+CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
+CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
+CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
+CONSTANT: ALUT_LOADER_BUFFER HEX: 300
+CONSTANT: ALUT_LOADER_MEMORY HEX: 301
+
+FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutExit ( ) ;
+FUNCTION: ALenum alutGetError ( ) ;
+FUNCTION: char* alutGetErrorString ( ALenum error ) ;
+FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
+FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
+FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
+FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
+FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
+FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
+FUNCTION: ALint alutGetMajorVersion ( ) ;
+FUNCTION: ALint alutGetMinorVersion ( ) ;
+FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
+
+FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
+
+SYMBOL: init
+
+: init-openal ( -- )
+ init get-global expired? [
+ f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
+ 1337 <alien> init set-global
+ ] when ;
+
+: exit-openal ( -- )
+ init get-global expired? [
+ alutExit 0 = [ "Could not close OpenAL" throw ] when
+ f init set-global
+ ] unless ;
+
+: gen-sources ( size -- seq )
+ dup <uint-array> [ alGenSources ] keep ;
+
+: gen-buffers ( size -- seq )
+ dup <uint-array> [ alGenBuffers ] keep ;
+
+: gen-buffer ( -- buffer ) 1 gen-buffers first ;
+
+: create-buffer-from-file ( filename -- buffer )
+ alutCreateBufferFromFile dup AL_NONE = [
+ "create-buffer-from-file failed" throw
+ ] when ;
+
+os macosx? "openal.macosx" "openal.other" ? require
+
+: create-buffer-from-wav ( filename -- buffer )
+ gen-buffer dup rot load-wav-file
+ [ alBufferData ] 4 nkeep alutUnloadWAV ;
+
+: queue-buffers ( source buffers -- )
+ [ length ] [ >uint-array ] bi alSourceQueueBuffers ;
+
+: queue-buffer ( source buffer -- )
+ 1array queue-buffers ;
+
+: set-source-param ( source param value -- )
+ alSourcei ;
+
+: get-source-param ( source param -- value )
+ 0 <uint> dup [ alGetSourcei ] dip *uint ;
+
+: set-buffer-param ( source param value -- )
+ alBufferi ;
+
+: get-buffer-param ( source param -- value )
+ 0 <uint> dup [ alGetBufferi ] dip *uint ;
+
+: source-play ( source -- ) alSourcePlay ;
+
+: source-stop ( source -- ) alSourceStop ;
+
+: check-error ( -- )
+ alGetError dup ALUT_ERROR_NO_ERROR = [
+ drop
+ ] [
+ alGetString throw
+ ] if ;
+
+: source-playing? ( source -- bool )
+ AL_SOURCE_STATE get-source-param AL_PLAYING = ;
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: openal.backend alien.c-types kernel alien alien.syntax
+shuffle combinators.lib ;
+IN: openal.other
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
+
+M: object load-wav-file ( filename -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ 0 <char> alutLoadWAVFile ] 4keep
+ >r >r >r *int r> *void* r> *int r> *int ;
--- /dev/null
+OpenAL 3D audio library binding
--- /dev/null
+bindings
+audio
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 specialized-arrays.uchar specialized-arrays.short ;
+IN: synth.buffers
+
+TUPLE: buffer sample-freq 8bit? id ;
+
+: <buffer> ( sample-freq 8bit? -- buffer )
+ f buffer boa ;
+
+TUPLE: mono-buffer < buffer data ;
+
+: <mono-buffer> ( sample-freq 8bit? -- buffer )
+ f f mono-buffer boa ;
+
+: <8bit-mono-buffer> ( sample-freq -- buffer ) t <mono-buffer> ;
+: <16bit-mono-buffer> ( sample-freq -- buffer ) f <mono-buffer> ;
+
+TUPLE: stereo-buffer < buffer left-data right-data ;
+
+: <stereo-buffer> ( sample-freq 8bit? -- buffer )
+ f f f stereo-buffer boa ;
+
+: <8bit-stereo-buffer> ( sample-freq -- buffer ) t <stereo-buffer> ;
+: <16bit-stereo-buffer> ( sample-freq -- buffer ) f <stereo-buffer> ;
+
+PREDICATE: 8bit-buffer < buffer 8bit?>> ;
+PREDICATE: 16bit-buffer < buffer 8bit?>> not ;
+INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ;
+INTERSECTION: 16bit-mono-buffer 16bit-buffer mono-buffer ;
+INTERSECTION: 8bit-stereo-buffer 8bit-buffer stereo-buffer ;
+INTERSECTION: 16bit-stereo-buffer 16bit-buffer stereo-buffer ;
+
+GENERIC: buffer-format ( buffer -- format )
+M: 8bit-mono-buffer buffer-format drop AL_FORMAT_MONO8 ;
+M: 16bit-mono-buffer buffer-format drop AL_FORMAT_MONO16 ;
+M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ;
+M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ;
+
+: 8bit-buffer-data ( seq -- data size )
+ [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ;
+
+: 16bit-buffer-data ( seq -- data size )
+ [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ;
+
+: stereo-data ( stereo-buffer -- left right )
+ [ left-data>> ] [ right-data>> ] bi@ ;
+
+: interleaved-stereo-data ( stereo-buffer -- data )
+ stereo-data <2merged> ;
+
+GENERIC: buffer-data ( buffer -- data size )
+M: 8bit-mono-buffer buffer-data data>> 8bit-buffer-data ;
+M: 16bit-mono-buffer buffer-data data>> 16bit-buffer-data ;
+M: 8bit-stereo-buffer buffer-data
+ interleaved-stereo-data 8bit-buffer-data ;
+M: 16bit-stereo-buffer buffer-data
+ interleaved-stereo-data 16bit-buffer-data ;
+
+: telephone-sample-freq ( -- n ) 8000 ;
+: half-sample-freq ( -- n ) 22050 ;
+: cd-sample-freq ( -- n ) 44100 ;
+: digital-sample-freq ( -- n ) 48000 ;
+: professional-sample-freq ( -- n ) 88200 ;
+
+: send-buffer ( buffer -- buffer )
+ {
+ [ gen-buffer dup [ >>id ] dip ]
+ [ buffer-format ]
+ [ buffer-data ]
+ [ sample-freq>> alBufferData ]
+ } cleave ;
+
+: ?send-buffer ( buffer -- buffer )
+ dup id>> [ send-buffer ] unless ;
+
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel namespaces make openal sequences
+synth synth.buffers ;
+IN: synth.example
+
+: play-sine-wave ( freq seconds sample-freq -- )
+ init-openal
+ <16bit-mono-buffer> >sine-wave-buffer send-buffer id>>
+ 1 gen-sources first
+ [ AL_BUFFER rot set-source-param ] [ source-play ] bi
+ check-error ;
+
+: test-instrument1 ( -- harmonics )
+ [
+ 1 0.5 <harmonic> ,
+ 2 0.125 <harmonic> ,
+ 3 0.0625 <harmonic> ,
+ 4 0.03125 <harmonic> ,
+ ] { } make ;
+
+: test-instrument2 ( -- harmonics )
+ [
+ 1 0.25 <harmonic> ,
+ 2 0.25 <harmonic> ,
+ 3 0.25 <harmonic> ,
+ 4 0.25 <harmonic> ,
+ ] { } make ;
+
+: sine-instrument ( -- harmonics )
+ 1 1 <harmonic> 1array ;
+
+: test-note-buffer ( note -- )
+ init-openal
+ test-instrument2 swap cd-sample-freq <16bit-mono-buffer>
+ >note send-buffer id>>
+ 1 gen-sources first [ swap queue-buffer ] [ source-play ] bi
+ check-error ;
--- /dev/null
+Simple sound synthesis using OpenAL.
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
+IN: synth
+
+MEMO: single-sine-wave ( samples/wave -- seq )
+ pi 2 * over / [ * sin ] curry map ;
+
+: (sine-wave) ( samples/wave n-samples -- seq )
+ [ single-sine-wave ] dip <repeating> ;
+
+: sine-wave ( sample-freq freq seconds -- seq )
+ pick * >integer [ /i ] dip (sine-wave) ;
+
+: >sine-wave-buffer ( freq seconds buffer -- buffer )
+ [ sample-freq>> -rot sine-wave ] keep swap >>data ;
+
+: >silent-buffer ( seconds buffer -- buffer )
+ tuck sample-freq>> * >integer 0 <repetition> >>data ;
+
+TUPLE: harmonic n amplitude ;
+C: <harmonic> harmonic
+
+TUPLE: note hz secs ;
+C: <note> note
+
+: harmonic-freq ( note harmonic -- freq )
+ n>> swap hz>> * ;
+
+:: note-harmonic-data ( harmonic note buffer -- data )
+ buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave
+ harmonic amplitude>> <scaled> ;
+
+: >note ( harmonics note buffer -- buffer )
+ dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
+
+++ /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, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
-IN: jamshred.game
-
-TUPLE: jamshred sounds tunnel players running quit ;
-
-: <jamshred> ( -- 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
-opengl.demo-support sequences specialized-arrays.float ;
-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 float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
-
-: 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 ]
- [ 10 milliseconds sleep 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 ] curry in-thread ;
-
-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 strings system ;
-IN: jamshred.player
-
-TUPLE: player < oint
- { name string }
- { sounds sounds }
- tunnel
- nearest-segment
- { last-move integer }
- { speed float } ;
-
-! 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 0 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) ;
-
-: almost-to-collision ( player -- distance )
- distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
-
-: from ( player -- radius distance-from-centre )
- [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
- distance-from-centre ;
-
-: distance-from-wall ( player -- distance ) from - ;
-: fraction-from-centre ( player -- fraction ) from swap / ;
-: fraction-from-wall ( player -- fraction )
- fraction-from-centre 1 swap - ;
-
-: update-nearest-segment2 ( heading player -- )
- 2dup distance-to-heading-segment-area 0 <= [
- [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
- [ (>>nearest-segment) ] tri
- ] [
- 2drop
- ] if ;
-
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [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 ] ;
-
-: distance-to-move-freely ( player -- distance )
- [ almost-to-collision ]
- [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
-
-: ?move-player-freely ( d-left player -- d-left' player )
- over 0 > [
- ! must make sure we are moving a significant distance, otherwise
- ! we can recurse endlessly due to floating-point imprecision.
- ! (at least I /think/ that's what causes it...)
- dup distance-to-move-freely dup 0.1 > [
- over forward>> move-player-on-heading ?move-player-freely
- ] [ drop ] if
- ] when ;
-
-: drag-heading ( player -- heading )
- [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
-
-: drag-player ( d-left player -- d-left' player )
- dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
- [ drag-heading move-player-on-heading ] bi ;
-
-: (move-player) ( d-left player -- d-left' player )
- ?move-player-freely over 0 > [
- ! bounce
- drag-player
- (move-player)
- ] when ;
-
-: move-player ( player -- )
- [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
-
-: update-player ( player -- )
- [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-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 colors combinators float-arrays kernel
-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
-
-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 first3 1.0 <rgba> ;
-
-: 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
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-IN: morse
-
-HELP: ch>morse
-{ $values
- { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
-{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
-
-HELP: morse>ch
-{ $values
- { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
-{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
-
-HELP: >morse
-{ $values
- { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
-{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
-{ $see-also morse> ch>morse } ;
-
-HELP: morse>
-{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
-{ $description "Translates morse code into ASCII text" }
-{ $see-also >morse morse>ch } ;
-
-HELP: play-as-morse*
-{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } }
-{ $description "Plays a string as morse code" } ;
-
-HELP: play-as-morse
-{ $values { "str" "A string of ascii characters which can be translated into morse code" } }
-{ $description "Plays a string as morse code" } ;
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays morse strings tools.test ;
-
-[ "" ] [ CHAR: \\ ch>morse ] unit-test
-[ "..." ] [ CHAR: s ch>morse ] unit-test
-[ CHAR: s ] [ "..." morse>ch ] unit-test
-[ f ] [ "..--..--.." morse>ch ] unit-test
-[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
-[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
-[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
-! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
-! [ ] [ "Factor rocks!" play-as-morse ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lists math
-namespaces make openal parser-combinators promises sequences
-strings symbols synth synth.buffers unicode.case ;
-IN: morse
-
-<PRIVATE
-: morse-codes ( -- array )
- {
- { CHAR: a ".-" }
- { CHAR: b "-..." }
- { CHAR: c "-.-." }
- { CHAR: d "-.." }
- { CHAR: e "." }
- { CHAR: f "..-." }
- { CHAR: g "--." }
- { CHAR: h "...." }
- { CHAR: i ".." }
- { CHAR: j ".---" }
- { CHAR: k "-.-" }
- { CHAR: l ".-.." }
- { CHAR: m "--" }
- { CHAR: n "-." }
- { CHAR: o "---" }
- { CHAR: p ".--." }
- { CHAR: q "--.-" }
- { CHAR: r ".-." }
- { CHAR: s "..." }
- { CHAR: t "-" }
- { CHAR: u "..-" }
- { CHAR: v "...-" }
- { CHAR: w ".--" }
- { CHAR: x "-..-" }
- { CHAR: y "-.--" }
- { CHAR: z "--.." }
- { CHAR: 1 ".----" }
- { CHAR: 2 "..---" }
- { CHAR: 3 "...--" }
- { CHAR: 4 "....-" }
- { CHAR: 5 "....." }
- { CHAR: 6 "-...." }
- { CHAR: 7 "--..." }
- { CHAR: 8 "---.." }
- { CHAR: 9 "----." }
- { CHAR: 0 "-----" }
- { CHAR: . ".-.-.-" }
- { CHAR: , "--..--" }
- { CHAR: ? "..--.." }
- { CHAR: ' ".----." }
- { CHAR: ! "-.-.--" }
- { CHAR: / "-..-." }
- { CHAR: ( "-.--." }
- { CHAR: ) "-.--.-" }
- { CHAR: & ".-..." }
- { CHAR: : "---..." }
- { CHAR: ; "-.-.-." }
- { CHAR: = "-...- " }
- { CHAR: + ".-.-." }
- { CHAR: - "-....-" }
- { CHAR: _ "..--.-" }
- { CHAR: " ".-..-." }
- { CHAR: $ "...-..-" }
- { CHAR: @ ".--.-." }
- { CHAR: \s "/" }
- } ;
-
-: ch>morse-assoc ( -- assoc )
- morse-codes >hashtable ;
-
-: morse>ch-assoc ( -- assoc )
- morse-codes [ reverse ] map >hashtable ;
-
-PRIVATE>
-
-: ch>morse ( ch -- str )
- ch>lower ch>morse-assoc at* swap "" ? ;
-
-: morse>ch ( str -- ch )
- morse>ch-assoc at* swap f ? ;
-
-: >morse ( str -- str )
- [
- [ CHAR: \s , ] [ ch>morse % ] interleave
- ] "" make ;
-
-<PRIVATE
-
-: dot-char ( -- ch ) CHAR: . ;
-: dash-char ( -- ch ) CHAR: - ;
-: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap-char ( -- ch ) CHAR: / ;
-
-: =parser ( obj -- parser )
- [ = ] curry satisfy ;
-
-LAZY: 'dot' ( -- parser )
- dot-char =parser ;
-
-LAZY: 'dash' ( -- parser )
- dash-char =parser ;
-
-LAZY: 'char-gap' ( -- parser )
- char-gap-char =parser ;
-
-LAZY: 'word-gap' ( -- parser )
- word-gap-char =parser ;
-
-LAZY: 'morse-char' ( -- parser )
- 'dot' 'dash' <|> <+> ;
-
-LAZY: 'morse-word' ( -- parser )
- 'morse-char' 'char-gap' list-of ;
-
-LAZY: 'morse-words' ( -- parser )
- 'morse-word' 'word-gap' list-of ;
-
-PRIVATE>
-
-: morse> ( str -- str )
- 'morse-words' parse car parsed>> [
- [
- >string morse>ch
- ] map >string
- ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
-
-<PRIVATE
-SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
-
-: queue ( symbol -- )
- get source get swap queue-buffer ;
-
-: dot ( -- ) dot-buffer queue ;
-: dash ( -- ) dash-buffer queue ;
-: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
-: letter-gap ( -- ) letter-gap-buffer queue ;
-
-: beep-freq 880 ;
-
-: <morse-buffer> ( -- buffer )
- half-sample-freq <8bit-mono-buffer> ;
-
-: sine-buffer ( seconds -- id )
- beep-freq swap <morse-buffer> >sine-wave-buffer
- send-buffer id>> ;
-
-: silent-buffer ( seconds -- id )
- <morse-buffer> >silent-buffer send-buffer id>> ;
-
-: make-buffers ( unit-length -- )
- {
- [ sine-buffer dot-buffer set ]
- [ 3 * sine-buffer dash-buffer set ]
- [ silent-buffer intra-char-gap-buffer set ]
- [ 3 * silent-buffer letter-gap-buffer set ]
- } cleave ;
-
-: playing-morse ( quot unit-length -- )
- [
- init-openal 1 gen-sources first source set make-buffers
- call
- source get source-play
- ] with-scope ;
-
-: play-char ( ch -- )
- [ intra-char-gap ] [
- {
- { dot-char [ dot ] }
- { dash-char [ dash ] }
- { word-gap-char [ intra-char-gap ] }
- } case
- ] interleave ;
-
-PRIVATE>
-
-: play-as-morse* ( str unit-length -- )
- [
- [ letter-gap ] [ ch>morse play-char ] interleave
- ] swap playing-morse ;
-
-: play-as-morse ( str -- )
- 0.05 play-as-morse* ;
+++ /dev/null
-Converts between text and morse code, and plays morse code.
+++ /dev/null
-Chris Double
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: namespaces system ;
-IN: openal.backend
-
-HOOK: load-wav-file os ( filename -- format data size frequency )
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-IN: openal.example\r
-USING: openal kernel alien threads sequences calendar ;\r
-\r
-: play-hello ( -- )\r
- init-openal\r
- 1 gen-sources\r
- first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
- source-play\r
- 1000 milliseconds sleep ;\r
- \r
-: (play-file) ( source -- )\r
- 100 milliseconds sleep\r
- dup source-playing? [ (play-file) ] [ drop ] if ;\r
-\r
-: play-file ( filename -- )\r
- init-openal\r
- create-buffer-from-file \r
- 1 gen-sources\r
- first dup >r AL_BUFFER rot set-source-param r>\r
- dup source-play\r
- check-error\r
- (play-file) ;\r
-\r
-: play-wav ( filename -- )\r
- init-openal\r
- create-buffer-from-wav \r
- 1 gen-sources\r
- first dup >r AL_BUFFER rot set-source-param r>\r
- dup source-play\r
- check-error\r
- (play-file) ;
\ No newline at end of file
+++ /dev/null
-Chris Double
+++ /dev/null
-! 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 ;
-IN: openal.macosx
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
-
-M: macosx load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ alutLoadWAVFile ] 4keep
- [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays alien system combinators alien.syntax namespaces
- alien.c-types sequences vocabs.loader shuffle
- openal.backend specialized-arrays.uint ;
-IN: openal
-
-<< "alut" {
- { [ os windows? ] [ "alut.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libalut.so" ] }
- } cond "cdecl" add-library >>
-
-<< "openal" {
- { [ os windows? ] [ "OpenAL32.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libopenal.so" ] }
- } cond "cdecl" add-library >>
-
-LIBRARY: openal
-
-TYPEDEF: char ALboolean
-TYPEDEF: char ALchar
-TYPEDEF: char ALbyte
-TYPEDEF: uchar ALubyte
-TYPEDEF: short ALshort
-TYPEDEF: ushort ALushort
-TYPEDEF: int ALint
-TYPEDEF: uint ALuint
-TYPEDEF: int ALsizei
-TYPEDEF: int ALenum
-TYPEDEF: float ALfloat
-TYPEDEF: double ALdouble
-
-CONSTANT: AL_INVALID -1
-CONSTANT: AL_NONE 0
-CONSTANT: AL_FALSE 0
-CONSTANT: AL_TRUE 1
-CONSTANT: AL_SOURCE_RELATIVE HEX: 202
-CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
-CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
-CONSTANT: AL_PITCH HEX: 1003
-CONSTANT: AL_POSITION HEX: 1004
-CONSTANT: AL_DIRECTION HEX: 1005
-CONSTANT: AL_VELOCITY HEX: 1006
-CONSTANT: AL_LOOPING HEX: 1007
-CONSTANT: AL_BUFFER HEX: 1009
-CONSTANT: AL_GAIN HEX: 100A
-CONSTANT: AL_MIN_GAIN HEX: 100D
-CONSTANT: AL_MAX_GAIN HEX: 100E
-CONSTANT: AL_ORIENTATION HEX: 100F
-CONSTANT: AL_CHANNEL_MASK HEX: 3000
-CONSTANT: AL_SOURCE_STATE HEX: 1010
-CONSTANT: AL_INITIAL HEX: 1011
-CONSTANT: AL_PLAYING HEX: 1012
-CONSTANT: AL_PAUSED HEX: 1013
-CONSTANT: AL_STOPPED HEX: 1014
-CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
-CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
-CONSTANT: AL_SEC_OFFSET HEX: 1024
-CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
-CONSTANT: AL_BYTE_OFFSET HEX: 1026
-CONSTANT: AL_SOURCE_TYPE HEX: 1027
-CONSTANT: AL_STATIC HEX: 1028
-CONSTANT: AL_STREAMING HEX: 1029
-CONSTANT: AL_UNDETERMINED HEX: 1030
-CONSTANT: AL_FORMAT_MONO8 HEX: 1100
-CONSTANT: AL_FORMAT_MONO16 HEX: 1101
-CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
-CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
-CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
-CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
-CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
-CONSTANT: AL_MAX_DISTANCE HEX: 1023
-CONSTANT: AL_FREQUENCY HEX: 2001
-CONSTANT: AL_BITS HEX: 2002
-CONSTANT: AL_CHANNELS HEX: 2003
-CONSTANT: AL_SIZE HEX: 2004
-CONSTANT: AL_UNUSED HEX: 2010
-CONSTANT: AL_PENDING HEX: 2011
-CONSTANT: AL_PROCESSED HEX: 2012
-CONSTANT: AL_NO_ERROR AL_FALSE
-CONSTANT: AL_INVALID_NAME HEX: A001
-CONSTANT: AL_ILLEGAL_ENUM HEX: A002
-CONSTANT: AL_INVALID_ENUM HEX: A002
-CONSTANT: AL_INVALID_VALUE HEX: A003
-CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
-CONSTANT: AL_INVALID_OPERATION HEX: A004
-CONSTANT: AL_OUT_OF_MEMORY HEX: A005
-CONSTANT: AL_VENDOR HEX: B001
-CONSTANT: AL_VERSION HEX: B002
-CONSTANT: AL_RENDERER HEX: B003
-CONSTANT: AL_EXTENSIONS HEX: B004
-CONSTANT: AL_DOPPLER_FACTOR HEX: C000
-CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
-CONSTANT: AL_SPEED_OF_SOUND HEX: C003
-CONSTANT: AL_DISTANCE_MODEL HEX: D000
-CONSTANT: AL_INVERSE_DISTANCE HEX: D001
-CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
-CONSTANT: AL_LINEAR_DISTANCE HEX: D003
-CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
-CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
-CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
-
-FUNCTION: void alEnable ( ALenum capability ) ;
-FUNCTION: void alDisable ( ALenum capability ) ;
-FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
-FUNCTION: ALchar* alGetString ( ALenum param ) ;
-FUNCTION: void alGetBooleanv ( ALenum param, ALboolean* data ) ;
-FUNCTION: void alGetIntegerv ( ALenum param, ALint* data ) ;
-FUNCTION: void alGetFloatv ( ALenum param, ALfloat* data ) ;
-FUNCTION: void alGetDoublev ( ALenum param, ALdouble* data ) ;
-FUNCTION: ALboolean alGetBoolean ( ALenum param ) ;
-FUNCTION: ALint alGetInteger ( ALenum param ) ;
-FUNCTION: ALfloat alGetFloat ( ALenum param ) ;
-FUNCTION: ALdouble alGetDouble ( ALenum param ) ;
-FUNCTION: ALenum alGetError ( ) ;
-FUNCTION: ALboolean alIsExtensionPresent ( ALchar* extname ) ;
-FUNCTION: void* alGetProcAddress ( ALchar* fname ) ;
-FUNCTION: ALenum alGetEnumValue ( ALchar* ename ) ;
-FUNCTION: void alListenerf ( ALenum param, ALfloat value ) ;
-FUNCTION: void alListener3f ( ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
-FUNCTION: void alListeneri ( ALenum param, ALint value ) ;
-FUNCTION: void alListener3i ( ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alListeneriv ( ALenum param, ALint* values ) ;
-FUNCTION: void alGetListenerf ( ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetListener3f ( ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3 ) ;
-FUNCTION: void alGetListenerfv ( ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetListeneri ( ALenum param, ALint* value ) ;
-FUNCTION: void alGetListener3i ( ALenum param, ALint* value1, ALint* value2, ALint* value3 ) ;
-FUNCTION: void alGetListeneriv ( ALenum param, ALint* values ) ;
-FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
-FUNCTION: void alDeleteSources ( ALsizei n, ALuint* sources ) ;
-FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
-FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
-FUNCTION: void alSource3f ( ALuint sid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
-FUNCTION: void alSource3i ( ALuint sid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
-FUNCTION: void alGetSourcef ( ALuint sid, ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetSource3f ( ALuint sid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
-FUNCTION: void alGetSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetSourcei ( ALuint sid, ALenum param, ALint* value ) ;
-FUNCTION: void alGetSource3i ( ALuint sid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
-FUNCTION: void alGetSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
-FUNCTION: void alSourcePlayv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourceStopv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourceRewindv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourcePausev ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourcePlay ( ALuint sid ) ;
-FUNCTION: void alSourceStop ( ALuint sid ) ;
-FUNCTION: void alSourceRewind ( ALuint sid ) ;
-FUNCTION: void alSourcePause ( ALuint sid ) ;
-FUNCTION: void alSourceQueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
-FUNCTION: void alSourceUnqueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
-FUNCTION: void alGenBuffers ( ALsizei n, ALuint* buffers ) ;
-FUNCTION: void alDeleteBuffers ( ALsizei n, ALuint* buffers ) ;
-FUNCTION: ALboolean alIsBuffer ( ALuint bid ) ;
-FUNCTION: void alBufferData ( ALuint bid, ALenum format, void* data, ALsizei size, ALsizei freq ) ;
-FUNCTION: void alBufferf ( ALuint bid, ALenum param, ALfloat value ) ;
-FUNCTION: void alBuffer3f ( ALuint bid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alBufferi ( ALuint bid, ALenum param, ALint value ) ;
-FUNCTION: void alBuffer3i ( ALuint bid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
-FUNCTION: void alGetBufferf ( ALuint bid, ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetBuffer3f ( ALuint bid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
-FUNCTION: void alGetBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetBufferi ( ALuint bid, ALenum param, ALint* value ) ;
-FUNCTION: void alGetBuffer3i ( ALuint bid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
-FUNCTION: void alGetBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
-FUNCTION: void alDopplerFactor ( ALfloat value ) ;
-FUNCTION: void alDopplerVelocity ( ALfloat value ) ;
-FUNCTION: void alSpeedOfSound ( ALfloat value ) ;
-FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
-
-LIBRARY: alut
-
-CONSTANT: ALUT_API_MAJOR_VERSION 1
-CONSTANT: ALUT_API_MINOR_VERSION 1
-CONSTANT: ALUT_ERROR_NO_ERROR 0
-CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
-CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
-CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
-CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
-CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
-CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
-CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
-CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
-CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
-CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
-CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
-CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
-CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
-CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
-CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
-CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
-CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
-CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
-CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
-CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
-CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
-CONSTANT: ALUT_LOADER_BUFFER HEX: 300
-CONSTANT: ALUT_LOADER_MEMORY HEX: 301
-
-FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutExit ( ) ;
-FUNCTION: ALenum alutGetError ( ) ;
-FUNCTION: char* alutGetErrorString ( ALenum error ) ;
-FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
-FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
-FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
-FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
-FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
-FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
-FUNCTION: ALint alutGetMajorVersion ( ) ;
-FUNCTION: ALint alutGetMinorVersion ( ) ;
-FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
-
-FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
-
-SYMBOL: init
-
-: init-openal ( -- )
- init get-global expired? [
- f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
- 1337 <alien> init set-global
- ] when ;
-
-: exit-openal ( -- )
- init get-global expired? [
- alutExit 0 = [ "Could not close OpenAL" throw ] when
- f init set-global
- ] unless ;
-
-: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
-
-: gen-sources ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenSources swap ;
-
-: gen-buffers ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenBuffers swap ;
-
-: gen-buffer ( -- buffer ) 1 gen-buffers first ;
-
-: create-buffer-from-file ( filename -- buffer )
- alutCreateBufferFromFile dup AL_NONE = [
- "create-buffer-from-file failed" throw
- ] when ;
-
-os macosx? "openal.macosx" "openal.other" ? require
-
-: create-buffer-from-wav ( filename -- buffer )
- gen-buffer dup rot load-wav-file
- [ alBufferData ] 4keep alutUnloadWAV ;
-
-: queue-buffers ( source buffers -- )
- [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
-
-: queue-buffer ( source buffer -- )
- 1array queue-buffers ;
-
-: set-source-param ( source param value -- )
- alSourcei ;
-
-: get-source-param ( source param -- value )
- 0 <uint> dup [ alGetSourcei ] dip *uint ;
-
-: set-buffer-param ( source param value -- )
- alBufferi ;
-
-: get-buffer-param ( source param -- value )
- 0 <uint> dup [ alGetBufferi ] dip *uint ;
-
-: source-play ( source -- ) alSourcePlay ;
-
-: source-stop ( source -- ) alSourceStop ;
-
-: check-error ( -- )
- alGetError dup ALUT_ERROR_NO_ERROR = [
- drop
- ] [
- alGetString throw
- ] if ;
-
-: source-playing? ( source -- bool )
- AL_SOURCE_STATE get-source-param AL_PLAYING = ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: openal.backend alien.c-types kernel alien alien.syntax
-shuffle combinators.lib ;
-IN: openal.other
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
-
-M: object load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4keep
- >r >r >r *int r> *void* r> *int r> *int ;
+++ /dev/null
-OpenAL 3D audio library binding
+++ /dev/null
-bindings
-audio
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 ;
-IN: synth.buffers
-
-TUPLE: buffer sample-freq 8bit? id ;
-
-: <buffer> ( sample-freq 8bit? -- buffer )
- f buffer boa ;
-
-TUPLE: mono-buffer < buffer data ;
-
-: <mono-buffer> ( sample-freq 8bit? -- buffer )
- f f mono-buffer boa ;
-
-: <8bit-mono-buffer> ( sample-freq -- buffer ) t <mono-buffer> ;
-: <16bit-mono-buffer> ( sample-freq -- buffer ) f <mono-buffer> ;
-
-TUPLE: stereo-buffer < buffer left-data right-data ;
-
-: <stereo-buffer> ( sample-freq 8bit? -- buffer )
- f f f stereo-buffer boa ;
-
-: <8bit-stereo-buffer> ( sample-freq -- buffer ) t <stereo-buffer> ;
-: <16bit-stereo-buffer> ( sample-freq -- buffer ) f <stereo-buffer> ;
-
-PREDICATE: 8bit-buffer < buffer 8bit?>> ;
-PREDICATE: 16bit-buffer < buffer 8bit?>> not ;
-INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ;
-INTERSECTION: 16bit-mono-buffer 16bit-buffer mono-buffer ;
-INTERSECTION: 8bit-stereo-buffer 8bit-buffer stereo-buffer ;
-INTERSECTION: 16bit-stereo-buffer 16bit-buffer stereo-buffer ;
-
-GENERIC: buffer-format ( buffer -- format )
-M: 8bit-mono-buffer buffer-format drop AL_FORMAT_MONO8 ;
-M: 16bit-mono-buffer buffer-format drop AL_FORMAT_MONO16 ;
-M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ;
-M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ;
-
-: 8bit-buffer-data ( seq -- data size )
- [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ;
-
-: 16bit-buffer-data ( seq -- data size )
- [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ;
-
-: stereo-data ( stereo-buffer -- left right )
- [ left-data>> ] [ right-data>> ] bi@ ;
-
-: interleaved-stereo-data ( stereo-buffer -- data )
- stereo-data <2merged> ;
-
-GENERIC: buffer-data ( buffer -- data size )
-M: 8bit-mono-buffer buffer-data data>> 8bit-buffer-data ;
-M: 16bit-mono-buffer buffer-data data>> 16bit-buffer-data ;
-M: 8bit-stereo-buffer buffer-data
- interleaved-stereo-data 8bit-buffer-data ;
-M: 16bit-stereo-buffer buffer-data
- interleaved-stereo-data 16bit-buffer-data ;
-
-: telephone-sample-freq 8000 ;
-: half-sample-freq 22050 ;
-: cd-sample-freq 44100 ;
-: digital-sample-freq 48000 ;
-: professional-sample-freq 88200 ;
-
-: send-buffer ( buffer -- buffer )
- {
- [ gen-buffer dup [ >>id ] dip ]
- [ buffer-format ]
- [ buffer-data ]
- [ sample-freq>> alBufferData ]
- } cleave ;
-
-: ?send-buffer ( buffer -- buffer )
- dup id>> [ send-buffer ] unless ;
-
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel namespaces make openal sequences
-synth synth.buffers ;
-IN: synth.example
-
-: play-sine-wave ( freq seconds sample-freq -- )
- init-openal
- <16bit-mono-buffer> >sine-wave-buffer send-buffer id>>
- 1 gen-sources first
- [ AL_BUFFER rot set-source-param ] [ source-play ] bi
- check-error ;
-
-: test-instrument1 ( -- harmonics )
- [
- 1 0.5 <harmonic> ,
- 2 0.125 <harmonic> ,
- 3 0.0625 <harmonic> ,
- 4 0.03125 <harmonic> ,
- ] { } make ;
-
-: test-instrument2 ( -- harmonics )
- [
- 1 0.25 <harmonic> ,
- 2 0.25 <harmonic> ,
- 3 0.25 <harmonic> ,
- 4 0.25 <harmonic> ,
- ] { } make ;
-
-: sine-instrument ( -- harmonics )
- 1 1 <harmonic> 1array ;
-
-: test-note-buffer ( note -- )
- init-openal
- test-instrument2 swap cd-sample-freq <16bit-mono-buffer>
- >note send-buffer id>>
- 1 gen-sources first [ swap queue-buffer ] [ source-play ] bi
- check-error ;
+++ /dev/null
-Simple sound synthesis using OpenAL.
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
-IN: synth
-
-MEMO: single-sine-wave ( samples/wave -- seq )
- pi 2 * over / [ * sin ] curry map ;
-
-: (sine-wave) ( samples/wave n-samples -- seq )
- [ single-sine-wave ] dip <repeating> ;
-
-: sine-wave ( sample-freq freq seconds -- seq )
- pick * >integer [ /i ] dip (sine-wave) ;
-
-: >sine-wave-buffer ( freq seconds buffer -- buffer )
- [ sample-freq>> -rot sine-wave ] keep swap >>data ;
-
-: >silent-buffer ( seconds buffer -- buffer )
- tuck sample-freq>> * >integer 0 <repetition> >>data ;
-
-TUPLE: harmonic n amplitude ;
-C: <harmonic> harmonic
-
-TUPLE: note hz secs ;
-C: <note> note
-
-: harmonic-freq ( note harmonic -- freq )
- n>> swap hz>> * ;
-
-:: note-harmonic-data ( harmonic note buffer -- data )
- buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave
- harmonic amplitude>> <scaled> ;
-
-: >note ( harmonics note buffer -- buffer )
- dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
-
projects / factor.git / commitdiff