# $Id: mbrola,v 9.0 1998/10/24 05:17:28 raman Exp $
# Description:  Interfacing to MBROLA  via TCL. 
# Keywords: Emacspeak, MBROLA, TCL
# {{{ LCD Entry: 

# LCD Archive Entry:
# emacspeak| T. V. Raman |raman@adobe.com 
# A speech interface to Emacs |
# $Date: 1998/10/24 05:17:28 $ |
#  $Revision: 9.0 $ | 
# Location undetermined
#

# }}}
# {{{ Copyright:  

# Copyright (c) 1995, 1996, 1997, 1998  T. V. Raman, Adobe Systems
# Incorporated.
#All Rights Reserved
# Copyright (c) 1994, 1995 by Digital Equipment Corporation.
# 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.

# }}}
# {{{ procedures  

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(say_rate) [round \
                                       [expr $rate  * $factor ]]
    set tts(speech_rate) $rate
    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
    set tts(not_stopped) 1
    set pattern {\[[^]*\]}
    regsub -all $pattern $text " " text
    exec echo $text | $tts(speak) 2>&1 > /dev/null        
    return ""
}

#formerly called tts_letter

proc l {text} {
    global tts
    set tts(not_stopped) 1
    set r $tts(speech_rate)
    set f  $tts(say_rate)
    exec echo $text | $tts(speak) 2>&1 > /dev/null
        return ""
}

#formerly called tts_speak
proc d {} {
    speech_task
}

proc tts_resume  {} {
    global tts
    queue_restore
    if {[queue_empty?]} {
        set text "No speech to resume. "
        exec echo $text | $tts(speak) 2>&1 > /dev/null
        set tts(not_stopped) 1
    } else {
        speech_task
    }
    return ""
}

proc tts_pause {} {
    global tts 
    queue_backup
    s
    return ""
}

#formerly called tts_stop 

proc s {}  {
    queue_clear
}

#formerly called tts_tone

proc t  {{pitch 440} {duration 50}} {
    global tts queue
    set tone "\[:to $pitch $duration\]"
    set queue($tts(q_tail)) [list t $tone]
    incr tts(q_tail)
    return ""
}

proc sh  {{duration 50}} {
    global tts queue
    set silence "\[_<$duration>\]"
    set queue($tts(q_tail)) [list t $silence]
    incr tts(q_tail)
    return ""
}


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

proc tts_capitalize {flag} {
    global tts 
    set tts(capitalize) $flag
    return ""
}

proc tts_allcaps_beep {flag} {
    global tts 
    set tts(allcaps_beep) $flag
    return ""
}

proc  read_pending_p  {file_handle} {
    set status   [lsearch [select [list  $file_handle]  {} {} 0] $file_handle]
    expr $status >= 0
}

#note that we cannot use stdin here due to a tcl bug.
#in tcl 7.4 we could always say file0
#in 7.5 and above  (only tested in 7.5 and 8.0)
 #we need to say sock0 when we are a server

proc tts_get_acknowledgement {} {
    global tts
    set input $tts(input)
    set status [select [list    $input ] {} {} 0]
    if {[lsearch $status $input]   >=0} {
        set tts(talking?) 0
    } else {
    }
    return ""
}

#Gobble up any garbage the Dectalk has returned.

proc tts_gobble_acknowledgements {{delay 0.1}} {
    global tts
    set r $tts(read)
    while {[lsearch [select [list  $r] {} {} 0.001] $r] >= 0  } {
        read $r  1
    }
}

proc tts_reset {} {
    set text "reset is not yet implemented. "
    exec echo $text | $tts(speak) 2>&1 > /dev/null
}

# }}}
# {{{ speech task 

proc speech_task {} {
    global queue tts
    set tts(talking?) 1
    set tts(not_stopped) 1
    set mode  $tts(punctuations) 
    set r $tts(speech_rate)
    set length [queue_length]
    #set up tts state
    set phone freephone
    set lex -h/usr/lib/mbrola/tts-English/lib/lexicon
    set synth mbrola
    set lang /usr/lib/mbrola/en1/en1
    set rate  [expr 300.0 / $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]]
                catch [exec echo $text \
                           | $phone $lex \
                           | $synth -v $tts(volume) -f $tts(pitch) \
                           -l $tts(freq) -t $rate  $lang - -.au  \
                           | na_play 2>&1 > /dev/null] errCode
                set retval [tts_get_acknowledgement ]
            }
            t {
                set text  [lindex $event 1]
                #send out the tone
            }
            a {
                set sound [lindex $event 1]
                catch "exec $tts(play) $sound >& /dev/null &" errCode
            }
        }
        if {$tts(talking?) == 0} {break;} 
    }
    set tts(talking?) 0
    return ""
}

# }}}
# {{{ queue:

#currently we use an inlined version of this test in speech_task

proc queue_empty? {} {
    global tts
    expr $tts(q_head) == $tts(q_tail)
}

proc queue_nonempty? {} {
    global tts
    expr $tts(q_head) != $tts(q_tail)
}

proc queue_length {} {
    global tts
    expr $tts(q_tail) - $tts(q_head)
}

