emacspeak-ss 1.12.1-6 / usr / share / emacs / site-lisp / emacspeak / servers / doubletalk

#!/usr/bin/tclsh
package require Tclx
# all.in - Generic Emacspeak server code    -*-tcl-*-
# Keywords: Emacspeak, TCL, speech, server
#
# Original program by T. V. Raman. 
# Modifications to make generic copyright 1998 by James R. Van Zandt
# <jrv@vanzandt.mv.com>, all rights reserved.
#
# $Id: all.in,v 1.19 2007/03/23 00:14:24 jrv Exp jrv $
#
# Copyright (c) 1995, 1996, 1997 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.

# 
# command abbreviations 

# 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

# }}}

# Fetch the device-specific code
# doubletalk.in - DoubleTalk specific Emacspeak server code    -*-tcl-*-
#
#   $Id: doubletalk.in,v 1.10 2006/02/09 00:15:35 jrv Exp jrv $
#
# {{{ Copyright:  
#
#   This software is Copyright 1998 James R. Van Zandt, all rights reserved
#
#   This program 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; version 2 dated
#   June, 1991, or any later version.
#
#   This program 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 this program;  if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston,
#   MA 02111-1307, USA.
#
# }}}

# {{{ beginning of DoubleTalk - specific functions

proc version {} {
    global tts
    q {this is $tts(device_version)  }
    d
}

#   Return a DoubleTalk command string to generate a tone with the
#   specified frequency (in Hz) and duration (in msec).

proc tone_command {{frequency 440} {duration 50}} {
    global tts queue

# early versions did not implement tones 
    if [expr $tts(has_sine_tones) == 0] return ""

    # express duration in sec 
    set duration [expr $duration*.001]

#   The DoubleTalk tone generator is controlled by the three
# parameters n, Kd, and K1.  The frequency of the tone in Hz is
# K1*603/(155-n), and the duration in seconds is Kd*(155-n)*.256/617.
# The three parameters are subject to these constraints: 1 <= n <= 99,
# 1 <= K1 <= 255, and 1 <= Kd <= 255.  These permit frequencies up to
# 2746 Hz and durations from 23 msec to 16.29 sec.  Here, we use 'tau'
# to stand for (155-n).

    # first priority: hardware limits
    set taumin 56
    set taumax 154

    # second priority: reach specified frequency
    # (provided the above limits are respected)
    set taumin [max $taumin [min [expr 603./$frequency] $taumax]]
    set taumax [min $taumax [max [expr 255*603./$frequency] $taumin]]

    # third priority: reach specified duration
    # (provided the above limits are respected)
    set taumin [max $taumin [min [expr 617.*$duration/.256/255] $taumax]]
    set taumax [min $taumax [max [expr 617.*$duration/.256] $taumin]]

    if {$taumin == $taumax} {
	set tau $taumin
	set K1 [min 255 [max 1 [int [expr $tau*$frequency/603.+.5]]]]
    } else {

##   Find good values of tau and K1.  K1/tau should approximate
## frequency/603.  We express the latter as a continued fraction, and (if
## possible) use one of its approximates.  In other words, we express
## frequency/603 in the form t0 + 1/(t1 + 1/(t2 + 1/(t3 + ...))) where ti
## is an integer.  To form an approximate of this continued fraction, we
## ignore everything after one of the '+' signs, and reduce to a regular
## fraction.  The more terms we include, the more accurate the
## approximate is.  For example, pi = 3 + 1/(7 + 1/(15 + 1/(1 + 1/(293 +
## ...)))).  The first four approximates are: 3, 22/7, 333/106, and
## 355/113.
## 
##    An approximate is accurate to about the same number of digits as it
## has.  The last approximate shown above for pi is accurate to 7 decimal
## places.  Our numerator and denominator can have 8 bits, so we can hope
## for about 16 bits of accuracy, or almost 5 decimal digits.  We can't
## really do this well, since tau is always restricted to the interval
## 56...154, and sometimes a much smaller interval.
## 
##    Here, we use a recurrence relation which lets us calculate
## successive approximates in the forward direction. 

	set ratio [expr $frequency/603.]

	if {$ratio > 1.} {
	    set num0 1
	    set den0 0
	    # num1/den1 is the first approximate
	    set num1 [floor $ratio]
	    set den1 1
	    set ratio [expr $ratio-$num1]
	} else {
	    set num0 0
	    set den0 1
	    set ratio [expr 1./$ratio]
	    # num1/den1 is the first approximate
	    set num1 1
	    set den1 [floor $ratio]
	    set ratio [expr $ratio-$den1]
	}
	while {$ratio > 0} {
	    set ratio [expr 1./$ratio]
	    if {$ratio > 1000.} break
	    set term [floor $ratio]
	    set ratio [expr $ratio-$term]
	    set num2 [expr $num0+$num1*$term]
	    set den2 [expr $den0 + $den1*$term]
	    if {$num2 > 255} break
	    if {$den2 > $taumax} break;
	    set num0 $num1
	    set num1 $num2
	    set den0 $den1
	    set den1 $den2
	}
	if {$den1 < $taumin} {
	    set scale [ceil [expr $taumin*1./$den1]]
	    set num1 [expr $num1*$scale]
	    set den1 [expr $den1*$scale]
	}
	if {$den1 > $taumax} {
				# There was no approximate whose
				# denominator, nor an integer
				# multiple of one, is in the allowed
				# range.  We fall back on a simpler
				# approximation.
	    set tau [expr ($taumin+$taumax)/2.]
	    set K1 [int [expr $frequency*$tau/603.+.5]]
	} else {
	    set K1 [max 1 [min 255 [int [expr $num1+.5]]]]
	    set tau [max $taumin [min $taumax $den1]]
	}
    }
    set n [int [expr 155.5-$tau]]
    set Kd [max 1 [min 255 [int [expr 617*$duration/$tau/.256 + .5]]]]

    # The DoubleTalk can generate a second simultaneous sine wave with
    # frequency determined by K2.  K2=0 would disable the second
    # source.  However, we cannot set K2=0 since the null byte would
    # terminate the string.  Instead, we make both the same.
    set K2 $K1
#
# The first is easier to read, but the second is the correct command string
#    return [format "\\1 %dJ %o %o %o" $n $Kd $K1 $K2]
    return [format "\1%dJ%c%c%c\r" $n $Kd $K1 $K2]
}

