add openal.waves to generate tones, and code to play morse code
Alex Chapman
parent
2f48f21eaf
commit
bd548d5423
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
parser-combinators promises sequences strings unicode.case ;
|
||||
USING: assocs combinators hashtables kernel lazy-lists math namespaces
|
||||
openal openal.waves parser-combinators promises sequences strings symbols
|
||||
unicode.case ;
|
||||
IN: morse
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -85,25 +86,25 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: dot ( -- ch ) CHAR: . ;
|
||||
: dash ( -- ch ) CHAR: - ;
|
||||
: char-gap ( -- ch ) CHAR: \s ;
|
||||
: word-gap ( -- ch ) CHAR: / ;
|
||||
: 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 =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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
Loading…
Reference in New Issue