proc queue_clear {} {
    global tts queue
    if {$tts(debug)} {
        exec echo $text | $tts(speak) 2>&1 > /dev/null
    }
    unset queue
    set queue(-1) "" 
    set tts(q_head) 0
    set tts(q_tail) 0 
    return ""
}

#formerly called queue_speech --queue speech event

proc q {element} {
    global queue tts
    set queue($tts(q_tail)) [list s $element]
    incr tts(q_tail)
    set mod [expr ($tts(q_tail) - $tts(q_head)) % 50]
    set sound "progress.au"
    if {$mod == 0} {
        catch "exec $tts(play) $sound >& /dev/null &" errCode
    }
    return ""
}

#queue a sound event

proc a {sound} {
    global queue tts
    set queue($tts(q_tail)) [list a $sound]
    incr tts(q_tail)
    return ""
}


proc queue_remove {} {
    global tts queue 
    set element  $queue($tts(q_head))
    incr tts(q_head)
    return $element
}

proc queue_backup {} {
    global tts  backup queue
    unset backup
    set backup(-1) ""
    set head [expr  $tts(q_head) - 2]
    set tail $tts(q_tail)
    loop i $head $tail 1 {
        set backup($i) $queue($i)
    }
    set tts(backup_head) $head
    set tts(backup_tail) $tail
}

proc queue_restore {} {
    global tts  backup queue
    unset queue
    set queue(-1) ""
    set head $tts(backup_head)
    set tail $tts(backup_tail)
    loop i $head $tail 1 {
        set queue($i) $backup($i)
    }
    set tts(q_head) $head
    set tts(q_tail) $tail
}

# }}}
# {{{sounds: 

#play a sound over the server
proc p {sound} {
    global tts
    catch "exec $tts(play) $sound >& /dev/null &" errCode
    speech_task
}

    # }}}
# {{{mbrola specific code 

#preprocess element before sending it out:

#set up pronunciation table 

proc clean {element} {
    global tts pronounce
    #first nuke all embedded controls 
    regsub -all $tts(inline_commands) $element { }  element
    #mbrola (specifically freephone) dies on blank lines
    regsub -all "\012|\015" $element { } element
    #split numbers 
    regsub -all {[0-9]} $element { & } element
    if {[string match all $tts(punctuations)]} {
        set p $tts(punct_pattern)
        while {[regexp $p $element match]} {
            regsub -all "\\$match" $element " $pronounce($match) " element
        }
    }
    return $element
}

# }}}
# {{{set punctuation pronunciation table 

set tts(inline_commands)  {\[[^]]*\]}
set pronounce(\!) exclamation 
set pronounce(\@) at
set pronounce(\#) pound
set pronounce(\$) dollar
set pronounce(\%) percent 
set pronounce(\^) caret 
set pronounce(\&) ampersand 
set pronounce(\*) star
set pronounce(\() "left paren"
set pronounce(\)) "right paren"
set pronounce(\-) dash
set pronounce(\_) underscore 
set pronounce(\+) plus
set pronounce(\=) equals
set pronounce(\[) "left bracket"
set pronounce(\]) "right bracket"
set pronounce(\{) "left brace"
set pronounce(\}) "right brace"
set pronounce(\\) backslash
set pronounce(\|) pipe
set pronounce(\,) comma
set pronounce(\.) period 
set pronounce(\;) "semi colon"
set pronounce(\:) colon
set pronounce(\') apostrophe 
set pronounce(\") quotes 
set pronounce(\/) slash
set pronounce(\?) "question mark"
set pronounce(\`) backquote 
set pronounce(\~) tilde 
set pronounce(<) "less than"
set pronounce(>) "greater than"
set tts(punct_pattern) [join [array names pronounce] "|\\"]

# }}}

# {{{ globals

#mbrola
set tts(pitch) 1.0
set tts(freq) 16384
set tts(volume) 2.0
set tts(speak) "/usr/lib/mbrola/tts-English/speakme"
#optional debuggin output
if {[info exists env(DTK_DEBUG)] } {
    set tts(debug) 1
} else {
    set tts(debug) 0
}

#flag to avoid multiple consecutive stops
set tts(not_stopped) 1
#split caps flag: 
set tts(split_caps) 1
# Capitalize flag
set tts(capitalize)  0
#allcaps beep flag
set tts(allcaps_beep)  0
set tts(talking?) 0
set tts(speech_rate) 425 
set tts(char_factor)  1.2
set tts(say_rate) [round \
                       [expr $tts(speech_rate) * $tts(char_factor)]]
set tts(q_head)  0
set tts(q_tail) 0
set tts(backup_head)  0
set tts(backup_tail) 0
set tts(punctuations) some
set queue(-1) ""
set backup(-1) ""
#play program for auditory icons
if {[info exists env(EMACSPEAK_PLAY_PROGRAM)] } {
    set tts(play)  $env(EMACSPEAK_PLAY_PROGRAM)
} else {
    set tts(play) "play"
}

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

#working around tcl 7.5
set tts(input) file0
if {[string match [info tclversion] 7.5]
    || [string match 8.0 [info tclversion]] } {
    if {[info exists server_p]} {
        set tts(input) sock0
    } else {
        set tts(input) file0
    }
}
#do not die if you see a control-c
signal ignore {sigint}

#Start the main command loop:
commandloop

# }}}
# {{{ Emacs local variables  

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

# }}}