home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Multimed / Multimed.zip / fest-141.zip / festival / lib / tts.scm < prev    next >
Lisp/Scheme  |  1999-05-30  |  9KB  |  242 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;                                                                       ;;
  3. ;;;                Centre for Speech Technology Research                  ;;
  4. ;;;                     University of Edinburgh, UK                       ;;
  5. ;;;                       Copyright (c) 1996,1997                         ;;
  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. ;;;  Various tts functions and hooks
  35.  
  36. ;;;  Once the utterance is built these functions synth and play it
  37. (defvar tts_hooks (list utt.synth utt.play)
  38.   "tts_hooks
  39. Function or list of functions to be called during text to speech.
  40. The function tts_file, chunks data into Utterances of type Token and
  41. applies this hook to the utterance.  This typically contains the utt.synth
  42. function and utt.play. [see TTS]")
  43.  
  44. ;;;  This is used to define utterance breaks in tts on files
  45. (defvar eou_tree 
  46.   '((n.whitespace matches ".*\n.*\n\\(.\\|\n\\)*");; significant break (2 nls)
  47.     ((1))
  48.     ((name matches "--+")
  49.      ((1))
  50.      ((punc matches ".*[\\?:!].*")
  51.       ((1))
  52.       ((punc matches ".*\\..*")
  53.        ((punc matches "..+");; longer punctuation string
  54.     ((punc matches "\\..*,")  ;; for U.S.S.R., like tokens
  55.      ((0))
  56.      ((1)))
  57.     ;; This is to distinguish abbreviations vs periods
  58.     ;; These are heuristics
  59.     ((name matches "\\(.*\\..*\\|[A-Z][A-Za-z]?[A-Za-z]?\\|etc\\)");; an abbreviation
  60.      ((n.whitespace is " ")
  61.       ((0));; if abbrev single space isn't enough for break
  62.       ((n.name matches "[A-Z].*")
  63.        ((1))
  64.        ((0))))
  65.      ((n.whitespace is " ");; if it doesn't look like an abbreviation
  66.       ((n.name matches "[A-Z].*");; single space and non-cap is no break
  67.        ((1))
  68.        ((0)))
  69.       ((1)))))
  70.        ((0))))))
  71.   "eou_tree
  72. End of utterance tree.  A decision tree used to determine if the given
  73. token marks the end of an utterance.  It may look one token ahead to
  74. do this. [see Utterance chunking]")
  75.  
  76. ;;;  The program used to parse stml files
  77. ;;;  Needs version 1.0 to allow -D option to work
  78. (defvar sgml_parse_progname "nsgmls-1.0"
  79.   "sgml_parse_progname
  80. The name of the program to use to parse SGML files.  Typically this is
  81. nsgml-1.0 from the sp SGML package. [see XML/SGML requirements]")
  82.  
  83. ;;;  When PHRASE elements are specified in an utterance in STML
  84. ;;;  no other method for phrase prediction is to be used, so we
  85. ;;;  use the following tree
  86. (set! stml_phrase_cart_tree
  87. '((R:Token.parent.pbreak is B)
  88.   ((B))
  89.   ((n.name is 0)
  90.    ((B))
  91.    ((NB)))))
  92.  
  93. (define (xxml_synth utt)
  94. "(xxml_synth UTT)
  95. This applies the xxml_hooks (mode specific) and tts_hooks to the
  96. given utterance.  This function should be called from xxml element
  97. definitions that signal an utterance boundary."
  98.    (cond
  99.     ((or (not utt)
  100.      (not (utt.relation utt 'Token)))  ;; no tokens
  101.      nil)
  102.     (t
  103.      (apply_hooks xxml_hooks utt)
  104.      (apply_hooks tts_hooks utt)
  105.      (set! utt nil) ;; not enough ... 
  106.      (gc)
  107.      utt))
  108. )
  109.  
  110. (define (xxml_attval ATTNAME ATTLIST)
  111. "(xxml_attval ATTNAME ATTLIST)
  112. Returns attribute value of ATTNAME in ATTLIST or nil if it doesn't
  113. exists."
  114.   (cond
  115.    ((not ATTLIST)
  116.     nil)
  117.    ((string-equal ATTNAME (car (car ATTLIST)))
  118.     (car (cdr (car ATTLIST))))
  119.    (t
  120.     (xxml_attval ATTNAME (cdr ATTLIST)))))
  121.  
  122. (defvar xxml_word_features nil
  123.   "xxml_word_features
  124. An assoc list of features to be added to the current word when
  125. in xxml parse mode.")
  126.  
  127. (defvar xxml_token_hooks nil
  128.   "xxml_token_hooks
  129. Functions to apply to each token.")
  130.  
  131. (defvar xxml_hooks nil
  132.   "xxml_hooks
  133.   Function or list of functions to be applied to an utterance when
  134.   parsed with xxML, before tts_hooks.")
  135.  
  136. (defvar xxml_elements nil
  137.   "xxml_elements
  138. List of Scheme actions to perform on finding xxML tags.")
  139.  
  140. (defvar xml_dtd_dir libdir
  141.   "xml_dtd_dir
  142. The directory holding standard DTD form the xml parser.")
  143.  
  144. (set! tts_fnum 1)
  145. (define (save_tts_output utt)
  146.   (let ((fname (string-append "tts_file_" tts_fnum ".wav")))
  147.     (format stderr "festival: saving waveform in %s\n" fname)
  148.     (utt.save.wave utt fname)
  149.     (set! tts_fnum (+ 1 tts_fnum))
  150.     utt))
  151.  
  152. (define (save_waves_during_tts)
  153.   "(save_waves_during_tts)
  154. Save each waveform in the current directory in files \"tts_file_XXX.wav\".
  155. use (save_waves_during_tts_STOP) to stop saving waveforms"
  156.   (if (not (member save_tts_output tts_hooks))
  157.       (set! tts_hooks (append tts_hooks (list save_tts_output))))
  158.   t)
  159.  
  160. (define (save_waves_during_tts_STOP)
  161.   "(save_waves_during_tts_STOP)
  162. Stop saving waveforms when doing tts."
  163.   (if (member save_tts_output tts_hooks)
  164.       (set! tts_hooks (delq save_tts_output tts_hooks)))
  165.   t)
  166.  
  167. (define (tts file mode)
  168.   "(tts FILE MODE)
  169.   Convert FILE to speech.  MODE identifies any special treatment
  170.   necessary for FILE.  This is simply a front end to tts_file but 
  171.   puts the system in async audio mode first. [see TTS]"
  172.   (audio_mode 'async)
  173.   (if mode
  174.       (tts_file file mode)
  175.       (tts_file file (tts_find_text_mode file auto-text-mode-alist)))
  176. ;;  (audio_mode 'sync) ;; Hmm this is probably bad
  177. )
  178.  
  179. (define (tts_text string mode)
  180.   "(tts_text STRING mode)
  181. Apply tts on given string.  That is, segment it into utterances and
  182. apply tts_hooks to each utterance.  This is naively done by saving the
  183. string to a file and calling tts_file on that file.  This differs from
  184. SayText which constructs a single utterance for the whole given text."
  185.   (let ((tmpfile (make_tmp_filename))
  186.     (fd))
  187.     (set! fd (fopen tmpfile "wb"))
  188.     (format fd "%s" string)
  189.     (fclose fd)
  190.     (audio_mode 'async)
  191.     (tts_file tmpfile mode)
  192.     (delete-file tmpfile)))
  193.  
  194. (define (tts_textall string mode)
  195.   "(tts_textall STRING MODE)
  196. Apply tts to STRING.  This function is specifically designed for
  197. use in server mode so a single function call may synthesize the string.
  198. This function name maybe added to the server safe functions."
  199.   (utt.send.wave.client 
  200.    (utt.synth
  201.     (eval (list 'Utterance 'Text string)))))
  202.  
  203. (define (tts_return_to_client)
  204.   "(tts_return_to_client)
  205. This function is called by clients who wish to return waveforms of
  206. their text samples asynchronously.  This replaces utt.play in tts_hooks
  207. with utt.send.wave.client."
  208.   (set! tts_hooks
  209.     (append (delq utt.play tts_hooks)
  210.         (list utt.send.wave.client))))
  211.  
  212. (defvar tts_text_modes nil
  213. "tts_text_modes
  214. An a-list of text modes data for file type specific tts functions.
  215. See the manual for an example.  [see Text modes]")
  216.  
  217. (define (tts_find_text_mode file alist)
  218.   "(find_text_mode FILE ALIST)
  219. Search through ALIST for one that matches FILE.  Returns nil if
  220. nothing macthes."
  221.   (cond
  222.    ((null alist) nil)  ;; can't find a match
  223.    ((string-matches file (string-append ".*" (car (car alist)) ".*"))
  224.     (cdr (car alist)))
  225.    (t
  226.     (tts_find_text_mode file (cdr alist)))))
  227.  
  228. (defvar auto-text-mode-alist
  229.   (list
  230.    (cons "\\.sable$" 'sable)
  231.    (cons "\\.ogi" 'ogimarkup)
  232.    (cons "\\.email" 'email)
  233.    (cons "" 'fundamental)
  234.    )
  235.   "auto-text-mode-alist
  236. Following Emacs' auto-mode-alist thios provides a mechanism for auto
  237. selecting a TTS text mode based on the filename being analyzed.  Its
  238. format is exactly the same as Emacs in that it consists of an alist of
  239. dotted pairs of regular expression and text mode name.")
  240.  
  241. (provide 'tts)
  242.