# Return silence command
# Argument is desired pause in msec
proc silence_command  {{duration 50}} {
    set silence ""
    loop i 0 [expr duration/10] {
	append silence "$tts(silencecmd)"
    }
    return silence
}

# Return speech rate command
# Argument is desired rate in words per minute.
# measured speaking rates are as follows:
# DoubleTalk PC, max rate (code=9): 480 words/78 sec = 370 wpm
# DoubleTalk LT, max rate (code=9): 490 words/80 sec = 367 wpm
# 
# measurements are with punctuation=none.
# 
proc rate_command {r} {
    set rmin 100
    set rmax 236
    if {$r<$rmin} {set r $rmin}
    if {$r>$rmax} {set r $rmax}
    set index [int [floor [expr .5+($r-$rmin)*9/($rmax-$rmin)]]]
    return [format "\1%dS" $index]
}

# Return punctuation mode command
proc punctuation_command {} {
    global tts
    set mode  $tts(punctuations) 
    set punctuation(all) 5
    set punctuation(some) 5
    set punctuation(none) 7
    return "\001$punctuation($mode)B"
}

proc tts_initialize {} {
    global tts env
				# interrogate the DoubleTalk
    if {[info exists env(DTK_PORT)] } {
	set port  $env(DTK_PORT)
    } else {
    	set port ""
    }
    if {[regexp {dev/dtlk} $port]} {
	set version "5.20"
#	echo "internal doubletalk at $port is assumed to be version $version"
    } else {
	set r $tts(read)
	while {[lsearch [select [list  $r] {} {} 0.1] $r] >= 0  } {
	    read $r  1
	}
	puts -nonewline  $tts(write) "\001?"
	set status ""
	while {[lsearch [select [list  $r] {} {} 0.1] $r] >= 0  } {
	    append status [read $r  1]
	}
	set version $status
	echo "doubletalk status report is $version"
	regsub {^..} $version "" version
	regsub {^([0-9\.]*).*$} $version {\1} version
    }
    set tts(device_version) $version
    echo "the DoubleTalk is version $version"
    set tts(has_sine_tones) [expr $version+0 >= 4.20]
#    echo "has_sine_tones=$tts(has_sine_tones)"

# DoubleTalk commands
    set tts(charmode) "\0015C"
    set tts(stop) "\030"
				# FIXME what standard interword pause?
    set tts(textmode) "\0015T"
    set tts(textmode) "\0010T"
    set tts(silencecmd) "\00116*"
    set tts(resetcmd) "\001@"
    set tts(somepunct) "\0015B"
    set tts(mark) "\00176I"
    set tts(flush) "\r"
    set tts(tone_440_10) [tone_command 440 10]
    set tts(tone_660_10) [tone_command 660 10]
    set tts(paul) "\0010O"
    set tts(henry) "\0011O"
    set tts(dennis) "\0012O"
    set tts(frank) "\0013O"
    set tts(betty) "\0014O"
    set tts(ursula) "\0010O\00175P"
    set tts(rita) "\0011O\00175P"
    set tts(wendy) "\0012O\00175P"
    set tts(kit) "\0013O\00175P"
    set tts(version) [format "doubletalk with ROM version %s, doubletalk server from emacspeak-ss version 1.12.1" $tts(device_version) ]
    set tts(initstring) "\001@\
\0010T\
\0010Y\
\0015B\
\0015S\
This is the DoubleTalk speech server for Emacspeak.\
speakers report\r\
\00116*\0010T\r\
\0010O Paul \r\
\00116*\
\0011O Vader\r\
\00116*\0010T\r\
\0012O Bob\r\
\00116*\0010T\r\
\0013O Pete\r\
\00116*\0010T\r\
\0014O Larry\r\
\00116*\0010T\r\
\0010O \r\n"
}

