#!/usr/bin/tcl
# $Id$
# Description:  Interfacing to a Dectalk via TCL. 
# Keywords: Emacspeak, Dectalk, TCL
# {{{ LCD Entry: 

# LCD Archive Entry:
# emacspeak| T. V. Raman |raman@cs.cornell.edu 
# A speech interface to Emacs |
# $Date$ |
#  $Revision$ | 
# Location undetermined
#

# }}}
# {{{ Copyright:  
#Copyright (C) 1995 -- 2001, T. V. Raman 
# Copyright (c) 1995,   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.

# }}}
# {{{commandabbreviations 

#This version uses shortened dtk command strings to improve performance 
#when running remote sessions.
#These short-cuts are documented here to preserve ones sanity.
#:sa == :say
# c == clause 
# w == word
# le == letter 
#:to == :tone 
# :ra == :rate 
# :index == :i
# reply == r
# :punct == :pu
# a == all
# s == some

# }}}
# {{{ 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
    tts_gobble_acknowledgements 0.001
    set tts(not_stopped) 1
    set sync "\033P0;11z\033\\"
    puts -nonewline  $tts(write) "$text $sync\013"
    return ""
}

#formerly called tts_letter

proc l {text} {
    global tts
    set tts(not_stopped) 1
    set sync "\033P0;11z\033\\"
    set r $tts(speech_rate)
    set f  $tts(say_rate)
puts -nonewline  $tts(write)\
    "\[_]\[:ra $f] $text $sync"
        return ""
}

#formerly called tts_speak
proc d {} {
    speech_task
}

proc tts_resume  {} {
    global tts
    queue_restore
    if {[queue_empty?]} {
        puts -nonewline  $tts(write) "No speech to resume\013"
        set tts(not_stopped) 1
    } else {
        speech_task
    }
    return ""
}

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

#formerly called tts_stop 

proc s {} {
    global tts
    if {$tts(not_stopped)} {
        puts -nonewline  $tts(write) "\033P0;10z\033\\"
                  set tts(not_stopped) 0
        tts_gobble_acknowledgements
        set tts(talking?) 0
        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   $tts(read) input ] {} {} {}]
    set code ""
    if {[lsearch $status input]   >=0} {
        set tts(talking?) 0
    } else {
        set r $tts(read)
        while {[lsearch [select [list  $r] {} {} 0.1] $r] >= 0  } {
            append code [read $r  1]
        }
    }
    return $code
}

#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 {} {
    global tts
    s
    tts_gobble_acknowledgements
    set tts(not_stopped) 1
    puts -nonewline     $tts(write)  {]][:np]
        Restoring sanity to theMultivoice.
    }
}

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

# }}}
# {{{ 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]
    tts_gobble_acknowledgements
    puts -nonewline $tts(write) "\[:np :ra $r]"
    loop index 0 $length {
        set event   [queue_remove]
        set index  "\033P0;21;99z\033\\"
        set sync "\033P0;11z\033\\"
        set event_type [lindex $event 0]
        switch  -exact -- $event_type {
            s {
                set text [clean [lindex $event 1]]
                puts -nonewline  $tts(write) "$index $text\[_.]$sync\013"
                set retval [tts_get_acknowledgement ]
            }
            t {
                set text  [lindex $event 1]
                puts -nonewline  $tts(write) "\[_.]$text\[_.] "
            }
            a {
                set sound [lindex $event 1]
                catch "exec $tts(play) $sound >& /dev/null &" errCode
            }
            default {
            }
        }
        if {$tts(talking?) == 0} {break;} 
    }
    set tts(talking?) 0
    return ""
}

# }}}
# {{{ queue:

#preprocess element before sending it out:

