561 lines
20 KiB
Scheme
561 lines
20 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;
|
|
;;; Centre for Speech Technology Research ;;
|
|
;;; University of Edinburgh, UK ;;
|
|
;;; Copyright (c) 1998 ;;
|
|
;;; All Rights Reserved. ;;
|
|
;;; ;;
|
|
;;; Permission is hereby granted, free of charge, to use and distribute ;;
|
|
;;; this software and its documentation without restriction, including ;;
|
|
;;; without limitation the rights to use, copy, modify, merge, publish, ;;
|
|
;;; distribute, sublicense, and/or sell copies of this work, and to ;;
|
|
;;; permit persons to whom this work is furnished to do so, subject to ;;
|
|
;;; the following conditions: ;;
|
|
;;; 1. The code must retain the above copyright notice, this list of ;;
|
|
;;; conditions and the following disclaimer. ;;
|
|
;;; 2. Any modifications must be clearly marked as such. ;;
|
|
;;; 3. Original authors' names are not deleted. ;;
|
|
;;; 4. The authors' names are not used to endorse or promote products ;;
|
|
;;; derived from this software without specific prior written ;;
|
|
;;; permission. ;;
|
|
;;; ;;
|
|
;;; THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK ;;
|
|
;;; DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;
|
|
;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT ;;
|
|
;;; SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE ;;
|
|
;;; FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES ;;
|
|
;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN ;;
|
|
;;; AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;
|
|
;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF ;;
|
|
;;; THIS SOFTWARE. ;;
|
|
;;; ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;
|
|
;;; Festival (1.3.X) support for SABLE 0.2 the SGML/XML based mark up ;;
|
|
;;; language. ;;
|
|
;;; ;;
|
|
;;; This is XML version requiring Edinburgh's LTG's rxp XML parser as ;;
|
|
;;; distributed with Festival ;;
|
|
;;; ;;
|
|
|
|
(require_module 'rxp)
|
|
|
|
;;(set! auto-text-mode-alist
|
|
;; (cons
|
|
;; (cons "\\.sable$" 'sable)
|
|
;; auto-text-mode-alist))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; ;;
|
|
;; Remember where to find these two XML entities. ;;
|
|
;; ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(xml_register_id "-//SABLE//DTD SABLE speech mark up//EN"
|
|
(path-append libdir "Sable.v0_2.dtd")
|
|
)
|
|
|
|
(xml_register_id "-//SABLE//ENTITIES Added Latin 1 for SABLE//EN"
|
|
(path-append libdir "sable-latin.ent")
|
|
)
|
|
|
|
;; (print (xml_registered_ids))
|
|
|
|
(defvar SABLE_RXDOUBLE "-?\\(\\([0-9]+\\.[0-9]*\\)\\|\\([0-9]+\\)\\|\\(\\.[0-9]+\\)\\)\\([eE][---+]?[0-9]+\\)?")
|
|
|
|
(defvar sable_pitch_base_map
|
|
'((highest 1.2)
|
|
(high 1.1)
|
|
(medium 1.0)
|
|
(default 1.0)
|
|
(low 0.9)
|
|
(lowest 0.8)))
|
|
(defvar sable_pitch_med_map
|
|
'((highest 1.2)
|
|
(high 1.1)
|
|
(medium 1.0)
|
|
(default 1.0)
|
|
(low 0.9)
|
|
(lowest 0.8)))
|
|
(defvar sable_pitch_range_map
|
|
'((largest 1.2)
|
|
(large 1.1)
|
|
(medium 1.0)
|
|
(default 1.0)
|
|
(small 0.9)
|
|
(smallest 0.8)))
|
|
(defvar sable_rate_speed_map
|
|
'((fastest 1.5)
|
|
(fast 1.2)
|
|
(medium 1.0)
|
|
(default 1.0)
|
|
(slow 0.8)
|
|
(slowest 0.6)))
|
|
(defvar sable_volume_level_map
|
|
'((loudest 2.0)
|
|
(loud 1.5)
|
|
(default 1.0)
|
|
(medium 1.0)
|
|
(quiet 0.5)))
|
|
|
|
(define (sable_init_globals)
|
|
(set! utts nil)
|
|
(set! sable_omitted_mode nil)
|
|
(set! sable_word_features_stack nil)
|
|
(set! sable_pitch_context nil)
|
|
(set! sable_vol_context nil)
|
|
(set! sable_vol_type 'no_change)
|
|
(set! sable_vol_factor 1.0)
|
|
(set! sable_current_language 'britishenglish)
|
|
(set! sable_unsupported_language nil)
|
|
(set! sable_language_stack nil)
|
|
(set! sable_current_speaker 'voice_kal_diphone)
|
|
(set! sable_speaker_stack nil)
|
|
)
|
|
|
|
(define (sable_token_to_words token name)
|
|
"(sable_token_to_words utt token name)
|
|
SABLE mode token specific analysis."
|
|
(cond
|
|
((or sable_omitted_mode sable_unsupported_language)
|
|
;; don't say anything (whole utterance)
|
|
nil)
|
|
((string-equal "1" (item.feat token "done_sable_sub"))
|
|
;; to catch recursive calls this when splitting up sub expressions
|
|
(sable_previous_token_to_words token name))
|
|
((and (not (string-equal "0" (item.feat token "sable_sub")))
|
|
(string-equal "0" (item.feat token "p.sable_sub")))
|
|
(let (words (sub (item.feat token "sable_sub")))
|
|
(item.set_feat token "done_sable_sub" "1")
|
|
(set! words
|
|
(apply append
|
|
(mapcar
|
|
(lambda (w)
|
|
(set! www (sable_previous_token_to_words token w))
|
|
www)
|
|
(read-from-string sub))))
|
|
(item.set_feat token "done_sable_sub" "0")
|
|
words))
|
|
((string-equal "1" (item.feat token "sable_ignore"))
|
|
;; don't say anything (individual word)
|
|
nil)
|
|
((string-equal "1" (item.feat token "sable_ipa"))
|
|
;; Each token is an IPA phone
|
|
(item.set_feat token "phonemes" (sable-map-ipa name))
|
|
(list name))
|
|
((string-equal "1" (item.feat token "sable_literal"))
|
|
;; Only deal with spell here
|
|
(let ((subwords) (subword))
|
|
(item.set_feat token "pos" token.letter_pos)
|
|
(mapcar
|
|
(lambda (letter)
|
|
;; might be symbols or digits
|
|
(set! subword (sable_previous_token_to_words token letter))
|
|
(if subwords
|
|
(set! subwords (append subwords subword))
|
|
(set! subwords subword)))
|
|
(symbolexplode name))
|
|
subwords))
|
|
((not (string-equal "0" (item.feat token "token_pos")))
|
|
;; bypass the prediction stage, if English
|
|
(if (member_string (Parameter.get 'Language)
|
|
'(britishenglish americanenglish))
|
|
(builtin_english_token_to_words token name)
|
|
(sable_previous_token_to_words token name)))
|
|
;; could be others here later
|
|
(t
|
|
(sable_previous_token_to_words token name))))
|
|
|
|
(defvar sable_elements
|
|
'(
|
|
("(SABLE" (ATTLIST UTT)
|
|
(eval (list sable_current_speaker)) ;; so we know what state we start in
|
|
(sable_setup_voice_params)
|
|
nil
|
|
)
|
|
(")SABLE" (ATTLIST UTT)
|
|
(xxml_synth UTT) ;; Synthesis the remaining tokens
|
|
nil
|
|
)
|
|
;; Utterance break elements
|
|
("(LANGUAGE" (ATTLIST UTT)
|
|
;; Status: probably complete
|
|
(xxml_synth UTT)
|
|
(set! sable_language_stack
|
|
(cons
|
|
(list sable_current_language sable_unsupported_language)
|
|
sable_language_stack))
|
|
;; Select a new language
|
|
(let ((language (upcase (car (xxml_attval "ID" ATTLIST)))))
|
|
(cond
|
|
((or (string-equal language "SPANISH")
|
|
(string-equal language "ES"))
|
|
(set! sable_current_language 'spanish)
|
|
(set! sable_unsupported_language nil)
|
|
(select_language 'spanish))
|
|
((or (string-equal language "ENGLISH")
|
|
(string-equal language "EN"))
|
|
(set! sable_current_language 'britishenglish)
|
|
(set! sable_unsupported_language nil)
|
|
(select_language 'britishenglish))
|
|
(t ;; skip languages you don't know
|
|
;; BUG: if current language isn't English this wont work
|
|
(apply_hooks tts_hooks
|
|
(eval (list 'Utterance 'Text
|
|
(string-append "Some text in " language))))
|
|
(set! sable_unsupported_language t)))
|
|
nil))
|
|
(")LANGUAGE" (ATTLIST UTT)
|
|
(xxml_synth UTT)
|
|
(set! sable_unsupported_language (car (cdr (car sable_language_stack))))
|
|
(set! sable_current_language (car (car sable_language_stack)))
|
|
(set! sable_language_stack (cdr sable_language_stack))
|
|
(if (not sable_omitted_mode)
|
|
(begin
|
|
(select_language sable_current_language)
|
|
(sable_setup_voice_params)))
|
|
nil)
|
|
("(SPEAKER" (ATTLIST UTT)
|
|
;; Status: GENDER/AGE ignored, should be done by sable-def-speaker
|
|
;; function to define Festival voices to SABLE
|
|
(xxml_synth UTT)
|
|
(set! sable_speaker_stack (cons sable_current_speaker sable_speaker_stack))
|
|
(cond
|
|
((not equal? sable_current_language 'britishenglish)
|
|
(print "SABLE: choosen unknown voice, current voice unchanged"))
|
|
((equal? (car (xxml_attval "NAME" ATTLIST)) 'male1)
|
|
(set! sable_current_speaker 'voice_kal_diphone)
|
|
(voice_kal_diphone))
|
|
((equal? (car (xxml_attval "NAME" ATTLIST)) 'male2)
|
|
(set! sable_current_speaker 'voice_cmu_us_rms_cg)
|
|
(voice_cmu_us_rms_cg))
|
|
((equal? (car (xxml_attval "NAME" ATTLIST)) 'male3)
|
|
(set! sable_current_speaker 'voice_ked_diphone)
|
|
(voice_ked_diphone))
|
|
((equal? (car (xxml_attval "NAME" ATTLIST)) 'male4)
|
|
(set! sable_current_speaker 'voice_rab_diphone)
|
|
(voice_rab_diphone))
|
|
((equal? (car (xxml_attval "NAME" ATTLIST)) 'male5)
|
|
(set! sable_current_speaker 'voice_cmu_us_awb_cg)
|
|
(voice_cmu_us_awb_cg))
|
|
((equal? (car (xxml_attval "NAME" ATTLIST)) 'female1)
|
|
(set! sable_current_speaker 'voice_cmu_us_slt_cg)
|
|
(voice_us1_mbrola))
|
|
(t
|
|
(set! sable_current_speaker (intern (string-append "voice_" (car (xxml_attval "NAME" ATTLIST)))))
|
|
(eval (list sable_current_speaker))))
|
|
(sable_setup_voice_params)
|
|
nil)
|
|
(")SPEAKER" (ATTLIST UTT)
|
|
(xxml_synth UTT)
|
|
(set! sable_utt UTT)
|
|
(set! sable_current_speaker (car sable_speaker_stack))
|
|
(set! sable_speaker_stack (cdr sable_speaker_stack))
|
|
(eval (list sable_current_speaker))
|
|
(sable_setup_voice_params)
|
|
nil)
|
|
("BREAK" (ATTLIST UTT)
|
|
;; Status: probably complete
|
|
;; may cause an utterance break
|
|
(let ((level (upcase (car (xxml_attval "LEVEL" ATTLIST)))))
|
|
(cond
|
|
((null UTT) nil)
|
|
((string-equal "LARGE" level)
|
|
(xxml_synth UTT)
|
|
nil)
|
|
(t
|
|
(let ((last_token (utt.relation.last UTT'Token)))
|
|
(if last_token
|
|
(item.set_feat last_token "pbreak" "B"))
|
|
UTT)))))
|
|
("(DIV" (ATLIST UTT)
|
|
;; Status: probably complete
|
|
(xxml_synth UTT)
|
|
nil)
|
|
("AUDIO" (ATTLIST UTT)
|
|
;; Status: MODE (background) ignored, only insertion supported
|
|
;; mime type of file also ignored, as its LEVEL
|
|
(let ((tmpfile (make_tmp_filename)))
|
|
;; ignoring mode-background (and will for sometime)
|
|
;; ignoring level option
|
|
(xxml_synth UTT) ;; synthesizing anything ready to be synthesized
|
|
(get_url (car (xxml_attval "SRC" ATTLIST)) tmpfile)
|
|
(apply_hooks tts_hooks
|
|
(eval (list 'Utterance 'Wave tmpfile)))
|
|
(delete-file tmpfile)
|
|
nil))
|
|
("(EMPH" (ATTLIST UTT)
|
|
;; Status: nesting makes no difference, levels ignored
|
|
;; Festival is particularly bad at adding specific emphasis
|
|
;; that's what happens when you use statistical methods that
|
|
;; don't include any notion of emphasis
|
|
;; This is *not* recursive and only one level of EMPH supported
|
|
(sable_push_word_features)
|
|
(set! xxml_word_features
|
|
(cons (list "dur_stretch" 1.6)
|
|
(cons
|
|
(list "EMPH" "1") xxml_word_features)))
|
|
UTT)
|
|
(")EMPH" (ATTLIST UTT)
|
|
(set! xxml_word_features (sable_pop_word_features))
|
|
UTT)
|
|
("(PITCH" (ATTLIST UTT)
|
|
;; Status: probably complete
|
|
;; At present festival requires an utterance break here
|
|
(xxml_synth UTT)
|
|
(set! sable_pitch_context (cons int_lr_params sable_pitch_context))
|
|
(let ((base (sable_interpret_param
|
|
(car (xxml_attval "BASE" ATTLIST))
|
|
sable_pitch_base_map
|
|
(cadr (assoc 'target_f0_mean int_lr_params))
|
|
sable_pitch_base_original))
|
|
(med (sable_interpret_param
|
|
(car (xxml_attval "MED" ATTLIST))
|
|
sable_pitch_med_map
|
|
(cadr (assoc 'target_f0_mean int_lr_params))
|
|
sable_pitch_med_original))
|
|
(range (sable_interpret_param
|
|
(car (xxml_attval "RANGE" ATTLIST))
|
|
sable_pitch_range_map
|
|
(cadr (assoc 'target_f0_std int_lr_params))
|
|
sable_pitch_range_original))
|
|
(oldmean (cadr (assoc 'target_f0_mean int_lr_params))))
|
|
;; Festival (if it supports anything) supports mean and std
|
|
;; so we treat base as med if med doesn't seem to do anything
|
|
(if (equal? med oldmean)
|
|
(set! med base))
|
|
(set! int_lr_params
|
|
(cons
|
|
(list 'target_f0_mean med)
|
|
(cons
|
|
(list 'target_f0_std range)
|
|
int_lr_params)))
|
|
nil))
|
|
(")PITCH" (ATTLIST UTT)
|
|
(xxml_synth UTT)
|
|
(set! int_lr_params (car sable_pitch_context))
|
|
(set! sable_pitch_context (cdr sable_pitch_context))
|
|
nil)
|
|
("(RATE" (ATTLIST UTT)
|
|
;; Status: can't deal with absolute word per minute SPEED.
|
|
(sable_push_word_features)
|
|
;; can't deal with words per minute value
|
|
(let ((rate (sable_interpret_param
|
|
(car (xxml_attval "SPEED" ATTLIST))
|
|
sable_rate_speed_map
|
|
(sable_find_fval "dur_stretch" xxml_word_features 1.0)
|
|
sable_rate_speed_original)))
|
|
(set! xxml_word_features
|
|
(cons (list "dur_stretch" (/ 1.0 rate)) xxml_word_features))
|
|
UTT))
|
|
(")RATE" (ATTLIST UTT)
|
|
(set! xxml_word_features (sable_pop_word_features))
|
|
UTT)
|
|
("(VOLUME" (ATTLIST UTT)
|
|
;; Status: probably complete
|
|
;; At present festival requires an utterance break here
|
|
(xxml_synth UTT)
|
|
(set! sable_vol_context (cons (list sable_vol_type sable_vol_factor)
|
|
sable_vol_context))
|
|
(let ((level (sable_interpret_param
|
|
(car (xxml_attval "LEVEL" ATTLIST))
|
|
sable_volume_level_map
|
|
sable_vol_factor
|
|
1.0)))
|
|
(cond
|
|
((string-matches (car (xxml_attval "LEVEL" ATTLIST)) ".*%")
|
|
(set! sable_vol_type 'relative))
|
|
((string-matches (car (xxml_attval "LEVEL" ATTLIST)) SABLE_RXDOUBLE)
|
|
(set! sable_vol_type 'absolute))
|
|
(t
|
|
(set! sable_vol_type 'relative)))
|
|
(set! sable_vol_factor level))
|
|
nil)
|
|
(")VOLUME" (ATTLIST UTT)
|
|
(xxml_synth UTT)
|
|
(set! sable_vol_type (car (car sable_vol_context)))
|
|
(set! sable_vol_factor (car (cdr (car sable_vol_context))))
|
|
(set! sable_vol_context (cdr sable_vol_context))
|
|
nil)
|
|
("(ENGINE" (ATTLIST UTT)
|
|
;; Status: probably complete
|
|
(xxml_synth UTT)
|
|
(if (string-matches (car (xxml_attval "ID" ATTLIST)) "festival.*")
|
|
(let ((datastr ""))
|
|
(mapcar
|
|
(lambda (c) (set! datastr (string-append datastr " " c)))
|
|
(xxml_attval "DATA" ATTLIST))
|
|
(apply_hooks tts_hooks (eval (list 'Utterance 'Text datastr)))
|
|
(set! sable_omitted_mode t)) ;; ignore contents
|
|
;; else
|
|
;; its not relevant to me
|
|
)
|
|
nil)
|
|
(")ENGINE" (ATTLIST UTT)
|
|
(xxml_synth UTT)
|
|
(set! sable_omitted_mode nil)
|
|
nil)
|
|
("MARKER" (ATTLIST UTT)
|
|
;; Status: does nothing
|
|
;; Can't support this without low-level control of audio spooler
|
|
(format t "SABLE: marker \"%s\"\n"
|
|
(car (xxml_attval "MARK" ATTLIST)))
|
|
UTT)
|
|
("(PRON" (ATTLIST UTT)
|
|
;; Status: IPA currently ignored
|
|
(sable_push_word_features)
|
|
;; can't deal with words per minute value
|
|
(let ((ipa (xxml_attval "IPA" ATTLIST))
|
|
(sub (xxml_attval "SUB" ATTLIST)))
|
|
(cond
|
|
(ipa
|
|
(format t "SABLE: ipa ignored\n")
|
|
(set! xxml_word_features
|
|
(cons (list "sable_ignore" "1") xxml_word_features)))
|
|
(sub
|
|
(set! xxml_word_features
|
|
(cons (list "sable_sub" (format nil "%l" sub))
|
|
xxml_word_features))
|
|
(set! xxml_word_features
|
|
(cons (list "sable_ignore" "1") xxml_word_features))))
|
|
UTT))
|
|
(")PRON" (ATTLIST UTT)
|
|
(set! xxml_word_features (sable_pop_word_features))
|
|
UTT)
|
|
("(SAYAS" (ATTLIST UTT)
|
|
;; Status: only a few of the types are dealt with
|
|
(sable_push_word_features)
|
|
(set! sable_utt UTT)
|
|
;; can't deal with words per minute value
|
|
(let ((mode (downcase (car (xxml_attval "MODE" ATTLIST))))
|
|
(modetype (car (xxml_attval "MODETYPE" ATTLIST))))
|
|
(cond
|
|
((string-equal mode "literal")
|
|
(set! xxml_word_features
|
|
(cons (list "sable_literal" "1") xxml_word_features)))
|
|
((string-equal mode "phone")
|
|
(set! xxml_word_features
|
|
(cons (list "token_pos" "digits") xxml_word_features)))
|
|
((string-equal mode "ordinal")
|
|
(set! xxml_word_features
|
|
(cons (list "token_pos" "ordinal") xxml_word_features)))
|
|
((string-equal mode "cardinal")
|
|
(set! xxml_word_features
|
|
(cons (list "token_pos" "cardinal") xxml_word_features)))
|
|
(t
|
|
;; blindly trust festival to get it right
|
|
t))
|
|
UTT))
|
|
(")SAYAS" (ATTLIST UTT)
|
|
(set! xxml_word_features (sable_pop_word_features))
|
|
UTT)
|
|
|
|
|
|
))
|
|
|
|
(define (sable_init_func)
|
|
"(sable_init_func)
|
|
Initialisation for SABLE mode"
|
|
(sable_init_globals)
|
|
(voice_kal_diphone)
|
|
(set! sable_previous_elements xxml_elements)
|
|
(set! xxml_elements sable_elements)
|
|
(set! sable_previous_token_to_words english_token_to_words)
|
|
(set! english_token_to_words sable_token_to_words)
|
|
(set! token_to_words sable_token_to_words))
|
|
|
|
(define (sable_exit_func)
|
|
"(sable_exit_func)
|
|
Exit function for SABLE mode"
|
|
(set! xxml_elements sable_previous_elements)
|
|
(set! token_to_words sable_previous_token_to_words)
|
|
(set! english_token_to_words sable_previous_token_to_words))
|
|
|
|
(define (sable_push_word_features)
|
|
"(sable_push_word_features)
|
|
Save current word features on stack."
|
|
(set! sable_word_features_stack
|
|
(cons xxml_word_features sable_word_features_stack)))
|
|
|
|
(define (sable_adjust_volume utt)
|
|
"(sable_adjust_volume utt)
|
|
Amplify or attenutate signale based on value of sable_vol_factor
|
|
and sable_vol_type (absolute or relative)."
|
|
(set! utts (cons utt utts))
|
|
(cond
|
|
((equal? sable_vol_type 'no_change)
|
|
utt)
|
|
((equal? sable_vol_type 'absolute)
|
|
(utt.wave.rescale utt sable_vol_factor 'absolute))
|
|
((equal? sable_vol_type 'relative)
|
|
(utt.wave.rescale utt sable_vol_factor))
|
|
(t
|
|
(format stderr "SABLE: volume unknown type \"%s\"\n" sable_vol_type)
|
|
utt))
|
|
utt)
|
|
|
|
(define (sable_pop_word_features)
|
|
"(sable_pop_word_features)
|
|
Pop word features from stack."
|
|
(let ((r (car sable_word_features_stack)))
|
|
(set! sable_word_features_stack (cdr sable_word_features_stack))
|
|
r))
|
|
|
|
(define (sable_find_fval feat flist def)
|
|
(cond
|
|
((null flist) def)
|
|
((string-equal feat (car (car flist)))
|
|
(car (cdr (car flist))))
|
|
(t
|
|
(sable_find_fval feat (cdr flist) def))))
|
|
|
|
(define (sable_interpret_param ident map original current)
|
|
"(sable_interpret_param IDENT MAP ORIGINAL CURRENT)
|
|
If IDENT is in map return ORIGINAL times value in map, otherwise
|
|
treat IDENT of the form +/-N% and modify CURRENT accordingly."
|
|
(let ((mm (assoc ident map)))
|
|
(cond
|
|
(mm
|
|
(* original (car (cdr mm))))
|
|
((string-matches ident SABLE_RXDOUBLE)
|
|
(parse-number ident))
|
|
((string-matches ident ".*%")
|
|
(+ current (* current (/ (parse-number (string-before ident "%"))
|
|
100.0))))
|
|
;; ((string-matches ident ".*%")
|
|
;; (* current (/ (parse-number (string-before ident "%")) 100.0)))
|
|
((not ident) current)
|
|
(t
|
|
(format stderr "SABLE: modifier \"%s\" not of float, tag or +/-N\n"
|
|
ident)
|
|
current))))
|
|
|
|
(define (sable_setup_voice_params)
|
|
"(sable_setup_voice_params)
|
|
Set up original values for various voice parameters."
|
|
(set! sable_pitch_base_original (cadr (assoc 'target_f0_mean int_lr_params)))
|
|
(set! sable_pitch_med_original (cadr (assoc 'target_f0_mean int_lr_params)))
|
|
(set! sable_pitch_range_original (cadr (assoc 'target_f0_std int_lr_params)))
|
|
(set! sable_rate_speed_original 1.0)
|
|
(if (and after_synth_hooks (not (consp after_synth_hooks)))
|
|
(set! after_synth_hooks
|
|
(cons after_synth_hooks (list sable_adjust_volume)))
|
|
(set! after_synth_hooks
|
|
(append after_synth_hooks (list sable_adjust_volume))))
|
|
)
|
|
|
|
;;; Declare the new mode to Festival
|
|
(set! tts_text_modes
|
|
(cons
|
|
(list
|
|
'sable ;; mode name
|
|
(list
|
|
(list 'init_func sable_init_func)
|
|
(list 'exit_func sable_exit_func)
|
|
'(analysis_type xml)
|
|
))
|
|
tts_text_modes))
|
|
|
|
(provide 'sable-mode)
|