cebpic/morse-tester

   1 #!/usr/bin/wish
   2 #
   3 # usage:
   4 #  type these things in the window
   5 #    a-z 0-9    add character to queue or to repeat string
   6 #    spc        insert morse space
   7 #    #          clear, make us repeat
   8 #    =          clear, do not repeat
   9
  10 proc widgets {} {
  11     catch { destroy .b }
  12     frame .b -width 20 -height 20
  13     pack .b -padx 70 -pady 20 -fill none
  14     . configure -background {#222}
  15 }
  16
  17 proc lamp-off {} { .b configure -background black }
  18 proc lamp-on {} { .b configure -background red }
  19
  20 proc bgerror {emsg} {
  21     global errorCode errorInfo
  22     puts stderr \
  23 "==========BGERROR==========
  24 $emsg
  25 $errorCode
  26 $errorInfo
  27 ===========================
  28 "
  29 }
  30
  31 proc setup {} {
  32     global morselist
  33     widgets
  34     lamp-off
  35     foreach {key value} $morselist {
  36         bind . [string tolower $key] [list morse-key $key $value]
  37     }
  38     bind . {#} { repeat 1 }
  39     bind . = { repeat 0 }
  40     bind . <Key-space> { morse-add " " | }
  41     fconfigure stdout -buffering none
  42 }
  43
  44 proc repeat {yn} {
  45     global repeating morse_after morse_queue morse_repeat
  46     lamp-off
  47     set morse_queue {}
  48     set morse_repeat {}
  49     set repeating $yn
  50     if {[info exists morse_after]} {
  51         after cancel $morse_after
  52         unset morse_after
  53     }
  54     puts ""
  55 }
  56
  57 proc reload {} {
  58     uplevel #0 source morse-tester
  59 }
  60
  61 proc morse-add {key dotsdashes} {
  62     global repeating morse_queue morse_repeat morse_after
  63     append morse_queue $dotsdashes
  64     if {$repeating} { append morse_repeat $dotsdashes }
  65     if {![info exists morse_after]} morse-next
  66     puts -nonewline $key
  67 }
  68
  69 proc morse-key {key dotsdashes} {
  70     morse-add $key "$dotsdashes "
  71 }
  72
  73 set morse_queue {}
  74 set unit_ms 66
  75 set repeating 1
  76
  77 proc after-units {units script} {
  78     global unit_ms morse_after
  79     set morse_after [after [expr {$units * $unit_ms}] $script]
  80 }
  81
  82 proc space {units} {
  83     lamp-off; after-units $units morse-next
  84 }
  85
  86 proc morse-next {} {
  87     global morse_queue morse_repeat morse_after
  88     if {![string length $morse_queue]} {
  89         if {![string length $morse_repeat]} { unset morse_after; return }
  90         set morse_queue "|$morse_repeat"
  91     }
  92     set c [string index $morse_queue 0]
  93     set morse_queue [string range $morse_queue 1 end]
  94     switch -exact -- $c {
  95         . { lamp-on; after-units 1 {space 1} }
  96         _ { lamp-on; after-units 3 {space 1} }
  97         { } { space 2 }
  98         | { space 6 }
  99     }
 100 }
 101
 102 set morselist {
 103 A       ._
 104 B       _...
 105 C       _._.
 106 D       _..
 107 E       .
 108 F       .._.
 109 G       __.
 110 H       ....
 111 I       ..
 112 J       .___
 113 K       _._
 114 L       ._..
 115 M       __
 116 N       _.
 117 O       ___
 118 P       .__.
 119 Q       __._
 120 R       ._.
 121 S       ...
 122 T       _
 123 U       .._
 124 V       ..._
 125 W       .__
 126 X       _.._
 127 Y       _.__
 128 Z       __..
 129 0       _____
 130 1       .____
 131 2       ..___
 132 3       ...__
 133 4       ...._
 134 5       .....
 135 6       _....
 136 7       __...
 137 8       ___..
 138 9       ____.
 139 }
 140
 141 setup