Merging Diego Martinelli's improvements and simplifications of morse
Alex Chapman
parent
c2a35ecf33
commit
0f82f4af87
|
|
@ -1 +1,2 @@
|
||||||
Alex Chapman
|
Alex Chapman
|
||||||
|
Diego Martinelli
|
||||||
|
|
|
||||||
|
|
@ -6,12 +6,12 @@ IN: morse
|
||||||
HELP: ch>morse
|
HELP: ch>morse
|
||||||
{ $values
|
{ $values
|
||||||
{ "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
|
{ "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
|
||||||
{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
|
{ $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ;
|
||||||
|
|
||||||
HELP: morse>ch
|
HELP: morse>ch
|
||||||
{ $values
|
{ $values
|
||||||
{ "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
|
{ "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
|
||||||
{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
|
{ $description "If the given string represents a morse code character, then return that character, otherwise return a space character." } ;
|
||||||
|
|
||||||
HELP: >morse
|
HELP: >morse
|
||||||
{ $values
|
{ $values
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,43 @@
|
||||||
! Copyright (C) 2007 Alex Chapman
|
! Copyright (C) 2007 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays morse strings tools.test ;
|
USING: arrays morse strings tools.test ;
|
||||||
|
IN: morse.tests
|
||||||
|
|
||||||
[ "" ] [ CHAR: \\ ch>morse ] unit-test
|
[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
|
||||||
[ "..." ] [ CHAR: s ch>morse ] unit-test
|
[ "..." ] [ CHAR: s ch>morse ] unit-test
|
||||||
[ CHAR: s ] [ "..." morse>ch ] unit-test
|
[ CHAR: s ] [ "..." morse>ch ] unit-test
|
||||||
[ f ] [ "..--..--.." morse>ch ] unit-test
|
[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
|
||||||
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
|
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
|
||||||
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
|
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
|
||||||
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
|
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
|
||||||
|
[ ".- -... -.-." ] [ "abc" >morse ] unit-test
|
||||||
|
|
||||||
|
[ "abc" ] [ ".- -... -.-." morse> ] unit-test
|
||||||
|
|
||||||
|
[ "morse code" ] [
|
||||||
|
[MORSE
|
||||||
|
-- --- .-. ... . /
|
||||||
|
-.-. --- -.. .
|
||||||
|
MORSE] >morse morse> ] unit-test
|
||||||
|
|
||||||
|
[ "morse code 123" ] [
|
||||||
|
[MORSE
|
||||||
|
__ ___ ._. ... . /
|
||||||
|
_._. ___ _.. . /
|
||||||
|
.____ ..___ ...__
|
||||||
|
MORSE] ] unit-test
|
||||||
|
|
||||||
|
[ [MORSE
|
||||||
|
-- --- .-. ... . /
|
||||||
|
-.-. --- -.. .
|
||||||
|
MORSE] ] [
|
||||||
|
"morse code" >morse morse>
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ "factor rocks!" ] [
|
||||||
|
[MORSE
|
||||||
|
..-. .- -.-. - --- .-. /
|
||||||
|
.-. --- -.-. -.- ... -.-.--
|
||||||
|
MORSE] ] unit-test
|
||||||
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
|
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
|
||||||
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
|
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,130 +1,120 @@
|
||||||
! Copyright (C) 2007, 2008 Alex Chapman
|
! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors ascii assocs combinators hashtables kernel lists math
|
USING: accessors ascii assocs biassocs combinators hashtables kernel lists math
|
||||||
namespaces make openal parser-combinators promises sequences
|
namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
|
||||||
strings synth synth.buffers unicode.case ;
|
|
||||||
IN: morse
|
IN: morse
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
: morse-codes ( -- array )
|
|
||||||
{
|
|
||||||
{ CHAR: a ".-" }
|
|
||||||
{ CHAR: b "-..." }
|
|
||||||
{ CHAR: c "-.-." }
|
|
||||||
{ CHAR: d "-.." }
|
|
||||||
{ CHAR: e "." }
|
|
||||||
{ CHAR: f "..-." }
|
|
||||||
{ CHAR: g "--." }
|
|
||||||
{ CHAR: h "...." }
|
|
||||||
{ CHAR: i ".." }
|
|
||||||
{ CHAR: j ".---" }
|
|
||||||
{ CHAR: k "-.-" }
|
|
||||||
{ CHAR: l ".-.." }
|
|
||||||
{ CHAR: m "--" }
|
|
||||||
{ CHAR: n "-." }
|
|
||||||
{ CHAR: o "---" }
|
|
||||||
{ CHAR: p ".--." }
|
|
||||||
{ CHAR: q "--.-" }
|
|
||||||
{ CHAR: r ".-." }
|
|
||||||
{ CHAR: s "..." }
|
|
||||||
{ CHAR: t "-" }
|
|
||||||
{ CHAR: u "..-" }
|
|
||||||
{ CHAR: v "...-" }
|
|
||||||
{ CHAR: w ".--" }
|
|
||||||
{ CHAR: x "-..-" }
|
|
||||||
{ CHAR: y "-.--" }
|
|
||||||
{ CHAR: z "--.." }
|
|
||||||
{ CHAR: 1 ".----" }
|
|
||||||
{ CHAR: 2 "..---" }
|
|
||||||
{ CHAR: 3 "...--" }
|
|
||||||
{ CHAR: 4 "....-" }
|
|
||||||
{ CHAR: 5 "....." }
|
|
||||||
{ CHAR: 6 "-...." }
|
|
||||||
{ CHAR: 7 "--..." }
|
|
||||||
{ CHAR: 8 "---.." }
|
|
||||||
{ CHAR: 9 "----." }
|
|
||||||
{ CHAR: 0 "-----" }
|
|
||||||
{ CHAR: . ".-.-.-" }
|
|
||||||
{ CHAR: , "--..--" }
|
|
||||||
{ CHAR: ? "..--.." }
|
|
||||||
{ CHAR: ' ".----." }
|
|
||||||
{ CHAR: ! "-.-.--" }
|
|
||||||
{ CHAR: / "-..-." }
|
|
||||||
{ CHAR: ( "-.--." }
|
|
||||||
{ CHAR: ) "-.--.-" }
|
|
||||||
{ CHAR: & ".-..." }
|
|
||||||
{ CHAR: : "---..." }
|
|
||||||
{ CHAR: ; "-.-.-." }
|
|
||||||
{ CHAR: = "-...- " }
|
|
||||||
{ CHAR: + ".-.-." }
|
|
||||||
{ CHAR: - "-....-" }
|
|
||||||
{ CHAR: _ "..--.-" }
|
|
||||||
{ CHAR: " ".-..-." }
|
|
||||||
{ CHAR: $ "...-..-" }
|
|
||||||
{ CHAR: @ ".--.-." }
|
|
||||||
{ CHAR: \s "/" }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
: ch>morse-assoc ( -- assoc )
|
CONSTANT: dot-char CHAR: .
|
||||||
morse-codes >hashtable ;
|
CONSTANT: dash-char CHAR: -
|
||||||
|
CONSTANT: char-gap-char CHAR: \s
|
||||||
: morse>ch-assoc ( -- assoc )
|
CONSTANT: word-gap-char CHAR: /
|
||||||
morse-codes [ reverse ] map >hashtable ;
|
CONSTANT: unknown-char CHAR: ?
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: ch>morse ( ch -- str )
|
DEFER: morse-code-table
|
||||||
ch>lower ch>morse-assoc at* swap "" ? ;
|
|
||||||
|
H{
|
||||||
|
{ CHAR: a ".-" }
|
||||||
|
{ CHAR: b "-..." }
|
||||||
|
{ CHAR: c "-.-." }
|
||||||
|
{ CHAR: d "-.." }
|
||||||
|
{ CHAR: e "." }
|
||||||
|
{ CHAR: f "..-." }
|
||||||
|
{ CHAR: g "--." }
|
||||||
|
{ CHAR: h "...." }
|
||||||
|
{ CHAR: i ".." }
|
||||||
|
{ CHAR: j ".---" }
|
||||||
|
{ CHAR: k "-.-" }
|
||||||
|
{ CHAR: l ".-.." }
|
||||||
|
{ CHAR: m "--" }
|
||||||
|
{ CHAR: n "-." }
|
||||||
|
{ CHAR: o "---" }
|
||||||
|
{ CHAR: p ".--." }
|
||||||
|
{ CHAR: q "--.-" }
|
||||||
|
{ CHAR: r ".-." }
|
||||||
|
{ CHAR: s "..." }
|
||||||
|
{ CHAR: t "-" }
|
||||||
|
{ CHAR: u "..-" }
|
||||||
|
{ CHAR: v "...-" }
|
||||||
|
{ CHAR: w ".--" }
|
||||||
|
{ CHAR: x "-..-" }
|
||||||
|
{ CHAR: y "-.--" }
|
||||||
|
{ CHAR: z "--.." }
|
||||||
|
{ CHAR: 1 ".----" }
|
||||||
|
{ CHAR: 2 "..---" }
|
||||||
|
{ CHAR: 3 "...--" }
|
||||||
|
{ CHAR: 4 "....-" }
|
||||||
|
{ CHAR: 5 "....." }
|
||||||
|
{ CHAR: 6 "-...." }
|
||||||
|
{ CHAR: 7 "--..." }
|
||||||
|
{ CHAR: 8 "---.." }
|
||||||
|
{ CHAR: 9 "----." }
|
||||||
|
{ CHAR: 0 "-----" }
|
||||||
|
{ CHAR: . ".-.-.-" }
|
||||||
|
{ CHAR: , "--..--" }
|
||||||
|
{ CHAR: ? "..--.." }
|
||||||
|
{ CHAR: ' ".----." }
|
||||||
|
{ CHAR: ! "-.-.--" }
|
||||||
|
{ CHAR: / "-..-." }
|
||||||
|
{ CHAR: ( "-.--." }
|
||||||
|
{ CHAR: ) "-.--.-" }
|
||||||
|
{ CHAR: & ".-..." }
|
||||||
|
{ CHAR: : "---..." }
|
||||||
|
{ CHAR: ; "-.-.-." }
|
||||||
|
{ CHAR: = "-...- " }
|
||||||
|
{ CHAR: + ".-.-." }
|
||||||
|
{ CHAR: - "-....-" }
|
||||||
|
{ CHAR: _ "..--.-" }
|
||||||
|
{ CHAR: " ".-..-." }
|
||||||
|
{ CHAR: $ "...-..-" }
|
||||||
|
{ CHAR: @ ".--.-." }
|
||||||
|
{ CHAR: \s "/" }
|
||||||
|
} >biassoc \ morse-code-table set-global
|
||||||
|
|
||||||
|
: morse-code-table ( -- biassoc )
|
||||||
|
\ morse-code-table get-global ;
|
||||||
|
|
||||||
|
: ch>morse ( ch -- morse )
|
||||||
|
ch>lower morse-code-table at [ unknown-char ] unless* ;
|
||||||
|
|
||||||
: morse>ch ( str -- ch )
|
: morse>ch ( str -- ch )
|
||||||
morse>ch-assoc at* swap f ? ;
|
morse-code-table value-at [ char-gap-char ] unless* ;
|
||||||
|
|
||||||
: >morse ( str -- str )
|
|
||||||
[
|
|
||||||
[ CHAR: \s , ] [ ch>morse % ] interleave
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
: word>morse ( str -- morse )
|
||||||
|
[ ch>morse ] { } map-as " " join ;
|
||||||
|
|
||||||
: dot-char ( -- ch ) CHAR: . ;
|
: sentence>morse ( str -- morse )
|
||||||
: dash-char ( -- ch ) CHAR: - ;
|
" " split [ word>morse ] map " / " join ;
|
||||||
: char-gap-char ( -- ch ) CHAR: \s ;
|
|
||||||
: word-gap-char ( -- ch ) CHAR: / ;
|
: trim-blanks ( str -- newstr )
|
||||||
|
[ blank? ] trim ; inline
|
||||||
|
|
||||||
: =parser ( obj -- parser )
|
: morse>word ( morse -- str )
|
||||||
[ = ] curry satisfy ;
|
" " split [ morse>ch ] "" map-as ;
|
||||||
|
|
||||||
LAZY: 'dot' ( -- parser )
|
: morse>sentence ( morse -- sentence )
|
||||||
dot-char =parser ;
|
"/" split [ trim-blanks morse>word ] map " " join ;
|
||||||
|
|
||||||
LAZY: 'dash' ( -- parser )
|
: replace-underscores ( str -- str' )
|
||||||
dash-char =parser ;
|
[ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
|
||||||
|
|
||||||
LAZY: 'char-gap' ( -- parser )
|
|
||||||
char-gap-char =parser ;
|
|
||||||
|
|
||||||
LAZY: 'word-gap' ( -- parser )
|
|
||||||
word-gap-char =parser ;
|
|
||||||
|
|
||||||
LAZY: 'morse-char' ( -- parser )
|
|
||||||
'dot' 'dash' <|> <+> ;
|
|
||||||
|
|
||||||
LAZY: 'morse-word' ( -- parser )
|
|
||||||
'morse-char' 'char-gap' list-of ;
|
|
||||||
|
|
||||||
LAZY: 'morse-words' ( -- parser )
|
|
||||||
'morse-word' 'word-gap' list-of ;
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
: >morse ( str -- newstr )
|
||||||
|
trim-blanks sentence>morse ;
|
||||||
|
|
||||||
|
: morse> ( morse -- plain )
|
||||||
|
replace-underscores morse>sentence ;
|
||||||
|
|
||||||
: morse> ( str -- str )
|
SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
|
||||||
'morse-words' parse car parsed>> [
|
|
||||||
[
|
|
||||||
>string morse>ch
|
|
||||||
] map >string
|
|
||||||
] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
|
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
|
||||||
|
|
||||||
: queue ( symbol -- )
|
: queue ( symbol -- )
|
||||||
|
|
@ -135,7 +125,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
|
||||||
: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
|
: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
|
||||||
: letter-gap ( -- ) letter-gap-buffer queue ;
|
: letter-gap ( -- ) letter-gap-buffer queue ;
|
||||||
|
|
||||||
: beep-freq ( -- n ) 880 ;
|
CONSTANT: beep-freq 880
|
||||||
|
|
||||||
: <morse-buffer> ( -- buffer )
|
: <morse-buffer> ( -- buffer )
|
||||||
half-sample-freq <8bit-mono-buffer> ;
|
half-sample-freq <8bit-mono-buffer> ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue