#!/usr/bin/env /usr/bin/tcl
# accent - Emacspeak server code for Accent SA    -*-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.
# Modifications for Emacspeak-18+ 2005 by Gary Murphy garym@teledyn.com
#
# $Id$
#
# 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. 
# Copyright (c) 2005 by Gary Lawrence Murphy.
# 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 

# Emacspeak uses shortened dtk command strings to improve performance 
# 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

# }}}

# {{{source common code 
set wd [file dirname $argv0]
source $wd/tts-lib.tcl
# }}}

# {{{ beginning of Accent - specific functions

proc version {} {
    global tts
    tts_debug "version: $tts(version)"
    q { "this is $tts(version)" }
    d
}

proc tts_debug {msg} {
    global tts
    if {$tts(debug)} {
	puts  $tts(dfile) $msg
	flush $tts(dfile)
    }
}
#   Return a Accent SA 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
tts_debug "tone_command: $frequency $duration"
    if {[info exists env(DTK_BEEP)] } {
	    if { [ catch { exec "$env(DTK_BEEP) $frequency $duration" } oops ] } {
		# or ignore it
	    }
    } else {
	if {[info exists env(DTK_EXTRA_SOUNDS)] } {
	    tts_debug "using extra sounds"
	    set BASE "$env(EMACSPEAK_EXTRA_SOUNDS)"
	    if {$frequency ==440} {
		set SOUND "$BASE/beep_metal.wav"
	    } else {
		set SOUND "$BASE/generic.wav"
	    }
	    if { [ catch { exec "esdplay $SOUND" } oops ] } {
		# or ignore it
	    }
	}
    }
    #todo: accent has no tones
    #want to fake it
    return ""
}

proc silence_command  {{duration 50}} {
#todo: want to make silences.
#silence pauses not implemented by accent
#we make a space pause increase and space pause decrease for each 10
#duration
    set silence ""
    loop i 0 [expr duration/10] {
	append silence $tts(silencecmd_begin)
    }
    append silence " "
    loop i 0 [expr duration/10] {
	append silence "$tts(silencecmd_end)"
    }
    return silence
}

#helper function for rate_command
proc rate_command_initialize {} {
    global rate_command_initialized? 
    global rate_command_ranges
    #This variable gives the lower limits for each words per minute range.
    #if array(1)==100 and we have a value of 150, then 1 is the mapped speech
    #rate for accent.

    #Note for the accent, all speech rates slower than 8 are of no use because
    #there is not much difference and they are extremely slow.

    set rate_command_initialized? 1

    set rate_command_ranges(8) 60
    set rate_command_ranges(9) 100
    set rate_command_ranges(A) 140
    set rate_command_ranges(B) 180
    set rate_command_ranges(C) 230
    set rate_command_ranges(D) 280
    set rate_command_ranges(E) 330
    set rate_command_ranges(F) 380
    set rate_command_ranges(G) 480
    set rate_command_ranges(H) 530

    return ""
}

proc return_rate_command_range {r} {
    global rate_command_ranges
#    tts_debug "return_rate_command_range $r"

    foreach i {H G F E D C B A 9 8} {
	if {$rate_command_ranges($i)<=$r} {
	    return $i
	} 
    } 

    #the rate is lower than our lowest so we return our lowest
    return 0
}

# Return speech rate command for Accent.
# Argument is desired rate in words per minute.
proc rate_command {r} {
    global ESC rate_command_initialized?
#tts_debug "rate_command $r"
    if {${rate_command_initialized?} ==0} {
	rate_command_initialize
    }
    set retval [eval return_rate_command_range {$r}]
    return [format "${ESC}R%s" $retval]
}

# Return punctuation mode command for Accent
proc punctuation_command {} {
    global tts
    global ESC
#tts_debug "punctuation_command: $tts(punctuations)"
    set result $tts(nopunct)
    switch -exact -- $tts(punctuations) {
	all {
	    set result $tts(allpunct)
	}
	some {
	    set result $tts(somepunct)
	}
    }
    return $result
}