# }}} end of DoubleTalk - specific functions


# {{{ Emacs local variables  

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

# }}}

# {{{ These are wrappers which accommodate versions of emacspeak before 8.0

proc dectalk_set_punctuations {mode} {
    tts_set_punctuations $mode
    return ""
}

proc dectalk_set_speech_rate {rate} {
    tts_set_speech_rate $rate
    return ""
}

proc dectalk_set_character_scale {factor} {
    tts_set_character_scale $factor
    return ""
}

proc dectalk_say {text} {
    tts_say $text
    return ""
}

proc dectalk_speak {text} {
    tts_speak $text
    return ""
}

proc dectalk_resume  {} {
    tts_resume
    return ""
}

proc dectalk_pause {} {
    tts_pause
    return ""
}

proc dectalk_split_caps {flag} {
    tts_split_caps $flag
    return ""
}

proc dectalk_capitalize {flag} {
    tts_capitalize $flag
    return ""
}

proc dectalk_allcaps_beep {flag} {
    tts_allcaps_beep $flag
    return ""
}

proc dectalk_reset {} {
    tts_reset
}

# this was replaced by d in version 12.0
proc tts_speak {text} {
    q $text
    speech_task
}

# }}}

# {{{ These are the current functions

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
    regsub -all {\[:version speak\]} $text $tts(version)  text
    set tts(not_stopped) 1
    set fl $tts(flush)
    puts -nonewline  $tts(write)\
	    "$text$fl"
#        "\[_]\[:sa w]$text "
        tts_gobble_acknowledgements
    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)
    set ra [rate_command $tts(say_rate)]
    tts_gobble_acknowledgements 0.001
    puts -nonewline  $tts(write)\
	    "$tts(charmode)$text\r"
#    "\[_]\[:ra $f :sa le]$text"
        return ""
}

# formerly called tts_speak
proc d {} {
    speech_task
}

proc tts_resume  {} {
    global tts
    queue_restore
    if {[queue_empty?]} {
	set fl $tts(flush)
        puts -nonewline  $tts(write) "No speech to resume$fl"
        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)} {
	set st $tts(stop)
	set tm $tts(textmode)
	set ra [rate_command $tts(speech_rate)]
        puts -nonewline  $tts(write)  "$st$ra$tm"
        set tts(not_stopped) 0
#        select [list $tts(read)] {} {} {}
#        read  $tts(read) 1
        set tts(talking?) 0
        queue_clear
        #tts_gobble_acknowledgements
    }
}
# formerly called tts_tone

