#!/usr/bin/tclsh
# Keywords: Emacspeak, Software Dectalk , TCL
#{{{ LCD Entry: 

# LCD Archive Entry:
# emacspeak| T. V. Raman |raman@cs.cornell.edu
# A speech interface to Emacs |
#$Id$
#Incorporating fixes  from  by Tim Cross for DTk 5.0
# Date: 2004/05/01 01:16:25  |
# Location https://github.com/tvraman/emacspeak
#

#}}}
#{{{ Copyright:  
#Copyright (C) 1995 -- 2001, T. V. Raman 
#All Rights Reserved
#
# This file is not part of GNU Emacs, but the same permissions apply.
#
# GNU Emacs is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# GNU Emacs is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GNU Emacs; see the file COPYING.  If not, write to
# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

#}}}
#{{{source common code 

package require Tclx
set wd [file dirname $argv0]
source $wd/tts-lib.tcl
set tts(old_rate) 0

#}}}
#{{{ procedures  

proc version {} {
    q {[:version speak]}
    d
}

proc tts_set_punctuations {mode} {
    global tts
    set tts(punctuations) $mode
    return ""
}

proc tts_set_speech_rate {rate} {
    global tts
    set factor $tts(char_factor) 
    set tts(speech_rate) $rate
    set tts(say_rate) [round [expr $rate  * $factor ]]
    return ""
}

proc tts_set_character_scale {factor} {
    global tts
    set tts(say_rate) [round [expr $tts(speech_rate) * $factor ]]
    set tts(char_factor) $factor
    return ""
}

proc tts_say {text} {
    global tts
	synth "$text "
    return ""
}

#formerly called tts_letter

proc l {text} {
    global tts
    synth "\[:sa le]$text\[:sa c] "
	return ""
}

#formerly called tts_speak
proc d {} {
    speech_task
}

#formerly called tts_stop 

proc s {} {
    stop 
    queue_clear
}

#formerly called tts_tone


proc t  {{pitch 440} {duration 50}} {
    global tts queue
    if {$tts(beep)} {
        b $pitch $duration
        return ""
    }
}

proc sh  {{duration 50}} {
    global tts queue 
    q  "\[_<$duration>] "
    return ""
}


proc tts_split_caps {flag} {
    global tts 
    set tts(split_caps) $flag
    return ""
}

proc tts_reset {} {
    global tts 
    synth -reset
    queue_clear
    synth {[:phoneme arpabet speak on][:pu s][:sa c] Reset Dectalk}
}

proc r {rate} {
    global queue  tts
    set queue($tts(q_tail)) [list s "\[:rate $rate] "]
    incr tts(q_tail)
    return ""
}

#}}}
#{{{ speech task 

proc speech_task {}  {
    global queue tts 
    set mode  $tts(punctuations) 
    set r $tts(speech_rate)
    set length [queue_length]
	say "\[:sa c]\[:np]\[:pu $mode]"
    if {$tts(old_rate) != $r } {
        say "\[:ra $r]" 
        set tts(old_rate) $r
    }
   
    loop index 0 $length {
        set event   [queue_remove]
        set event_type [lindex $event 0]
        switch  -exact -- $event_type {
            s {
                set text [clean [lindex $event 1]]
                say  "\[:i r 1]$text "
            }
            c {
                set text  [lindex $event 1]
                say  "\[:i r 1]$text "
            }
            a {
                set sound [lindex $event 1]
                catch "exec $tts(play) $sound > /dev/null &" errCode
            }
            b {
                if {$tts(beep)} {
                    lvarpop event 
                    eval beep $event
                }
            }
        }
    }
    synth " "
    return ""
}

#}}}
#{{{clean 

#preprocess element before sending it out:
proc clean {element} {
    global queue tts
    if {$tts(caps_beep)} {
        set tone {[:to 440 20]}
    set atone {[:to 1300 20]}
    } else {
        set tone ""
    set atone ""
    }
    
    set abbrev {\y[-_[:upper:]]{2,}\y}
    set element [string trim $element]
    if {[string match all $tts(punctuations)] } {
        regsub -all {\#} $element { pound } element
		regsub -all {\*} $element { star } element
        regsub -all {\.} $element { dot  } element
        regsub -all {\.,} $element { dot comma [_,] } element
        regsub -all {[[:punct:]]} $element  { \0 }   element
        regsub -all {\.\.\.} $element { dot dot dot } element
        regsub -all {\.\.} $element { dot dot } element
        regsub -all {([[:alpha:]])\.([[:alpha:]])} $element {\1 dot \2} element
        regsub -all {\y[[:digit:]]+\y} $element { & } element
    } else {
        regsub -all {([[:alnum:]])([[:punct:]])+([[:alnum:]])} $element \
            {\1 \2 \3} element
        regsub -all {([[:alpha:]])(,)+([[:alpha:]])} $element \
            {\1 \2 \3} element
        regsub -all {([[:alpha:]])(\.)([:alpha:])} $element {\1 dot \3} element
        regsub -all {``} $element {[_<1>/]} element
        regsub -all {''} $element {[_<1>\\]} element
    }
    if {$tts(split_caps) } {
        while {[regexp $abbrev  $element match    ]}  {
            regsub  $match $element "$atone [string tolower $match]" element
        }
        # next line  produces a tone for capitalized words.
        regsub -all {\y[[:upper:]][[:lower:]]+\y} $element "$tone   &" element
        regsub -all {[[:upper:]]} $element { [_<1>]&} element
        regsub -all {([^ -_[:upper:]])([[:upper:]][[:alpha:]]*\y)} $element\
            {\1 [_<1>] \2 } element
        regsub -all {\y[A]\y} $element {[ey]} element
    }
    return $element 
}

#}}}
#{{{ Initialize and set state.

#do not die if you see a control-c
signal ignore {sigint}

#initialize Dectalk 
tts_initialize
beep_initialize
set tts(speech_rate)  225
set tts(say_rate) [round \
                           [expr $tts(speech_rate) * $tts(char_factor)]]
set tclTTS $env(EMACSPEAK_DIR)/servers/software-dtk
load $tclTTS/tcldtk.so
synth   {[:phoneme arpabet speak on ]
    [:pu s ]
    [:sa c]
    [:np]
    I speak, Therefore I am.}
#Start the main command loop:
commandloop

#}}}
#{{{ Emacs local variables  

### Local variables:
### mode: tcl
### voice-lock-mode: t
### folded-file: t
### End:

#}}}

commandloop
