1 ! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors ascii assocs biassocs combinators kernel
4 literals math multiline namespaces openal openal.alut sequences
5 splitting strings synth synth.buffers ;
8 ERROR: no-morse-ch ch ;
12 CONSTANT: dot-char CHAR: .
13 CONSTANT: dash-char CHAR: -
14 CONSTANT: char-gap-char CHAR: \s
15 CONSTANT: word-gap-char CHAR: /
16 CONSTANT: unknown-char CHAR: ?
20 CONSTANT: morse-code-table $[
80 : ch>morse ( ch -- morse )
81 ch>lower morse-code-table at unknown-char 1string or ;
83 : morse>ch ( str -- ch )
84 morse-code-table value-at char-gap-char or ;
88 : word>morse ( str -- morse )
89 [ ch>morse ] { } map-as join-words ;
91 : sentence>morse ( str -- morse )
92 split-words [ word>morse ] map " / " join ;
94 : trim-blanks ( str -- newstr )
95 [ blank? ] trim ; inline
97 : morse>word ( morse -- str )
98 split-words [ morse>ch ] "" map-as ;
100 : morse>sentence ( morse -- sentence )
101 "/" split [ trim-blanks morse>word ] map join-words ;
103 : replace-underscores ( str -- str' )
104 [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
108 : >morse ( str -- newstr )
109 trim-blanks sentence>morse ;
111 : morse> ( morse -- plain )
112 replace-underscores morse>sentence ;
114 SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> suffix! ;
118 SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
120 : queue ( symbol -- )
121 get source get swap queue-buffer ;
123 : dot ( -- ) dot-buffer queue ;
124 : dash ( -- ) dash-buffer queue ;
125 : intra-char-gap ( -- ) intra-char-gap-buffer queue ;
126 : letter-gap ( -- ) letter-gap-buffer queue ;
128 CONSTANT: beep-freq 880
130 : <morse-buffer> ( -- buffer )
131 half-sample-freq <8-bit-mono-buffer> ;
133 : sine-buffer ( seconds -- id )
134 beep-freq swap <morse-buffer> >sine-wave-buffer
137 : silent-buffer ( seconds -- id )
138 <morse-buffer> >silent-buffer send-buffer id>> ;
140 : make-buffers ( unit-length -- )
142 [ sine-buffer dot-buffer set ]
143 [ 3 * sine-buffer dash-buffer set ]
144 [ silent-buffer intra-char-gap-buffer set ]
145 [ 3 * silent-buffer letter-gap-buffer set ]
148 : playing-morse ( quot unit-length -- )
150 init-openal 1 gen-sources first source set make-buffers
152 source get source-play
153 ] with-scope ; inline
155 : play-char ( string -- )
159 { dash-char [ dash ] }
160 { word-gap-char [ intra-char-gap ] }
161 { unknown-char [ intra-char-gap ] }
168 : play-as-morse* ( str unit-length -- )
170 [ letter-gap ] [ ch>morse play-char ] interleave
171 ] swap playing-morse ; inline
173 : play-as-morse ( str -- )
174 0.05 play-as-morse* ; inline