proc clean {element} {
    global queue tts
    if {[string match all $tts(punctuations)] } {
        regsub -all {\#} $element \
            { pound } element
        regsub -all {\*} $element \
            { star } element
        regsub -all {\.,} $element \
            { dot comma [_,] } element
        regsub -all {\.\.\.} $element \
            { dot dot dot } element
        regsub -all {\.\.} $element \
            { dot dot } element
        regsub -all {[].,={}!$^_%&;()$+=/[-]} $element  { \0 }   element
        regsub -all {[0-9]+}  $element \
            { & } element
    } else {
        regsub -all {\.,} $element \
            {[_,]} element
        regsub -all {([0-9a-zA-Z])(["!;/:()=])+([0-9a-zA-z])} $element \
            {\1 \2 \3} element
regsub -all {([a-zA-Z])(,)+([a-zA-z])} $element \
            {\1 \2 \3} element
        regsub -all {([a-zA-Z])(\.)([a-zA-z])} $element \
            {\1[*]dot[*]\3} element
        regsub -all {``} $element {[_<1>/]} element
        regsub -all {''} $element {[_<1>\\]} element
        regsub -all { '}  $element {[_']} element
        regsub -all {' }  $element {[_']} element
        regsub -all --  {--} $element { [_,]} element
        regsub -all -- {-}  $element { } element 
    }
    if {$tts(capitalize) } {
        regsub -all {[A-Z]} $element {[_ :to 440 10]&} element
    }
    if {$tts(split_caps) } {
        if  {$tts(allcaps_beep)} {
            set tone {[_:to 660 10]}
            set abbrev_tone ":to 660 10"
        } else {
            set tone ""
            set abbrev_tone ""
        }
        set allcaps [regexp {[^a-zA-Z0-9]?([A-Z][A-Z0-9]+)[^a-zA-Z0-9]} $element full  match ]
        while {$allcaps } {
            if {[string length $match] <=3} {
                set abbrev "\[_ $abbrev_tone\]$match"
                regsub -all {[A-Z]} $abbrev {&[*]} abbrev
                regsub -all A $abbrev {[ey]} abbrev 
                regsub $match $element  $abbrev element
            } else {
                regsub $match $element "$tone[string tolower $match]"  element
            }
            set allcaps [regexp {[^a-zA-Z0-9]([A-Z][A-Z0-9]+)[^a-zA-Z0-9]} $element full  match ]
        }
        regsub -all {[A-Z]} $element {[_<5>]&} element
        regsub -all {([^ -_A-Z])([A-Z][a-zA-Z]* )} $element\
            {\1[_<1>]\2[,] } element
        regsub -all {([^ -_A-Z])([A-Z])} $element\
            {\1[:pause 1]\2} element
    }
    return $element
}

#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)} {
    puts -nonewline  $tts(write) "$tts(q_head) e\013"
    }
    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 "drip.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
    if {[queue_empty?]} {
set tts(backup_head) 0
    set tts(backup_tail) 0
        return
    }
    unset backup
    set backup(-1) ""
    set head [expr  max($tts(q_head) - 2, 0)]
    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
}

    # }}}
# {{{ globals

#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
#regexp for identifying solaris --should get smarter over time
set solaris_regexp {^SunOS[ a-zA-Z]+5\.[0-9].*  }
#first lets pick a default.
set machine Linux
#if env variable DTK_OS is set, use it;
if {[info exists env(DTK_OS)] } {
    set machine $env(DTK_OS)
} else {
    #Otherwise we'll try guessing.
    catch {set machine [exec uname ]}
    #regexp match to try recognizing solaris
    if {[regexp -nocase $solaris_regexp $machine]} {
        set machine solaris
    }
}
switch -exact  -- $machine {
    ULTRIX  -
    OSF1  {
        if {[info exists env(DTK_PORT)] } {
            set port $env(DTK_PORT)
        } else {
            set port /dev/tty00
        }
        set tts(read)  [open $port  r]
        set tts(write)  [open $port  w]
        #stty setting:
        exec stty sane 9600 raw  -echo < $port 
        exec stty ixon ixoff  <  $port 
    }
    solaris {
        if {[info exists env(DTK_PORT)] } {
            set port $env(DTK_PORT)
        } else {
            set port /dev/ttya
        }
        set tts(read)  [open $port  r]
        set tts(write)  [open $port  w]
        #stty setting:
        exec /usr/bin/stty sane 9600 raw  -echo < $port 
        exec /usr/bin/stty -echo <  $port 
        exec /usr/bin/stty ignpar <  $port 
        exec   /usr/bin/stty ixon ixoff <$port 
    }
    SunOS   {
        set machine sunos4
        if {[info exists env(DTK_PORT)] } {
            set port $env(DTK_PORT)
        } else {
            set port /dev/ttya
        }
        set tts(read)  [open $port  r]
        set tts(write)  [open $port  w]
        #stty setting:
        exec stty sane 9600 raw  -echo -echoe -echoke echoctl  > $port 
        exec stty ixon ixoff  >  $port 
    }
    Linux -
    default   {
        if {[info exists env(DTK_PORT)] } {
            set port $env(DTK_PORT)
        } else {
            set port /dev/ttyS0
        }
        set tts(read)  [open $port  r]
        set tts(write)  [open $port  w]
        #stty setting:
        exec stty sane 9600 raw  -echo <  $port 
        #linux wants the -echo done separately
        exec stty -echo <  $port 
        exec stty ixon ixoff  < $port 
    }
}

#set up the right kind of buffering:
fcntl $tts(read) nobuf 1
fcntl $tts(write) nobuf 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
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}
# gobble up garbage that is returned on powerup 
tts_gobble_acknowledgements

puts -nonewline     $tts(write)  {
    This is theMultivoice.
    [zhax<15> p'arl],
    [/dh`ow<100,140> ],  [:np] [  zhax<13>  suw<45>\iy<140,100>]. 
}

#Start the main command loop:
commandloop

# }}}
# {{{ Emacs local variables  

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

# }}}