# 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.12 2001/12/25 16:24:22 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
# pchablado.in - Interfacing Emacspeak to a Spanish PC Hablado -*-tcl-*-
#
# $Id: pchablado.in,v 1.0 1999/02/19 16:07:23 ofa Exp ofa $
#
# For any question of PC Hablado server contact with Oscar Fernandez
# <ofa@once.es>
# You can write in Spanish or English.
#
# {{{ 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.
#
# }}}

# {{{ procedures  

#   Return a 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

    return ""
}

proc silence_command  {{duration 50}} {
    
    return ""
}

# Return speech rate command
# Argument is desired rate in words per minute.
proc rate_command {r} {
    set rmin -100
    set rmax 100
    
    if {$r>$rmax} {set r [expr (($r-230)/2)-100]}	
    if {$r<$rmin} {set r $rmin}
    if {$r>$rmax} {set r $rmax}
    
    return "<* E VM$r *>" 
}

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

proc tts_initialize {} {
    global tts
    set tts(charmode) "<* S ON *>"
    set tts(stop) "\x9f"
    set tts(textmode) "<* S OFF *>"
    set tts(silencecmd) ""
    set tts(resetcmd) "<* D *>"
    set tts(somepunct) ""
    set tts(mark) "\x9d"
    set tts(flush) "\x9f"
    set tts(tone_440_10) ""
    set tts(tone_660_10) ""
    set tts(dennis) ""
    set tts(henry)  ""
    set tts(frank)  ""
    set tts(kit)    ""
    set tts(paul)   ""
    set tts(ursula) ""
    set tts(rita)   ""
    set tts(betty)  ""
    set tts(wendy)  ""
    set tts(version) "PC Hablado server from emacspeak-ss version 1.9.1"
    set tts(initstring) "<* D *>PC Hablado"
}

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

# }}}

# {{{ 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_speak {text} {
    q $text
    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

    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
}

# 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) 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) $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:

# }}}

