Add multiple language real time translating ability to a Tcl/Tk application in only about 100 lines of code. I'm a doctor and I'm using it in a medical application where I need to communicate in real time with Spanish and Portuguese speaking patients and their families. Add text to speech with ViaVoice or Festival speech synthesis tools.
Tcl, 120 lines
Download
Copy to clipboard1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | #!/bin/sh
# May need to change if not wish8.4 \
exec wish8.4 "$0" "$@"
package require http
# may need to uncomment next line if using a proxy server
#http::config -proxyhost proxy -proxyport 80
proc translate_query {query lang} {
set url http://babelfish.altavista.com/babelfish/tr?doit=done&urltext=[string map {" " +} $query]&lp=$lang
#puts "url = $url"
set token [http::geturl $url]
set data [http::data $token]
http::cleanup $token
#puts $token
#puts $data
set results ""
#regexp {\n[0-9-]+ of ([0-9]+)} $data -> results
regexp {input type=hidden name="q" value=[^>]+>} $data results
regsub {^(input type=hidden name="q" value=")} $results {} results
regsub {(">)$} $results {} results
set results
}
proc go {w} {
global query lang speak_choice original_output
if {$original_output == "Yes"} {
$w insert end "$query\n"
}
set answer [translate_query $query $lang]
$w insert end "$answer \n"
$w see end
update idletasks
# for the ViaVoice TTS speech synthesis system
# adjust for the path to cmdlinespeak on your system
if {$speak_choice == "TTS"} {
exec /usr/lib/ViaVoiceOutloud/samples/cmdlinespeak/cmdlinespeak "$answer"
}
# for the Festival speech synthesis system
# adjust path to the festival program on your system
if {$speak_choice == "Festival"} {
set f [open speech_test w]
puts $f "$answer"
close $f
exec /hdc1/festival/bin/festival --tts speech_test
}
}
set lang "en_es"
frame .frame
menubutton .frame.lang -text "English -> Spanish" -relief raised -indicatoron \
true -pady 0 -menu .frame.lang.menu
menu .frame.lang.menu
.frame.lang.menu add radiobutton -label "English -> Spanish" -variable lang \
-value "en_es" -command {.frame.lang configure -text "English -> Spanish"}
.frame.lang.menu add radiobutton -label "English to Portuguese" -variable lang \
-value "en_pt" -command {.frame.lang configure -text "English -> Portuguese"}
.frame.lang.menu add radiobutton -label "Spanish -> English" -variable lang \
-value "es_en" -command {.frame.lang configure -text "Spanish -> English"}
.frame.lang.menu add radiobutton -label "Portuguese -> English" -variable lang \
-value "pt_en" -command {.frame.lang configure -text "Portuguese -> English"}
set original_output No
.frame.lang.menu add separator
.frame.lang.menu add command -label "Output Original Text?"
.frame.lang.menu add radiobutton -label "No " -variable original_output -value No
.frame.lang.menu add radiobutton -label "Yes" -variable original_output -value Yes
set speak_choice "None"
menubutton .frame.speak -text "Text -> Speech?" -relief raised -pady 0 -indicatoron true -menu .frame.speak.menu
menu .frame.speak.menu
.frame.speak.menu add radiobutton -label "None " -variable speak_choice -value None
.frame.speak.menu add radiobutton -label "Festival " -variable speak_choice -value "Festival"
.frame.speak.menu add radiobutton -label "ViaVoice TTS" -variable speak_choice -value "TTS"
button .frame.print -text "Print" -pady 0 -command {
set print_data [.frame2.t get 1.0 end]
set f [open ./print_data.txt w]
puts $f "\n\n\n\n$print_data"
close $f
exec lpr ./print_data.txt
}
entry .e -textvar query -bg white
bind .e <Return> {
go .frame2.t
lappend history_list $query
set history_index [expr [llength $history_list] -1]
}
bind .e <Control-k> {set query ""}
bind .e <Key-Up> {
if {$history_index >= 1} {
incr history_index -1
set query [lindex $history_list $history_index]
}
}
bind .e <Key-Down> {
if {$history_index <= "[expr [llength $history_list] - 1]" } {
incr history_index
set query [lindex $history_list $history_index]
}
}
frame .frame2
text .frame2.t -bg white -yscrollcommand {.frame2.scroll set}
scrollbar .frame2.scroll -command {.frame2.t yview}
pack .frame -fill x -expand 1
pack .frame.lang .frame.speak .frame.print -side left -fill x -expand 1
pack .e -fill x -expand 1
pack .frame2 -fill x -expand 1
pack .frame2.t -side left -fill x -expand 1
pack .frame2.scroll -side left -fill y -expand 1
|
I modified Richard Suchenwirth's "Fuzzy Google Logic" script and directed it to Alta Vista's Babel Fish site. It uses Tcl's http package to send an appropriate query string to the Babel Fish server. Then it uses Tcl's regexp and regsub to extract the desired information from the web server response and inserts the results into a Tk text widget. You can print the output and/or you can send it to either IBM ViaVoice or to Festival speech synthesis. Include the original text in output or leave it out. I just love using this script in my medical practice.
Tags: binding
