add openal.waves to generate tones, and code to play morse code

extra/morse/morse-docs.factor

@@ -23,3 +23,7 @@ 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" }

extra/morse/morse-tests.factor

@@ -9,3 +9,5 @@ USING: arrays morse strings tools.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!" 0.05 play-as-morse ] unit-test

extra/morse/morse.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables kernel lazy-lists namespaces openal
+USING: assocs combinators hashtables kernel lazy-lists math namespaces
-parser-combinators promises sequences strings unicode.case ;
+openal openal.waves parser-combinators promises sequences strings symbols
+unicode.case ;
 IN: morse
 
 <PRIVATE
@@ -85,25 +86,25 @@ PRIVATE>
 
 <PRIVATE
 
-: dot ( -- ch ) CHAR: . ;
+: dot-char ( -- ch ) CHAR: . ;
-: dash ( -- ch ) CHAR: - ;
+: dash-char ( -- ch ) CHAR: - ;
-: char-gap ( -- ch ) CHAR: \s ;
+: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap ( -- ch ) CHAR: / ;
+: word-gap-char ( -- ch ) CHAR: / ;
 
 : =parser ( obj -- parser )
     [ = ] curry satisfy ;
 
 LAZY: 'dot' ( -- parser )
-    dot =parser ;
+    dot-char =parser ;
 
 LAZY: 'dash' ( -- parser )
-    dash =parser ;
+    dash-char =parser ;
 
 LAZY: 'char-gap' ( -- parser )
-    char-gap =parser ;
+    char-gap-char =parser ;
 
 LAZY: 'word-gap' ( -- parser )
-    word-gap =parser ;
+    word-gap-char =parser ;
 
 LAZY: 'morse-char' ( -- parser )
     'dot' 'dash' <|> <+> ;
@@ -123,3 +124,51 @@ PRIVATE>
         ] 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 ;
+
+: sine-buffer ( seconds -- id )
+    >r 8 22000 880 r> <sine-wave-buffer> send-buffer* ;
+
+: silent-buffer ( seconds -- id )
+    8 22000 rot <silent-buffer> send-buffer* ;
+
+: 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 ;
+

extra/openal/openal.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien system combinators alien.syntax namespaces
+USING: kernel arrays alien system combinators alien.syntax namespaces
        alien.c-types sequences vocabs.loader shuffle combinators.lib
        openal.backend ;
 IN: openal
@@ -266,6 +266,12 @@ os macosx? "openal.macosx" "openal.other" ? require
   gen-buffer dup rot load-wav-file
   [ alBufferData ] 4keep alutUnloadWAV ;
 
+: queue-buffers ( source buffers -- )
+    [ length ] [ >c-uint-array ] bi alSourceQueueBuffers ;
+
+: queue-buffer ( source buffer -- )
+    1array queue-buffers ;
+
 : set-source-param ( source param value -- )
   alSourcei ;
 

extra/openal/waves/waves-tests.factor

@@ -0,0 +1,5 @@
+USING: kernel openal openal.waves sequences tools.test ;
+IN: openal.waves.tests
+
+
+[ ] [ 8 22000 440 1 play-sine-wave ] unit-test

extra/openal/waves/waves.factor

@@ -0,0 +1,53 @@
+USING: accessors alien.c-types combinators kernel locals math
+math.constants math.functions math.ranges openal sequences ;
+IN: openal.waves
+
+TUPLE: buffer bits channels sample-freq seq id ;
+
+: <buffer> ( bits sample-freq seq -- buffer )
+    ! defaults to 1 channel
+    1 -rot gen-buffer buffer boa ;
+
+: buffer-format ( buffer -- format )
+    dup buffer-channels 1 = swap buffer-bits 8 = [
+        AL_FORMAT_MONO8 AL_FORMAT_STEREO8
+    ] [
+        AL_FORMAT_MONO16 AL_FORMAT_STEREO16
+    ] if ? ;
+
+: buffer-data ( buffer -- data size )
+    #! 8 bit data is integers between 0 and 255,
+    #! 16 bit data is integers between -32768 and 32768
+    #! size is in bytes
+    [ seq>> ] [ bits>> ] bi 8 = [
+        [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi
+    ] [
+        [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi
+    ] if ;
+
+: send-buffer ( buffer -- )
+    { [ id>> ] [ buffer-format ] [ buffer-data ] [ sample-freq>> ] } cleave
+    alBufferData ;
+
+: send-buffer* ( buffer -- id )
+    [ send-buffer ] [ id>> ] bi ;
+
+: (sine-wave-seq) ( samples/wave n-samples -- seq )
+    pi 2 * rot / [ * sin ] curry map ;
+
+: sine-wave-seq ( sample-freq freq seconds -- seq )
+    pick * >integer [ / ] dip (sine-wave-seq) ;
+
+: <sine-wave-buffer> ( bits sample-freq freq seconds -- buffer )
+    >r dupd r> sine-wave-seq <buffer> ;
+
+: <silent-buffer> ( bits sample-freq seconds -- buffer )
+    dupd * >integer [ drop 0 ] map <buffer> ;
+
+: play-sine-wave ( bits sample-freq freq seconds -- )
+    init-openal
+    <sine-wave-buffer> send-buffer*
+    1 gen-sources first
+    [ AL_BUFFER rot set-source-param ] [ source-play ] bi
+    check-error ;
+