proc t {{frequency 440} {duration 50}} {
    global tts queue

    set command [tone_command $frequency $duration]

    set queue($tts(q_tail)) [list t $command]
    incr tts(q_tail)
    return ""
}

proc sh {{duration 50}} {
    global tts queue
    set silence [silence_command 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
}

proc tts_get_acknowledgement {} {
    global tts

    if {$tts(requires_poll)} {
	return [tts_poll]
    }

# echo "   entering tts_get_acknowledgement"
# 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
    set input $tts(input)
# wait until either emacs or synthesizer write something
    set status [select [list   $tts(read) $input ] {} {} {}]
# echo "   status=$status"
    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]
        }
    }
# echo "   leaving tts_get_acknowledgement"
    return $code
}

# Gobble up any garbage the Dectalk has returned.

proc tts_gobble_acknowledgements {{delay 0.01}} {
    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) \
    "$tts(resetcmd) Restoring sanity to the speech device.\r"
}

# queue a rate command
proc r {rate} {
    global queue  tts
    set rate [rate_command $tts(speech_rate)]
    set queue($tts(q_tail)) [list s  $rate]
    incr tts(q_tail)
    return ""
}

# }}}
# {{{ speech task 

proc speech_task {} {
    global queue tts
    set tts(talking?) 1
    set tts(not_stopped) 1
    set np $tts(paul)
    set ra [rate_command $tts(speech_rate)]
    set length [queue_length]
    tts_gobble_acknowledgements
    set pu [punctuation_command]

    puts -nonewline $tts(write) \
	    "$tts(textmode)$np$ra$pu"
# "\[_]\[:sa c]\[:np]\[:ra $r]\[:pu $mode]" 
    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]]
                puts -nonewline  $tts(write) \
			"$tts(mark)$text$tts(flush)"
# "\[:i r 1]$text\[_.]\013"
                set retval [tts_get_acknowledgement ]
            }
            t {
                set text [fixtone [lindex $event 1]]
                puts -nonewline  $tts(write) "$tts(mark)$text"
# "\[_.]$text\[_.] "
                set retval [tts_get_acknowledgement ]
            }
            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 \
		{ at } element
        regsub -all {\#} $element \
            { pound } element
        regsub -all {\*} $element \
            { star } element
        regsub -all  {[%&;()$+=/]} $element  { \0 }   element
        regsub -all {\.,} $element \
            { dot comma } element
        regsub -all {\.\.\.} $element \
            { dot dot dot } element
        regsub -all {\.\.} $element \
            { dot dot } element
        regsub -all {([a-zA-Z])\.([a-zA-Z])} $element \
            {\1 dot \2} element
        regsub -all {[0-9]+} $element { & } element
    } else {
	if {[string match some $tts(punctuations)] } {
	    regsub -all {@} $element \
		    { at } element
	} else {
	    regsub -all {@} $element \
		    { } element
	}
        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 "$tts(tone_440_10)&" element
# {[_ :to 440 10]&} element
    }
    if {$tts(split_caps) } {
        if  {$tts(allcaps_beep)} {
            set tone "$tts(tone_660_10)"
            set abbrev_tone "$tts(tone_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
    }

# substitute for voice commands
# the first substitution is a special case for indentation in tcl-mode
    regsub -all {\[:np :dv  sm  40  ri  40   hr  7   sr  10  \]} $element \
	    $tts(henry)  element
#                                        $tts(betty)  element
    regsub -all {\[:np[^]]*\]} $element $tts(paul) element
    regsub -all {\[:nh[^]]*\]} $element $tts(henry)  element
    regsub -all {\[:nd[^]]*\]} $element $tts(dennis)  element
    regsub -all {\[:nf[^]]*\]} $element $tts(frank)  element
    regsub -all {\[:nb[^]]*\]} $element $tts(betty)  element
    regsub -all {\[:nu[^]]*\]} $element $tts(ursula)  element
    regsub -all {\[:nr[^]]*\]} $element $tts(rita)  element
    regsub -all {\[:nw[^]]*\]} $element $tts(wendy)  element
    regsub -all {\[:nk[^]]*\]} $element $tts(kit)  element
    regsub -all {\[:n[^]]*\]}  $element $tts(paul) element
