package require Tk
array 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 / " "
}
option add *Button -padx 0
proc ui {} {
global timevec morse
set font {Courier 10}
canvas .c -height 58 -relief sunken -borderwidth 1
.c create oval 5 5 55 55 -fill gold2 -outline gold3 -width 2 -tag key
.c create text 70 2 -text "Morse Trainer" -anchor nw \
-font {Times 24 {bold italic}}
.c create text 70 38 -anchor nw -text \
"Click the brass button to morse - have fun with Tcl/Tk!"
.c bind key <1> {compute; %W move current 2 2}
.c bind key <ButtonRelease-1> {compute; %W move current -2 -2}
grid .c - -sticky news
frame .f
label .f.lon -text On:
entry .f.on -textvar ::th_on -width 4
label .f.loff -text Off:
entry .f.off -textvar ::th_off -width 4
label .f.lgap -text Gap:
entry .f.gap -textvar ::th_gap -width 4
eval pack [winfo children .f] -side left
grid .f -
button .clear -text C -command init
label .info1 -textvar ::info1 -width 40 -font $font -anchor e
grid .clear .info1 -sticky news
button .help -text ? -command {help .help}
label .info2 -textvar ::info2 -bg white -width 40 -anchor e -font $font
grid .help .info2 -sticky news
label .h -textvar ::help -font $font -relief sunken -bg lightyellow
set tmp {}
foreach {mors char} [array get morse] {
lappend tmp [list $char $mors]
}
foreach {1 2 3 4 5} [lsort $tmp] {
foreach i {1 2 3 4 5} {
append ::help "[set $i]\t"
}
append ::help \n
}
grid columnconfigure . 1 -weight 1
init
}
proc help {w} {
if {[$w cget -text]=="?"} {
grid .h - -sticky news
$w config -text !
} else {
grid forget .h
$w config -text ?
}
}
proc init {} {
set ::info1 {}; set ::info2 {}; set ::timevec {}; set ::t 0
set ::th_on 200
set ::th_off 200
set ::th_gap 9
}
# Times for an on/off signal are measured here, and appended to timevec
proc compute {} {
global t timevec
global th_on th_off th_gap
set now [clock clicks -milliseconds]
if {$t} {lappend timevec [expr {$now - $t}]}
set t $now
set res ""
foreach {on off} $timevec {
if {$on>$th_on} {
append res -
} else {
append res .
}
if {$off > $th_off} {append res " "}
if {$off > $th_off * $th_gap} {append res "/ "}
}
set ::info1 $res
set ::info2 [morsedecode $res]
}
# This maps "..." to "s", etc.
proc morsedecode string {
global morse
set res ""
foreach part $string {
if {[info exists morse($part)]} {
append res $morse($part)
} else {append res "?"}
}
set res
}
ui
bind . <Escape> {exec wish $argv0 &; exit}FW: Using the Snack sound toolkit, you can make the Morse trainer beep (in traditional Morse code style) while the mouse is held down over the "knob". Just append this to the end of the code:
package require sound
set playing 0
set beep [snack::sound -rate 22050]
set filter [snack::filter generator 1000 30000 0.0 sine]
rename compute _compute
proc compute {} {
global playing filter beep
if {$playing} {
$beep stop
} else {
$beep play -filter $filter
}
set playing [expr {!$playing}]
_compute
} ;# FWRS: Thanks ever so much! This is the cooperative spirit that I love the Wiki for! Your "snack magic" also went straight into A toy piano ;-)
