1 ! Copyright (C) 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
7 : morse-codes ( -- array )
66 : ch>morse-assoc ( -- assoc )
67 morse-codes >hashtable ;
69 : morse>ch-assoc ( -- assoc )
70 morse-codes [ reverse ] map >hashtable ;
74 : ch>morse ( ch -- str )
75 ch>lower ch>morse-assoc at* swap "" ? ;
77 : morse>ch ( str -- ch )
78 morse>ch-assoc at* swap f ? ;
80 : >morse ( str -- str )
82 [ CHAR: \s , ] [ ch>morse % ] interleave
87 : dot-char ( -- ch ) CHAR: . ;
88 : dash-char ( -- ch ) CHAR: - ;
89 : char-gap-char ( -- ch ) CHAR: \s ;
90 : word-gap-char ( -- ch ) CHAR: / ;
92 : =parser ( obj -- parser )
95 LAZY: 'dot' ( -- parser )
98 LAZY: 'dash' ( -- parser )
101 LAZY: 'char-gap' ( -- parser )
102 char-gap-char =parser ;
104 LAZY: 'word-gap' ( -- parser )
105 word-gap-char =parser ;
107 LAZY: 'morse-char' ( -- parser )
108 'dot' 'dash' <|> <+> ;
110 LAZY: 'morse-word' ( -- parser )
111 'morse-char' 'char-gap' list-of ;
113 LAZY: 'morse-words' ( -- parser )
114 'morse-word' 'word-gap' list-of ;
118 : morse> ( str -- str )
119 'morse-words' parse car parsed>> [
123 ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
126 SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
128 : queue ( symbol -- )
129 get source get swap queue-buffer ;
131 : dot ( -- ) dot-buffer queue ;
132 : dash ( -- ) dash-buffer queue ;
133 : intra-char-gap ( -- ) intra-char-gap-buffer queue ;
134 : letter-gap ( -- ) letter-gap-buffer queue ;
138 : <morse-buffer> ( -- buffer )
139 half-sample-freq <8bit-mono-buffer> ;
141 : sine-buffer ( seconds -- id )
142 beep-freq swap <morse-buffer> >sine-wave-buffer
145 : silent-buffer ( seconds -- id )
146 <morse-buffer> >silent-buffer send-buffer id>> ;
148 : make-buffers ( unit-length -- )
150 [ sine-buffer dot-buffer set ]
151 [ 3 * sine-buffer dash-buffer set ]
152 [ silent-buffer intra-char-gap-buffer set ]
153 [ 3 * silent-buffer letter-gap-buffer set ]
156 : playing-morse ( quot unit-length -- )
158 init-openal 1 gen-sources first source set make-buffers
160 source get source-play
163 : play-char ( ch -- )
167 { dash-char [ dash ] }
168 { word-gap-char [ intra-char-gap ] }
174 : play-as-morse* ( str unit-length -- )
176 [ letter-gap ] [ ch>morse play-char ] interleave
177 ] swap playing-morse ;
179 : play-as-morse ( str -- )
180 0.05 play-as-morse* ;