-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lists math
-namespaces make openal parser-combinators promises sequences
-strings symbols synth synth.buffers unicode.case ;
+! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors ascii assocs biassocs combinators kernel
+literals math multiline namespaces openal openal.alut sequences
+splitting strings synth synth.buffers ;
IN: morse
+ERROR: no-morse-ch ch ;
+
<PRIVATE
-: morse-codes ( -- array )
- {
+
+CONSTANT: dot-char CHAR: .
+CONSTANT: dash-char CHAR: -
+CONSTANT: char-gap-char CHAR: \s
+CONSTANT: word-gap-char CHAR: /
+CONSTANT: unknown-char CHAR: ?
+
+PRIVATE>
+
+CONSTANT: morse-code-table $[
+ H{
{ CHAR: a ".-" }
{ CHAR: b "-..." }
{ CHAR: c "-.-." }
{ CHAR: + ".-.-." }
{ CHAR: - "-....-" }
{ CHAR: _ "..--.-" }
- { CHAR: " ".-..-." }
+ { CHAR: \" ".-..-." }
{ CHAR: $ "...-..-" }
{ CHAR: @ ".--.-." }
{ CHAR: \s "/" }
- } ;
-
-: ch>morse-assoc ( -- assoc )
- morse-codes >hashtable ;
-
-: morse>ch-assoc ( -- assoc )
- morse-codes [ reverse ] map >hashtable ;
+ } >biassoc
+]
-PRIVATE>
-
-: ch>morse ( ch -- str )
- ch>lower ch>morse-assoc at* swap "" ? ;
+: ch>morse ( ch -- morse )
+ ch>lower morse-code-table at unknown-char 1string or ;
: morse>ch ( str -- ch )
- morse>ch-assoc at* swap f ? ;
-
-: >morse ( str -- str )
- [
- [ CHAR: \s , ] [ ch>morse % ] interleave
- ] "" make ;
+ morse-code-table value-at char-gap-char or ;
<PRIVATE
-: dot-char ( -- ch ) CHAR: . ;
-: dash-char ( -- ch ) CHAR: - ;
-: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap-char ( -- ch ) CHAR: / ;
+: word>morse ( str -- morse )
+ [ ch>morse ] { } map-as join-words ;
-: =parser ( obj -- parser )
- [ = ] curry satisfy ;
+: sentence>morse ( str -- morse )
+ split-words [ word>morse ] map " / " join ;
-LAZY: 'dot' ( -- parser )
- dot-char =parser ;
+: trim-blanks ( str -- newstr )
+ [ blank? ] trim ; inline
-LAZY: 'dash' ( -- parser )
- dash-char =parser ;
+: morse>word ( morse -- str )
+ split-words [ morse>ch ] "" map-as ;
-LAZY: 'char-gap' ( -- parser )
- char-gap-char =parser ;
+: morse>sentence ( morse -- sentence )
+ "/" split [ trim-blanks morse>word ] map join-words ;
-LAZY: 'word-gap' ( -- parser )
- word-gap-char =parser ;
+: replace-underscores ( str -- str' )
+ [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
-LAZY: 'morse-char' ( -- parser )
- 'dot' 'dash' <|> <+> ;
-
-LAZY: 'morse-word' ( -- parser )
- 'morse-char' 'char-gap' list-of ;
+PRIVATE>
-LAZY: 'morse-words' ( -- parser )
- 'morse-word' 'word-gap' list-of ;
+: >morse ( str -- newstr )
+ trim-blanks sentence>morse ;
-PRIVATE>
+: morse> ( morse -- plain )
+ replace-underscores morse>sentence ;
-: morse> ( str -- str )
- 'morse-words' parse car parsed>> [
- [
- >string morse>ch
- ] map >string
- ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> suffix! ;
<PRIVATE
+
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
: queue ( symbol -- )
: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
: letter-gap ( -- ) letter-gap-buffer queue ;
-: beep-freq 880 ;
+CONSTANT: beep-freq 880
: <morse-buffer> ( -- buffer )
- half-sample-freq <8bit-mono-buffer> ;
+ half-sample-freq <8-bit-mono-buffer> ;
: sine-buffer ( seconds -- id )
beep-freq swap <morse-buffer> >sine-wave-buffer
init-openal 1 gen-sources first source set make-buffers
call
source get source-play
- ] with-scope ;
+ ] with-scope ; inline
-: play-char ( ch -- )
+: play-char ( string -- )
[ intra-char-gap ] [
{
{ dot-char [ dot ] }
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
+ { unknown-char [ intra-char-gap ] }
+ [ no-morse-ch ]
} case
] interleave ;
: play-as-morse* ( str unit-length -- )
[
[ letter-gap ] [ ch>morse play-char ] interleave
- ] swap playing-morse ;
+ ] swap playing-morse ; inline
: play-as-morse ( str -- )
- 0.05 play-as-morse* ;
+ 0.05 play-as-morse* ; inline