# map any unrecognized voice to Dennis
    regsub -all {\[ :dv[^]]*\]}  $element $tts(dennis) element

    return $element
}

# rewrite DECtalk tone commands for the speech device
proc fixtone {element} {
    global queue tts
    while {[regexp {\[:to ([0-9]+) ([0-9]+)]} $element match freq duration]} {
	set cmd [tone_command $freq $duration]
	regsub {\[:to ([0-9]+) ([0-9]+)]} $element $cmd element
    }
    return $element
}

proc tts_sync_state {punct capitalize allcaps splitcaps rate} {
    tts_set_punctuations  $punct
    tts_capitalize  $capitalize
    tts_allcaps_beep  $allcaps
    tts_split_caps   $splitcaps
    tts_set_speech_rate  $rate
}

# 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 env
    set queue($tts(q_tail)) [list s $element]
    incr tts(q_tail)
    set mod [expr ($tts(q_tail) - $tts(q_head)) % 50]
    if {[info exists env(EMACSPEAK_DIR)] } {
       set sound "$env(EMACSPEAK_DIR)/sounds/drip.au"
    } else {
       set sound "drip.au"
    }
    if {$mod == 0} {
	set tone [tone_command 500 20]
        puts -nonewline     $tts(write)    "$tone$tty(flush)"
        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
}

    # }}}

# {{{self test 

proc tts_selftest {} {
     loop i 1 10 {
	 q "This is test $i. "
     }
     d
}

# }}}
# {{{guessing os   and port 

proc which_os {} {
    global env
    #if env variable DTK_OS is set, use it;
    if {[info exists env(DTK_OS)] } {
	return  $env(DTK_OS)
    } 
    set machine [exec uname -a]
    #os hostname version 
    set fields [split $machine ]
    set os [lindex $fields 0]
    set host [lindex $fields 1]
    set version [lindex $fields 2]    
    switch -exact  -- $os {
	ULTRIX  -
	OSF1  {return DEC}
	SunOS {
	    #are we  solaris
	    if {[string match 5.* $version] }  {
		return Solaris
	    } else    {
		#we are sunos 4
		return SunOS
	    }
	}
	Linux -
	default    {
	    return Linux
	}
    }
}

proc which_port {{os Linux}} {
    global env
    if {[info exists env(DTK_PORT)] } {
	set port $env(DTK_PORT)
	puts stdout "Set port to $port"
    } else {
	switch -exact  -- $os {
	    DEC {
		set port /dev/tty00
	    }
	    SunOS -
	    Solaris -
	    solaris {
		set port /dev/ttya
	    } 
	    Linux -
	    default {
		set port /dev/ttyS0
	    }
	}
    }
    return $port
}

# }}}

# {{{ globals

# optional debugging 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

# set the machine and I/O port
set machine [which_os]
set port [which_port $machine]
set tts(port) $port

set tts(read)  [open $port  r]
set tts(write)  [open $port  w]

#set up stty settings 
switch -exact  -- $machine {
    DEC { #osf and ultrix
        exec stty sane 9600 raw  -echo < $port 
        exec stty ixon ixoff  <  $port 
    }
    solaris -
    Solaris {
        exec /usr/bin/stty sane 9600 raw  < $port 
        exec /usr/bin/stty -echo <  $port 
        exec /usr/bin/stty ignpar <  $port 
        exec   /usr/bin/stty ixon ixoff < $port 
    }
    SunOS   {
        exec stty sane 9600 raw  -echo -echoe -echoke echoctl  > $port 
        exec stty ixon ixoff  >  $port 
    }
    Linux -
    default   {
	if {[expr ![regexp /dev/dtlk.* $port]]} {
          exec stty sane 9600 raw  -echo crtscts <  $port 
          exec stty -echo <  $port 
          exec stty ixon ixoff  < $port 
	}
    }
}

if {$tts(debug)} {
    set tts(dfile) [open "log.debug" w]
    fcntl $tts(dfile) nobuf 1
}

# 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"
}

# }}}

set tts(requires_poll) "0"

tts_initialize

# {{{ Initialize and set state.

# working around tcl 7.5
set tts(input) stdin
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) stdin
    }
}

# 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) $tts(initstring)

# Start the main command loop:
commandloop

# }}}
# {{{ Emacs local variables  

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

# }}}