proc tts_initialize {} {
    global tts backup queue
    global rate_command_initialized?
    global ESC
    set tts(requires_poll) "0"
    # Accent defaults to 9600 n 7 1
    exec stty cs7 < $tts(port)
    set rate_command_initialized? 0
    #
    # Accent commands
    #
    set ACK "\006"
    set LF  "\012"
    set CR  "\015"
    set CANCEL "\030" 
    set ESC "\033"
    set tts(np) "${ESC}P5${ESC}V5"
    set tts(charmode) "${ESC}Ot"
    set tts(stop) "${CANCEL}"
#    set tts(stop) "${ESC}=x"
    set tts(textmode) "${ESC}OT"
    set tts(silencecmd_begin) "${ESC}+S"
    set tts(silencecmd_end) "${ESC}-S"
    set tts(reset) "${ESC}=R"
    set tts(resetcmd) "${ESC}=X"
    set tts(allpunct) "${ESC}OP${ESC}OR"
    set tts(somepunct) "${ESC}OP${ESC}Or"
    set tts(nopunct) "${ESC}Op"
    set tts(mark) "${ACK}"
    set tts(flush) "${CANCEL}"
    set tts(tone_440_10) [tone_command 440 10]
    set tts(tone_660_10) [tone_command 660 10]
    set tts(version) "accent server extended from emacspeak-ss version 1.9.1"
# "The initialization for the Screen-Review applications is recommended to be
#  <ESC>=F <ESC>=B <ESC>OA <ESC>M4 <ESC>=M <ESC>N1. " (Accent manual)
# note ${ESC}=R requires several seconds for self-diag, =X requires 100ms
# init tts-mode, xon/off
# =F CR triggers speech (=f for punct triggered)
# =B: fast-mode
# =m: no C-x to flush synth state, must use \e=x; =M to reverse
# =Y: "This command will enable Accent to automatically prompt each index
#      marker to the host via the RS-232C, when Accent has spoken to 
#      the position of each index marker." 
#      (no idea what that means, =y to disable )
# XY: C-f is index marker
# OM: - is dash
# OP Or some punctuation (Op for none)
# OA: A=a
# M4: not quite full intonation
# N1: Number processor
# S6: longer Space pause
# Tn: timeout
    set tts(initstring) \
	"${ESC}=A${ESC}=V${ESC}=F${ESC}=B${ESC}=M${ESC}=Y${ESC}YX${ESC}OM${ESC}OP${ESC}Or${ESC}OA${ESC}M4${ESC}N1${ESC}S6${ESC}T3"

# original init code from tts-lib:

    set tts(split_caps) 1
    set tts(capitalize)  0
    set tts(allcaps_beep)  0

    set tts(talking?) 0
    set tts(speech_rate) 60 
    set tts(char_factor)  1.2
    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) ""

    #flag to avoid multiple consecutive stops
    set tts(not_stopped) 1
}

# }}} end of Accent - specific functions

# {{{ procedures  

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

proc tts_set_speech_rate {rate} {
    global tts
tts_debug "tts_set_speech_rate $rate"
    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
tts_debug "tts_set_character_scale $factor"
    set tts(say_rate) [round [expr $tts(speech_rate) * $factor ]]
    set tts(char_factor) $factor
    return ""
}

proc tts_say {text} {
    global tts
tts_debug "tts_say '$text'"
    set tts(not_stopped) 1
    synth "$text"
    tts_gobble_acknowledgements
    return ""
}

# formerly called tts_letter

proc l {text} {
    global tts
tts_debug "l: '$text'"
    set tts(not_stopped) 1
    set ra [rate_command $tts(speech_rate)]
    tts_gobble_acknowledgements 0.001
    synth "$ra$tts(charmode)$text" ""
    return ""
}

# formerly called tts_speak
proc d {} {
tts_debug "d"
    speech_task
}

proc tts_speak {text} {
tts_debug "tts_speak '$text'"
    q $text
    speech_task
}

proc tts_resume  {} {
    global tts
#tts_debug "tts_resume"
    queue_restore
    if {[queue_empty?]} {
        synth "No speech to resume"
        set tts(not_stopped) 1
    } else {
        speech_task
    }
    return ""
}

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

proc tts_fastForward  {{step 1}} {
    global tts
#tts_debug "tts_fastForward: $step"
    if {[queue_empty?]} {
        synth "No speech to fast forward."
        set tts(not_stopped) 1
    } else {
        queue_advance ($step)
        speech_task
    }
    return ""
}

proc tts_fastRewind  {{step 1}} {
    global tts
#tts_debug "tts_fastRewind: $step"
    if {$tts(q_head) == 0} {
        synth "No speech to fast rewind."
        set tts(not_stopped) 1
    } else {
        queue_retreat ($step)
        speech_task
    }
    return ""
}

proc tts_repeat  {} {
    global tts
#tts_debug "tts_repeat"
    queue_rewind
    if {[queue_empty?]} {
        synth "No speech to repeat."
        set tts(not_stopped) 1
    } else {
        speech_task
    }
    return ""
}

# formerly called tts_stop 

proc s {} {
    global tts
tts_debug "s"
    if {$tts(not_stopped)} {
	set st $tts(stop)
	set tm $tts(textmode)
	set ra [rate_command $tts(speech_rate)]
    tts_debug "\t send stop" 
        synth "$st$ra$tm" ""
        set tts(not_stopped) 0
        set tts(talking?) 0
#    tts_debug "\t clear_queue" 
        queue_clear
        tts_gobble_acknowledgements
    }
}
# formerly called tts_tone

proc t {{pitch 440} {duration 50}} {
    global tts queue
tts_debug "t: $pitch $duration"
    set command [tone_command $pitch $duration]
    set queue($tts(q_tail)) [list t $command]
    incr tts(q_tail)
    if {$tts(midi)} {
        set inst 9
        set len .1
        set note [expr $pitch / 10]
        n $inst $note $len
    }
    return ""
}

