lib/sable-mode.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                       ;;
   3 ;;;                Centre for Speech Technology Research                  ;;
   4 ;;;                     University of Edinburgh, UK                       ;;
   5 ;;;                         Copyright (c) 1998                            ;;
   6 ;;;                        All Rights Reserved.                           ;;
   7 ;;;                                                                       ;;
   8 ;;;  Permission is hereby granted, free of charge, to use and distribute  ;;
   9 ;;;  this software and its documentation without restriction, including   ;;
  10 ;;;  without limitation the rights to use, copy, modify, merge, publish,  ;;
  11 ;;;  distribute, sublicense, and/or sell copies of this work, and to      ;;
  12 ;;;  permit persons to whom this work is furnished to do so, subject to   ;;
  13 ;;;  the following conditions:                                            ;;
  14 ;;;   1. The code must retain the above copyright notice, this list of    ;;
  15 ;;;      conditions and the following disclaimer.                         ;;
  16 ;;;   2. Any modifications must be clearly marked as such.                ;;
  17 ;;;   3. Original authors' names are not deleted.                         ;;
  18 ;;;   4. The authors' names are not used to endorse or promote products   ;;
  19 ;;;      derived from this software without specific prior written        ;;
  20 ;;;      permission.                                                      ;;
  21 ;;;                                                                       ;;
  22 ;;;  THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK        ;;
  23 ;;;  DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING      ;;
  24 ;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT   ;;
  25 ;;;  SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE     ;;
  26 ;;;  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES    ;;
  27 ;;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN   ;;
  28 ;;;  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,          ;;
  29 ;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF       ;;
  30 ;;;  THIS SOFTWARE.                                                       ;;
  31 ;;;                                                                       ;;
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;;;                                                                       ;;
  34 ;;;  Festival (1.3.X) support for SABLE 0.2 the SGML/XML based mark up    ;;
  35 ;;;  language.                                                            ;;
  36 ;;;                                                                       ;;
  37 ;;;  This is XML version requiring Edinburgh's LTG's rxp XML parser as    ;;
  38 ;;;  distributed with Festival                                            ;;
  39 ;;;                                                                       ;;
  40
  41 (require_module 'rxp)
  42
  43 ;;(set! auto-text-mode-alist
  44 ;;      (cons
  45 ;;       (cons "\\.sable$" 'sable)
  46 ;;       auto-text-mode-alist))
  47
  48  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49  ;;                                                                       ;;
  50  ;; Remember where to find these two XML entities.                        ;;
  51  ;;                                                                       ;;
  52  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53
  54
  55 (xml_register_id "-//SABLE//DTD SABLE speech mark up//EN"
  56                 (path-append libdir "Sable.v0_2.dtd")
  57                 )
  58
  59 (xml_register_id "-//SABLE//ENTITIES Added Latin 1 for SABLE//EN"
  60                  (path-append libdir  "sable-latin.ent")
  61                  )
  62
  63 ;; (print (xml_registered_ids))
  64
  65 (defvar SABLE_RXDOUBLE "-?\\(\\([0-9]+\\.[0-9]*\\)\\|\\([0-9]+\\)\\|\\(\\.[0-9]+\\)\\)\\([eE][---+]?[0-9]+\\)?")
  66
  67 (defvar sable_pitch_base_map
  68   '((highest 1.2)
  69     (high 1.1)
  70     (medium 1.0)
  71     (default 1.0)
  72     (low 0.9)
  73     (lowest 0.8)))
  74 (defvar sable_pitch_med_map
  75   '((highest 1.2)
  76     (high 1.1)
  77     (medium 1.0)
  78     (default 1.0)
  79     (low 0.9)
  80     (lowest 0.8)))
  81 (defvar sable_pitch_range_map
  82   '((largest 1.2)
  83     (large 1.1)
  84     (medium 1.0)
  85     (default 1.0)
  86     (small 0.9)
  87     (smallest 0.8)))
  88 (defvar sable_rate_speed_map
  89   '((fastest 1.5)
  90     (fast 1.2)
  91     (medium 1.0)
  92     (default 1.0)
  93     (slow 0.8)
  94     (slowest 0.6)))
  95 (defvar sable_volume_level_map
  96   '((loudest 2.0)
  97     (loud 1.5)
  98     (default 1.0)
  99     (medium 1.0)
 100     (quiet 0.5)))
 101
 102 (define (sable_init_globals)
 103   (set! utts nil)
 104   (set! sable_omitted_mode nil)
 105   (set! sable_word_features_stack nil)
 106   (set! sable_pitch_context nil)
 107   (set! sable_vol_context nil)
 108   (set! sable_vol_type 'no_change)
 109   (set! sable_vol_factor 1.0)
 110   (set! sable_current_language 'britishenglish)
 111   (set! sable_unsupported_language nil)
 112   (set! sable_language_stack nil)
 113   (set! sable_current_speaker 'voice_kal_diphone)
 114   (set! sable_speaker_stack nil)
 115 )
 116
 117 (define (sable_token_to_words token name)
 118   "(sable_token_to_words utt token name)
 119 SABLE mode token specific analysis."
 120   (cond
 121    ((or sable_omitted_mode sable_unsupported_language)
 122     ;; don't say anything (whole utterance)
 123     nil)
 124    ((string-equal "1" (item.feat token "done_sable_sub"))
 125     ;; to catch recursive calls this when splitting up sub expressions
 126     (sable_previous_token_to_words token name))
 127    ((and (not (string-equal "0" (item.feat token "sable_sub")))
 128          (string-equal "0" (item.feat token "p.sable_sub")))
 129     (let (words (sub (item.feat token "sable_sub")))
 130       (item.set_feat token "done_sable_sub" "1")
 131       (set! words
 132             (apply append
 133                    (mapcar
 134                     (lambda (w)
 135                       (set! www (sable_previous_token_to_words token w))
 136                       www)
 137                     (read-from-string sub))))
 138       (item.set_feat token "done_sable_sub" "0")
 139       words))
 140    ((string-equal "1" (item.feat token "sable_ignore"))
 141     ;; don't say anything (individual word)
 142     nil)
 143    ((string-equal "1" (item.feat token "sable_ipa"))
 144     ;; Each token is an IPA phone
 145     (item.set_feat token "phonemes" (sable-map-ipa name))
 146     (list name))
 147    ((string-equal "1" (item.feat token "sable_literal"))
 148     ;; Only deal with spell here
 149     (let ((subwords) (subword))
 150       (item.set_feat token "pos" token.letter_pos)
 151       (mapcar
 152        (lambda (letter)
 153          ;; might be symbols or digits
 154          (set! subword (sable_previous_token_to_words token letter))
 155          (if subwords
 156              (set! subwords (append subwords subword))
 157              (set! subwords subword)))
 158        (symbolexplode name))
 159       subwords))
 160    ((not (string-equal "0" (item.feat token "token_pos")))
 161     ;; bypass the prediction stage, if English
 162     (if (member_string (Parameter.get 'Language)
 163                        '(britishenglish americanenglish))
 164         (builtin_english_token_to_words token name)
 165         (sable_previous_token_to_words token name)))
 166    ;; could be others here later
 167    (t
 168     (sable_previous_token_to_words token name))))
 169
 170 (defvar sable_elements
 171 '(
 172   ("(SABLE" (ATTLIST UTT)
 173     (eval (list sable_current_speaker))  ;; so we know what state we start in
 174     (sable_setup_voice_params)
 175     nil
 176   )
 177   (")SABLE" (ATTLIST UTT)
 178     (xxml_synth UTT)  ;;  Synthesis the remaining tokens
 179     nil
 180   )
 181   ;; Utterance break elements
 182   ("(LANGUAGE" (ATTLIST UTT)
 183    ;; Status: probably complete
 184    (xxml_synth UTT)
 185    (set! sable_language_stack
 186          (cons
 187           (list sable_current_language sable_unsupported_language)
 188           sable_language_stack))
 189    ;; Select a new language
 190    (let ((language (upcase (car (xxml_attval "ID" ATTLIST)))))
 191      (cond
 192       ((or (string-equal language "SPANISH")
 193            (string-equal language "ES"))
 194        (set! sable_current_language 'spanish)
 195        (set! sable_unsupported_language nil)
 196        (select_language 'spanish))
 197       ((or (string-equal language "ENGLISH")
 198            (string-equal language "EN"))
 199        (set! sable_current_language 'britishenglish)
 200        (set! sable_unsupported_language nil)
 201        (select_language 'britishenglish))
 202       (t  ;; skip languages you don't know
 203        ;; BUG: if current language isn't English this wont work
 204        (apply_hooks tts_hooks
 205                     (eval (list 'Utterance 'Text
 206                                 (string-append "Some text in " language))))
 207        (set! sable_unsupported_language t)))
 208      nil))
 209   (")LANGUAGE" (ATTLIST UTT)
 210    (xxml_synth UTT)
 211    (set! sable_unsupported_language (car (cdr (car sable_language_stack))))
 212    (set! sable_current_language (car (car sable_language_stack)))
 213    (set! sable_language_stack (cdr sable_language_stack))
 214    (if (not sable_omitted_mode)
 215        (begin
 216          (select_language sable_current_language)
 217          (sable_setup_voice_params)))
 218    nil)
 219   ("(SPEAKER" (ATTLIST UTT)
 220    ;; Status: GENDER/AGE ignored, should be done by sable-def-speaker
 221    ;;         function to define Festival voices to SABLE
 222    (xxml_synth UTT)
 223    (set! sable_speaker_stack (cons sable_current_speaker sable_speaker_stack))
 224    (cond
 225     ((not equal? sable_current_language 'britishenglish)
 226      (print "SABLE: choosen unknown voice, current voice unchanged"))
 227     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male1)
 228      (set! sable_current_speaker 'voice_kal_diphone)
 229      (voice_kal_diphone))
 230     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male2)
 231      (set! sable_current_speaker 'voice_cmu_us_rms_cg)
 232      (voice_cmu_us_rms_cg))
 233     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male3)
 234      (set! sable_current_speaker 'voice_ked_diphone)
 235      (voice_ked_diphone))
 236     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male4)
 237      (set! sable_current_speaker 'voice_rab_diphone)
 238      (voice_rab_diphone))
 239     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male5)
 240      (set! sable_current_speaker 'voice_cmu_us_awb_cg)
 241      (voice_cmu_us_awb_cg))
 242     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'female1)
 243      (set! sable_current_speaker 'voice_cmu_us_slt_arctic_hts)
 244      (voice_us1_mbrola))
 245    (t
 246       (set! sable_current_speaker (intern (string-append "voice_" (car (xxml_attval "NAME" ATTLIST)))))
 247       (eval (list sable_current_speaker))))
 248     (sable_setup_voice_params)
 249    nil)
 250   (")SPEAKER" (ATTLIST UTT)
 251    (xxml_synth UTT)
 252    (set! sable_utt UTT)
 253    (set! sable_current_speaker (car sable_speaker_stack))
 254    (set! sable_speaker_stack (cdr sable_speaker_stack))
 255    (eval (list sable_current_speaker))
 256    (sable_setup_voice_params)
 257    nil)
 258   ("BREAK" (ATTLIST UTT)
 259    ;; Status: probably complete
 260    ;; may cause an utterance break
 261    (let ((level (upcase (car (xxml_attval "LEVEL" ATTLIST)))))
 262      (cond
 263       ((null UTT) nil)
 264       ((string-equal "LARGE" level)
 265        (xxml_synth UTT)
 266        nil)
 267       (t
 268        (let ((last_token (utt.relation.last UTT'Token)))
 269          (if last_token
 270              (item.set_feat last_token "pbreak" "B"))
 271          UTT)))))
 272   ("(DIV" (ATLIST UTT)
 273    ;; Status: probably complete
 274    (xxml_synth UTT)
 275    nil)
 276   ("AUDIO" (ATTLIST UTT)
 277    ;; Status: MODE (background) ignored, only insertion supported
 278    ;; mime type of file also ignored, as its LEVEL
 279    (let ((tmpfile (make_tmp_filename)))
 280      ;; ignoring mode-background (and will for sometime)
 281      ;; ignoring level option
 282      (xxml_synth UTT)  ;; synthesizing anything ready to be synthesized
 283      (get_url (car (xxml_attval "SRC" ATTLIST)) tmpfile)
 284      (apply_hooks tts_hooks
 285                   (eval (list 'Utterance 'Wave tmpfile)))
 286      (delete-file tmpfile)
 287      nil))
 288   ("(EMPH" (ATTLIST UTT)
 289    ;; Status: nesting makes no difference, levels ignored
 290    ;; Festival is particularly bad at adding specific emphasis
 291    ;; that's what happens when you use statistical methods that
 292    ;; don't include any notion of emphasis
 293    ;; This is *not* recursive and only one level of EMPH supported
 294    (sable_push_word_features)
 295    (set! xxml_word_features
 296          (cons (list "dur_stretch" 1.6)
 297                (cons
 298                 (list "EMPH" "1") xxml_word_features)))
 299    UTT)
 300   (")EMPH" (ATTLIST UTT)
 301    (set! xxml_word_features (sable_pop_word_features))
 302    UTT)
 303   ("(PITCH" (ATTLIST UTT)
 304    ;; Status: probably complete
 305    ;; At present festival requires an utterance break here
 306    (xxml_synth UTT)
 307    (set! sable_pitch_context (cons int_lr_params sable_pitch_context))
 308    (let ((base (sable_interpret_param
 309                 (car (xxml_attval "BASE" ATTLIST))
 310                 sable_pitch_base_map
 311                 (cadr (assoc 'target_f0_mean int_lr_params))
 312                 sable_pitch_base_original))
 313          (med (sable_interpret_param
 314                (car (xxml_attval "MED" ATTLIST))
 315                sable_pitch_med_map
 316                (cadr (assoc 'target_f0_mean int_lr_params))
 317                sable_pitch_med_original))
 318          (range (sable_interpret_param
 319                  (car (xxml_attval "RANGE" ATTLIST))
 320                  sable_pitch_range_map
 321                  (cadr (assoc 'target_f0_std int_lr_params))
 322                  sable_pitch_range_original))
 323          (oldmean (cadr (assoc 'target_f0_mean int_lr_params))))
 324      ;; Festival (if it supports anything) supports mean and std
 325      ;; so we treat base as med if med doesn't seem to do anything
 326      (if (equal? med oldmean)
 327          (set! med base))
 328      (set! int_lr_params
 329            (cons
 330             (list 'target_f0_mean med)
 331             (cons
 332              (list 'target_f0_std range)
 333              int_lr_params)))
 334    nil))
 335   (")PITCH" (ATTLIST UTT)
 336    (xxml_synth UTT)
 337    (set! int_lr_params (car sable_pitch_context))
 338    (set! sable_pitch_context (cdr sable_pitch_context))
 339    nil)
 340   ("(RATE" (ATTLIST UTT)
 341    ;; Status: can't deal with absolute word per minute SPEED.
 342    (sable_push_word_features)
 343    ;; can't deal with words per minute value
 344    (let ((rate (sable_interpret_param
 345                 (car (xxml_attval "SPEED" ATTLIST))
 346                 sable_rate_speed_map
 347                 (sable_find_fval "dur_stretch" xxml_word_features 1.0)
 348                 sable_rate_speed_original)))
 349      (set! xxml_word_features
 350            (cons (list "dur_stretch" (/ 1.0 rate)) xxml_word_features))
 351      UTT))
 352   (")RATE" (ATTLIST UTT)
 353    (set! xxml_word_features (sable_pop_word_features))
 354    UTT)
 355   ("(VOLUME" (ATTLIST UTT)
 356    ;; Status: probably complete
 357    ;; At present festival requires an utterance break here
 358    (xxml_synth UTT)
 359    (set! sable_vol_context (cons (list sable_vol_type sable_vol_factor)
 360                                  sable_vol_context))
 361    (let ((level (sable_interpret_param
 362                 (car (xxml_attval "LEVEL" ATTLIST))
 363                 sable_volume_level_map
 364                 sable_vol_factor
 365                 1.0)))
 366      (cond
 367       ((string-matches (car (xxml_attval "LEVEL" ATTLIST)) ".*%")
 368        (set! sable_vol_type 'relative))
 369       ((string-matches (car (xxml_attval "LEVEL" ATTLIST))  SABLE_RXDOUBLE)
 370        (set! sable_vol_type 'absolute))
 371       (t
 372        (set! sable_vol_type 'relative)))
 373      (set! sable_vol_factor level))
 374    nil)
 375   (")VOLUME" (ATTLIST UTT)
 376    (xxml_synth UTT)
 377    (set! sable_vol_type (car (car sable_vol_context)))
 378    (set! sable_vol_factor (car (cdr (car sable_vol_context))))
 379    (set! sable_vol_context (cdr sable_vol_context))
 380    nil)
 381   ("(ENGINE" (ATTLIST UTT)
 382    ;; Status: probably complete
 383    (xxml_synth UTT)
 384    (if (string-matches (car (xxml_attval "ID" ATTLIST)) "festival.*")
 385        (let ((datastr ""))
 386          (mapcar
 387           (lambda (c) (set! datastr (string-append datastr " " c)))
 388           (xxml_attval "DATA" ATTLIST))
 389          (apply_hooks tts_hooks (eval (list 'Utterance 'Text datastr)))
 390          (set! sable_omitted_mode t)) ;; ignore contents
 391        ;; else
 392        ;;  its not relevant to me
 393        )
 394    nil)
 395   (")ENGINE" (ATTLIST UTT)
 396    (xxml_synth UTT)
 397    (set! sable_omitted_mode nil)
 398    nil)
 399   ("MARKER" (ATTLIST UTT)
 400    ;; Status: does nothing
 401    ;; Can't support this without low-level control of audio spooler
 402    (format t "SABLE: marker \"%s\"\n"
 403            (car (xxml_attval "MARK" ATTLIST)))
 404    UTT)
 405   ("(PRON" (ATTLIST UTT)
 406    ;; Status: IPA currently ignored
 407    (sable_push_word_features)
 408    ;; can't deal with words per minute value
 409    (let ((ipa (xxml_attval "IPA" ATTLIST))
 410          (sub (xxml_attval "SUB" ATTLIST)))
 411      (cond
 412       (ipa
 413        (format t "SABLE: ipa ignored\n")
 414        (set! xxml_word_features
 415              (cons (list "sable_ignore" "1") xxml_word_features)))
 416       (sub
 417        (set! xxml_word_features
 418              (cons (list "sable_sub" (format nil "%l" sub))
 419                    xxml_word_features))
 420        (set! xxml_word_features
 421              (cons (list "sable_ignore" "1") xxml_word_features))))
 422      UTT))
 423   (")PRON" (ATTLIST UTT)
 424    (set! xxml_word_features (sable_pop_word_features))
 425    UTT)
 426   ("(SAYAS" (ATTLIST UTT)
 427    ;; Status: only a few of the types are dealt with
 428    (sable_push_word_features)
 429     (set! sable_utt UTT)
 430    ;; can't deal with words per minute value
 431    (let ((mode (downcase (car (xxml_attval "MODE" ATTLIST))))
 432          (modetype (car (xxml_attval "MODETYPE" ATTLIST))))
 433      (cond
 434       ((string-equal mode "literal")
 435        (set! xxml_word_features
 436              (cons (list "sable_literal" "1") xxml_word_features)))
 437       ((string-equal mode "phone")
 438        (set! xxml_word_features
 439              (cons (list "token_pos" "digits") xxml_word_features)))
 440       ((string-equal mode "ordinal")
 441        (set! xxml_word_features
 442              (cons (list "token_pos" "ordinal") xxml_word_features)))
 443       ((string-equal mode "cardinal")
 444        (set! xxml_word_features
 445              (cons (list "token_pos" "cardinal") xxml_word_features)))
 446       (t
 447        ;; blindly trust festival to get it right
 448        t))
 449      UTT))
 450   (")SAYAS" (ATTLIST UTT)
 451    (set! xxml_word_features (sable_pop_word_features))
 452    UTT)
 453
 454
 455 ))
 456
 457 (define (sable_init_func)
 458   "(sable_init_func)
 459 Initialisation for SABLE mode"
 460   (sable_init_globals)
 461   (voice_kal_diphone)
 462   (set! sable_previous_elements xxml_elements)
 463   (set! xxml_elements sable_elements)
 464   (set! sable_previous_token_to_words english_token_to_words)
 465   (set! english_token_to_words sable_token_to_words)
 466   (set! token_to_words sable_token_to_words))
 467
 468 (define (sable_exit_func)
 469   "(sable_exit_func)
 470 Exit function for SABLE mode"
 471   (set! xxml_elements sable_previous_elements)
 472   (set! token_to_words sable_previous_token_to_words)
 473   (set! english_token_to_words sable_previous_token_to_words))
 474
 475 (define (sable_push_word_features)
 476 "(sable_push_word_features)
 477 Save current word features on stack."
 478   (set! sable_word_features_stack
 479         (cons xxml_word_features sable_word_features_stack)))
 480
 481 (define (sable_adjust_volume utt)
 482   "(sable_adjust_volume utt)
 483 Amplify or attenutate signale based on value of sable_vol_factor
 484 and sable_vol_type (absolute or relative)."
 485   (set! utts (cons utt utts))
 486   (cond
 487    ((equal? sable_vol_type 'no_change)
 488     utt)
 489    ((equal? sable_vol_type 'absolute)
 490     (utt.wave.rescale utt sable_vol_factor 'absolute))
 491    ((equal? sable_vol_type 'relative)
 492     (utt.wave.rescale utt sable_vol_factor))
 493    (t
 494     (format stderr "SABLE: volume unknown type \"%s\"\n" sable_vol_type)
 495     utt))
 496    utt)
 497
 498 (define (sable_pop_word_features)
 499 "(sable_pop_word_features)
 500 Pop word features from stack."
 501   (let ((r (car sable_word_features_stack)))
 502     (set! sable_word_features_stack (cdr sable_word_features_stack))
 503     r))
 504
 505 (define (sable_find_fval feat flist def)
 506   (cond
 507    ((null flist) def)
 508    ((string-equal feat (car (car flist)))
 509     (car (cdr (car flist))))
 510    (t
 511     (sable_find_fval feat (cdr flist) def))))
 512
 513 (define (sable_interpret_param ident map original current)
 514 "(sable_interpret_param IDENT MAP ORIGINAL CURRENT)
 515 If IDENT is in map return ORIGINAL times value in map, otherwise
 516 treat IDENT of the form +/-N% and modify CURRENT accordingly."
 517   (let ((mm (assoc ident map)))
 518     (cond
 519      (mm
 520       (* original (car (cdr mm))))
 521      ((string-matches ident SABLE_RXDOUBLE)
 522       (parse-number ident))
 523      ((string-matches ident ".*%")
 524       (+ current (* current (/ (parse-number (string-before ident "%"))
 525                                100.0))))
 526 ;;     ((string-matches ident ".*%")
 527 ;;      (* current (/ (parse-number (string-before ident "%")) 100.0)))
 528      ((not ident) current)
 529      (t
 530       (format stderr "SABLE: modifier \"%s\" not of float, tag or +/-N\n"
 531               ident)
 532       current))))
 533
 534 (define (sable_setup_voice_params)
 535 "(sable_setup_voice_params)
 536 Set up original values for various voice parameters."
 537  (set! sable_pitch_base_original (cadr (assoc 'target_f0_mean int_lr_params)))
 538  (set! sable_pitch_med_original (cadr (assoc 'target_f0_mean int_lr_params)))
 539  (set! sable_pitch_range_original (cadr (assoc 'target_f0_std int_lr_params)))
 540  (set! sable_rate_speed_original 1.0)
 541  (if (and after_synth_hooks (not (consp after_synth_hooks)))
 542      (set! after_synth_hooks
 543            (cons after_synth_hooks (list sable_adjust_volume)))
 544      (set! after_synth_hooks
 545            (append after_synth_hooks (list sable_adjust_volume))))
 546 )
 547
 548 ;;; Declare the new mode to Festival
 549 (set! tts_text_modes
 550    (cons
 551     (list
 552       'sable   ;; mode name
 553       (list
 554        (list 'init_func sable_init_func)
 555        (list 'exit_func sable_exit_func)
 556        '(analysis_type xml)
 557        ))
 558     tts_text_modes))
 559
 560 (provide 'sable-mode)