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
4 kernel lists literals math namespaces make multiline openal
5 openal.alut parser sequences splitting strings synth
9 ERROR: no-morse-ch ch ;
13 CONSTANT: dot-char CHAR: .
14 CONSTANT: dash-char CHAR: -
15 CONSTANT: char-gap-char CHAR: \s
16 CONSTANT: word-gap-char CHAR: /
17 CONSTANT: unknown-char CHAR: ?
21 CONSTANT: morse-code-table $[
81 : ch>morse ( ch -- morse )
82 ch>lower morse-code-table at unknown-char 1string or ;
84 : morse>ch ( str -- ch )
85 morse-code-table value-at char-gap-char or ;
89 : word>morse ( str -- morse )
90 [ ch>morse ] { } map-as " " join ;
92 : sentence>morse ( str -- morse )
93 " " split [ word>morse ] map " / " join ;
95 : trim-blanks ( str -- newstr )
96 [ blank? ] trim ; inline
98 : morse>word ( morse -- str )
99 " " split [ morse>ch ] "" map-as ;
101 : morse>sentence ( morse -- sentence )
102 "/" split [ trim-blanks morse>word ] map " " join ;
104 : replace-underscores ( str -- str' )
105 [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
109 : >morse ( str -- newstr )
110 trim-blanks sentence>morse ;
112 : morse> ( morse -- plain )
113 replace-underscores morse>sentence ;
115 SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> suffix! ;
119 SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
121 : queue ( symbol -- )
122 get source get swap queue-buffer ;
124 : dot ( -- ) dot-buffer queue ;
125 : dash ( -- ) dash-buffer queue ;
126 : intra-char-gap ( -- ) intra-char-gap-buffer queue ;
127 : letter-gap ( -- ) letter-gap-buffer queue ;
129 CONSTANT: beep-freq 880
131 : <morse-buffer> ( -- buffer )
132 half-sample-freq <8bit-mono-buffer> ;
134 : sine-buffer ( seconds -- id )
135 beep-freq swap <morse-buffer> >sine-wave-buffer
138 : silent-buffer ( seconds -- id )
139 <morse-buffer> >silent-buffer send-buffer id>> ;
141 : make-buffers ( unit-length -- )
143 [ sine-buffer dot-buffer set ]
144 [ 3 * sine-buffer dash-buffer set ]
145 [ silent-buffer intra-char-gap-buffer set ]
146 [ 3 * silent-buffer letter-gap-buffer set ]
149 : playing-morse ( quot unit-length -- )
151 init-openal 1 gen-sources first source set make-buffers
153 source get source-play
154 ] with-scope ; inline
156 : play-char ( string -- )
160 { dash-char [ dash ] }
161 { word-gap-char [ intra-char-gap ] }
162 { unknown-char [ intra-char-gap ] }
163 [ throw-no-morse-ch ]
169 : play-as-morse* ( str unit-length -- )
171 [ letter-gap ] [ ch>morse play-char ] interleave
172 ] swap playing-morse ; inline
174 : play-as-morse ( str -- )
175 0.05 play-as-morse* ; inline