proc sh {{duration 50}} {
    global tts queue
tts_debug "sh $duration"
    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 
#tts_debug "tts_split_caps $flag"
    set tts(split_caps) $flag
    return ""
}

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

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

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

proc tts_get_acknowledgement {} {
    global tts
#tts_debug "tts_get_acknowledgement"

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

    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]
        }
    }
#    tts_debug "\t ACK: $code" 
    return $code
}

# Gobble up any garbage the Dectalk has returned.

proc tts_gobble_acknowledgements {{delay 0.01}} {
    global tts
#tts_debug "tts_gobble_acknowledgements: $delay"
    set r $tts(read)
    while {[lsearch [select [list  $r] {} {} 0.001] $r] >= 0  } {
        read $r  1
    }
}
    
proc tts_reset {} {
    global tts
tts_debug "tts_reset"
    set tts(not_stopped) 0
    synth $tts(resetcmd) ""
    after 100
}

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

# }}}
# {{{ speech task 

proc synth {{msg ""} {fl "\015"}} {
    global tts 
tts_debug "synth: '$msg'$fl"
    puts -nonewline $tts(write) "$msg$fl"
}

proc speech_task {} {
    global queue tts
tts_debug "SPEECH_TASK"
    set tts(talking?) 1
    set tts(not_stopped) 1
    set np $tts(np)
    set ra [rate_command $tts(speech_rate)]
    set pu [punctuation_command]
    synth "$tts(textmode)$np$ra$pu" ""
    set length [queue_length]
    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]]
                synth "$tts(mark)$text"
                set retval [tts_get_acknowledgement ]
            }
            t {
                set text [fixtone [lindex $event 1]]
                synth "$tts(mark)$text"
                set retval [tts_get_acknowledgement ]
            }
            a {
                set sound [lindex $event 1]
                catch "exec $tts(play) $sound >& /dev/null &" errCode
            }
	    b {
		if ($tts(beep)) {
		    lvarpop event
		    eval beep $event
		}
	    }
            n {
                if {$tts(midi)} {
                    lvarpop event 
                    catch {eval note $event} err 
                }
            }
        }
#        if {$tts(talking?) == 0} {break;} 
    }
    set tts(talking?) 0
    tts_gobble_acknowledgements
    return ""
}

# }}}
# {{{ clean

# preprocess element before sending it out:

proc clean {element} {
    global queue tts
tts_debug "clean: $element"
    if {[string match all $tts(punctuations)] } {
	regsub -all {@} $element               { at } element
        regsub -all {\#} $element           { pound } element
        regsub -all {~} $element            { tilda } element
        regsub -all {\\} $element       { backslash } 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
    tts_debug "\t punct: $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 
    tts_debug "\t not punct: $element"
    }
    if {$tts(capitalize) } {
	regsub -all {[A-Z]} $element "$tts(tone_440_10)" element
#	regsub -all {[A-Z]} $element "$tts(tone_440_10)&" element
    tts_debug "\t Caps: $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 ""
        }
    tts_debug "\t Split: $element"
        set allcaps [regexp {[^a-zA-Z0-9\e]?([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
#	    regsub $match $element "$tone$match"  element
#            }
#            set allcaps [regexp {[^a-zA-Z0-9\e]([A-Z][A-Z0-9]+)[^a-zA-Z0-9]} $element full  match ]
#    tts_debug "\t allcaps: $element"
#        }
#        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
    }
    tts_debug "\t returns: $element"
    return $element
}

proc dv {parms} {
    global tts
    tts_debug "dv: $parms"
    return ""
}

# rewrite DECtalk tone commands for the speech device
proc fixtone {element} {
    global queue tts
tts_debug "fixtone: $element"
    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
}

# }}}

# {{{ globals

# set the machine and I/O port

# }}}

# {{{ Initialize and set state.

    #play program
    if {[info exists env(EMACSPEAK_PLAY_PROGRAM)] } {
        set tts(play)  $env(EMACSPEAK_PLAY_PROGRAM)
    } else {
        set tts(play) "play"
    }
    
    #optional debuggin output
    if {[info exists env(DTK_DEBUG)] } {
	set tts(dfile) [open "accent.log" w]
	fcntl $tts(dfile) nobuf 1
        set tts(debug) 1
    } else {
        set tts(debug) 0
    }
    
tts_setserial
tts_initialize

notes_initialize
set tts(input) file0
if {[info exists server_p]} {
    set tts(input) sock0
}

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

# gobble up garbage that is returned on powerup 
tts_gobble_acknowledgements

synth $tts(resetcmd) ""
after 100
synth $tts(initstring) ""

tts_debug "BEGIN command loop"
# Start the main command loop:
commandloop

# }}}
# {{{ Emacs local variables  

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

# }}}

