proc morse {s} {
# \u00C4 - Ä (Auml)
# \u00D6 - Ö (Ouml)
# \u00DC - Ü (Uuml)
set _morse {
A ._ \u00C4 ._._ B _... C _._. D _.. E . F .._.
G __. H .... I .. J .___ K _._ L ._.. M __
N _. O ___ \u00D6 ___. P .__. Q __._ R ._. S ...
T _ U .._ \u00DC ..__ V ..._ W .__ X _.._ Y _.__ Z __..
0 _____ 1 .____ 2 ..___ 3 ...__ 4 ...._ 5 .....
6 _.... 7 __... 8 ___.. 9 ____.
. ._._._ , __..__ ? ..__.. / _.._. ( _.__. ) _.__._
+ ._._. : ___... ; ...___ - _...._ = _..._
~ ._... # ..._._ $ _..._._
}
set res ""
if [regexp {^[._ ]+$} $s] {
regsub -all { +} $s " B " s
foreach i [split $s] {
if {$i==""} continue
if {$i=="B"} {append res " "; continue}
set ix [lsearch $_morse $i]
if {$ix>=0} {
append res [lindex $_morse [expr {$ix-1}]]
} else {append res ?}
}
} else {
foreach i [split [string toupper $s] ""] {
if {$i==" "} {append res " "; continue}
set ix [lsearch -exact $_morse $i]
if {$ix>=0 && $ix%2==0} {
append res "[lindex $_morse [expr {$ix+1}]] "
}
}
}
set res
} ;#RS - slightly uncrufted 2001-12-04KBK (2002-04-09)QST QST QST DE KE9TV/2 KE9TV/2 KE9TV/2 BTadded punctuation, plus added procedural signs
~ - Stand by (AS) # - End of work (SK or VA) $ - Break (BK)Procedural signs AR, BT and KN are encoded by +, = and ( respectively, since those are the meaning of those signs within a message body.Ampersand should be sent as the two characters ES.Still to do: AAA is a period, but a decimal point is sent as a character R.
VY 73 DE KE9TV/2 SK AR
For practizing, see also A little Morse trainer
DKF: Here's a morse code player I wrote for Rosetta Code that uses Snack to do the playing:
# This uses the GUI-free part of the Snack library
package require sound
# A simple pause while running the event loop, in terms of basic time units
proc pause n {
global t
after [expr {$t * $n}] set ok 1
vwait ok
}
# Generate using a sine-wave filter
proc beep n {
global frequency
set f [snack::filter generator $frequency 30000 0.0 sine -1]
set s [snack::sound -rate 22050]
$s play -filter $f
pause $n
$s stop
$s destroy
$f destroy
pause 1
}
# The dits and the dahs are just beeps of different lengths
interp alias {} dit {} beep 1
interp alias {} dah {} beep 3
set MORSE_CODE {
"!" "---." "\"" ".-..-." "$" "...-..-" "'" ".----."
"(" "-.--." ")" "-.--.-" "+" ".-.-." "," "--..--"
"-" "-....-" "." ".-.-.-" "/" "-..-."
":" "---..." ";" "-.-.-." "=" "-...-" "?" "..--.."
"@" ".--.-." "[" "-.--." "]" "-.--.-" "_" "..--.-"
"0" "-----" "1" ".----" "2" "..---" "3" "...--"
"4" "....-" "5" "....." "6" "-...." "7" "--..."
"8" "---.." "9" "----."
"A" ".-" "B" "-..." "C" "-.-." "D" "-.."
"E" "." "F" "..-." "G" "--." "H" "...."
"I" ".." "J" ".---" "K" "-.-" "L" ".-.."
"M" "--" "N" "-." "O" "---" "P" ".--."
"Q" "--.-" "R" ".-." "S" "..." "T" "-"
"U" "..-" "V" "...-" "W" ".--" "X" "-..-"
"Y" "-.--" "Z" "--.."
}
# The code to translate text to morse code and play it
proc morse {str wpm} {
global t MORSE_CODE
set t [expr {1200 / $wpm}]
# Backslash and space are special cases in various ways
set map {"\\" {} " " {[pause 4]}}
# Append each item in the code to the map, with an inter-letter pause after
foreach {from to} $MORSE_CODE {lappend map $from "$to\[pause 3\]"}
# Convert to dots and dashes
set s [string map $map [string toupper $str]]
# Play the dots and dashes by substituting commands for them
subst [string map {"." [dit] "-" [dah]} $s]
return
}
# We'll play at a fairly high pitch
set frequency 700
morse "Morse code with Tcl and Snack." 20ZB 2012-05-24 There is an unpleasant "pitter-pattering", which I'm unable to dispose of. Most probably Snack's command "play" and "stop" are switching on and off the volume, causing this effect. It would be handy to have "stop" with option "stop playing all sounds, but don't change present volume level". Or the mentioned action should be valid for "pause" command rather (currently it's causing "pitter-pattering" too).