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 hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
6 ERROR: no-morse-ch ch ;
10 CONSTANT: dot-char CHAR: .
11 CONSTANT: dash-char CHAR: -
12 CONSTANT: char-gap-char CHAR: \s
13 CONSTANT: word-gap-char CHAR: /
14 CONSTANT: unknown-char CHAR: ?
18 CONSTANT: morse-code-table $[
78 : ch>morse ( ch -- morse )
79 ch>lower morse-code-table at unknown-char 1string or ;
81 : morse>ch ( str -- ch )
82 morse-code-table value-at char-gap-char or ;
86 : word>morse ( str -- morse )
87 [ ch>morse ] { } map-as " " join ;
89 : sentence>morse ( str -- morse )
90 " " split [ word>morse ] map " / " join ;
92 : trim-blanks ( str -- newstr )
93 [ blank? ] trim ; inline
95 : morse>word ( morse -- str )
96 " " split [ morse>ch ] "" map-as ;
98 : morse>sentence ( morse -- sentence )
99 "/" split [ trim-blanks morse>word ] map " " join ;
101 : replace-underscores ( str -- str' )
102 [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
106 : >morse ( str -- newstr )
107 trim-blanks sentence>morse ;
109 : morse> ( morse -- plain )
110 replace-underscores morse>sentence ;
112 SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> suffix! ;
116 SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
118 : queue ( symbol -- )
119 get source get swap queue-buffer ;
121 : dot ( -- ) dot-buffer queue ;
122 : dash ( -- ) dash-buffer queue ;
123 : intra-char-gap ( -- ) intra-char-gap-buffer queue ;
124 : letter-gap ( -- ) letter-gap-buffer queue ;
126 CONSTANT: beep-freq 880
128 : <morse-buffer> ( -- buffer )
129 half-sample-freq <8bit-mono-buffer> ;
131 : sine-buffer ( seconds -- id )
132 beep-freq swap <morse-buffer> >sine-wave-buffer
135 : silent-buffer ( seconds -- id )
136 <morse-buffer> >silent-buffer send-buffer id>> ;
138 : make-buffers ( unit-length -- )
140 [ sine-buffer dot-buffer set ]
141 [ 3 * sine-buffer dash-buffer set ]
142 [ silent-buffer intra-char-gap-buffer set ]
143 [ 3 * silent-buffer letter-gap-buffer set ]
146 : playing-morse ( quot unit-length -- )
148 init-openal 1 gen-sources first source set make-buffers
150 source get source-play
151 ] with-scope ; inline
153 : play-char ( string -- )
157 { dash-char [ dash ] }
158 { word-gap-char [ intra-char-gap ] }
159 { unknown-char [ intra-char-gap ] }
166 : play-as-morse* ( str unit-length -- )
168 [ letter-gap ] [ ch>morse play-char ] interleave
169 ] swap playing-morse ; inline
171 : play-as-morse ( str -- )
172 0.05 play-as-morse* ; inline