steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adding morse code translation code

db4
Alex Chapman 2008-01-26 00:15:11 +11:00
parent 76e4702f38
commit ba4062e04b
3 changed files with 149 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
extra/morse/morse-docs.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax morse ;
HELP: ch>morse
{ $values
{ "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." } ;
HELP: morse>ch
{ $values
{ "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" } ;

11
extra/morse/morse-tests.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays morse strings tools.test ;
[ "" ] [ CHAR: \\ ch>morse ] unit-test
[ "..." ] [ CHAR: s ch>morse ] unit-test
[ CHAR: s ] [ "..." morse>ch ] unit-test
[ f ] [ "..--..--.." morse>ch ] unit-test
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test

125
extra/morse/morse.factor Normal file
View File

@ -0,0 +1,125 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel lazy-lists namespaces openal
parser-combinators promises sequences strings ;
IN: morse
<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 )
morse-codes >hashtable ;
: morse>ch-assoc ( -- assoc )
morse-codes [ reverse ] map >hashtable ;
PRIVATE>
: ch>morse ( ch -- str )
ch>lower ch>morse-assoc at* swap "" ? ;
: morse>ch ( str -- ch )
morse>ch-assoc at* swap f ? ;
: >morse ( str -- str )
[
[ CHAR: \s , ] [ ch>morse % ] interleave
] "" make ;
<PRIVATE
: dot ( -- ch ) CHAR: . ;
: dash ( -- ch ) CHAR: - ;
: char-gap ( -- ch ) CHAR: \s ;
: word-gap ( -- ch ) " / " ;
: =parser ( obj -- parser )
[ = ] curry satisfy ;
LAZY: 'dot' ( -- parser )
dot =parser ;
LAZY: 'dash' ( -- parser )
dash =parser ;
LAZY: 'char-gap' ( -- parser )
char-gap =parser ;
LAZY: 'word-gap' ( -- parser )
word-gap token ;
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>
: morse> ( str -- str )
'morse-words' parse car parse-result-parsed [
[
>string morse>ch
] map >string
] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;