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 ;
8 CONSTANT: dot-char CHAR: .
9 CONSTANT: dash-char CHAR: -
10 CONSTANT: char-gap-char CHAR: \s
11 CONSTANT: word-gap-char CHAR: /
12 CONSTANT: unknown-char CHAR: ?
16 CONSTANT: morse-code-table $[
76 : ch>morse ( ch -- morse )
77 ch>lower morse-code-table at [ unknown-char ] unless* ;
79 : morse>ch ( str -- ch )
80 morse-code-table value-at [ char-gap-char ] unless* ;
84 : word>morse ( str -- morse )
85 [ ch>morse ] { } map-as " " join ;
87 : sentence>morse ( str -- morse )
88 " " split [ word>morse ] map " / " join ;
90 : trim-blanks ( str -- newstr )
91 [ blank? ] trim ; inline
93 : morse>word ( morse -- str )
94 " " split [ morse>ch ] "" map-as ;
96 : morse>sentence ( morse -- sentence )
97 "/" split [ trim-blanks morse>word ] map " " join ;
99 : replace-underscores ( str -- str' )
100 [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
104 : >morse ( str -- newstr )
105 trim-blanks sentence>morse ;
107 : morse> ( morse -- plain )
108 replace-underscores morse>sentence ;
110 SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
114 SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
116 : queue ( symbol -- )
117 get source get swap queue-buffer ;
119 : dot ( -- ) dot-buffer queue ;
120 : dash ( -- ) dash-buffer queue ;
121 : intra-char-gap ( -- ) intra-char-gap-buffer queue ;
122 : letter-gap ( -- ) letter-gap-buffer queue ;
124 CONSTANT: beep-freq 880
126 : <morse-buffer> ( -- buffer )
127 half-sample-freq <8bit-mono-buffer> ;
129 : sine-buffer ( seconds -- id )
130 beep-freq swap <morse-buffer> >sine-wave-buffer
133 : silent-buffer ( seconds -- id )
134 <morse-buffer> >silent-buffer send-buffer id>> ;
136 : make-buffers ( unit-length -- )
138 [ sine-buffer dot-buffer set ]
139 [ 3 * sine-buffer dash-buffer set ]
140 [ silent-buffer intra-char-gap-buffer set ]
141 [ 3 * silent-buffer letter-gap-buffer set ]
144 : playing-morse ( quot unit-length -- )
146 init-openal 1 gen-sources first source set make-buffers
148 source get source-play
149 ] with-scope ; inline
151 : play-char ( ch -- )
155 { dash-char [ dash ] }
156 { word-gap-char [ intra-char-gap ] }
162 : play-as-morse* ( str unit-length -- )
164 [ letter-gap ] [ ch>morse play-char ] interleave
165 ] swap playing-morse ; inline
167 : play-as-morse ( str -- )
168 0.05 play-as-morse* ; inline