Merging Diego Martinelli's improvements and simplifications of morse

diff --git a/extra/morse/authors.txt b/extra/morse/authors.txt
index e9c193bac72836f0710fc5440af248256e9fc736..409f0443a67557e80e3abf087400cb6393ec519c 100644 (file)
--- a/extra/morse/authors.txt
+++ b/extra/morse/authors.txt
@@ -1 +1,2 @@
 Alex Chapman
+Diego Martinelli

diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor
index e35967d3e965e85f5703f8faa547991241e8686d..93350ad02d3da97bb49ad328bd43ca864e6dd8db 100644 (file)
--- a/extra/morse/morse-docs.factor
+++ b/extra/morse/morse-docs.factor
@@ -6,12 +6,12 @@ IN: 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." } ;
+{ $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ;
 
 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" } ;
+{ $description "If the given string represents a morse code character, then return that character, otherwise return a space character." } ;
 
 HELP: >morse
 { $values

diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor
index 144448917f3e3d10ac432952c7d77cda49d81925..fd52df1c4d54987bf06ca7fe78e480c9554d04b6 100644 (file)
--- a/extra/morse/morse-tests.factor
+++ b/extra/morse/morse-tests.factor
@@ -1,13 +1,43 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
 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 ] [ "..." 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
 [ "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
 ! [ ] [ "Factor rocks!" play-as-morse ] unit-test

diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor
index 54abce93953808f9a3e0835987d6a5942238cf28..49e6ae39f594355eda6e3cb7c75904fb8b4bfd51 100644 (file)
--- a/extra/morse/morse.factor
+++ b/extra/morse/morse.factor
@@ -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.
-USING: accessors ascii assocs combinators hashtables kernel lists math
-namespaces make openal parser-combinators promises sequences
-strings synth synth.buffers unicode.case ;
+USING: accessors ascii assocs biassocs combinators hashtables kernel lists math
+namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
 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 ;
+
+CONSTANT: dot-char CHAR: .
+CONSTANT: dash-char CHAR: -
+CONSTANT: char-gap-char CHAR: \s
+CONSTANT: word-gap-char CHAR: /
+CONSTANT: unknown-char CHAR: ?
 
 PRIVATE>
 
-: ch>morse ( ch -- str )
-    ch>lower ch>morse-assoc at* swap "" ? ;
+DEFER: morse-code-table
+
+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-assoc at* swap f ? ;
-
-: >morse ( str -- str )
-    [
-        [ CHAR: \s , ] [ ch>morse % ] interleave
-    ] "" make ;
-
+    morse-code-table value-at [ char-gap-char ] unless* ;
+    
 <PRIVATE
+    
+: word>morse ( str -- morse )
+    [ ch>morse ] { } map-as " " join ;
 
-: dot-char ( -- ch ) CHAR: . ;
-: dash-char ( -- ch ) CHAR: - ;
-: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap-char ( -- ch ) CHAR: / ;
-
-: =parser ( obj -- parser )
-    [ = ] curry satisfy ;
+: sentence>morse ( str -- morse )
+    " " split [ word>morse ] map " / " join ;
+    
+: trim-blanks ( str -- newstr )
+    [ blank? ] trim ; inline
 
-LAZY: 'dot' ( -- parser )
-    dot-char =parser ;
+: morse>word ( morse -- str )
+    " " split [ morse>ch ] "" map-as ;
 
-LAZY: 'dash' ( -- parser )
-    dash-char =parser ;
+: morse>sentence ( morse -- sentence )
+    "/" split [ trim-blanks morse>word ] map " " join ;
 
-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 ;
+: replace-underscores ( str -- str' )
+    [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
 
 PRIVATE>
-
-: morse> ( str -- str )
-    'morse-words' parse car parsed>> [
-        [ 
-            >string morse>ch
-        ] map >string
-    ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
-
+    
+: >morse ( str -- newstr )
+    trim-blanks sentence>morse ;
+    
+: morse> ( morse -- plain )
+    replace-underscores morse>sentence ;
+
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ; 
+    
 <PRIVATE
+    
 SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
 
 : 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 ;
 : letter-gap ( -- ) letter-gap-buffer queue ;
 
-: beep-freq ( -- n ) 880 ;
+CONSTANT: beep-freq 880
 
 : <morse-buffer> ( -- buffer )
     half-sample-freq <8bit-mono-buffer> ;