home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Multimed / Multimed.zip / fest-141.zip / festival / lib / soleml-mode.scm < prev    next >
Lisp/Scheme  |  1999-05-30  |  12KB  |  337 lines
  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. ;;;  Support for an SGML based mark-up language used in the SOLE
  35. ;;;  project.  This is all still experimental.
  36. ;;;
  37. ;;;  This currently treats one file as one utterance (to make dealing with
  38. ;;;  the SOLE museaum database easy
  39.  
  40. (set! soleml_word_features_stack nil)
  41. (defvar sole_current_node nil)
  42.  
  43. (define (soleml_token_to_words utt token name)
  44.   "(soleml_token_to_words utt token name)
  45. SOLEML mode token specific analysis."
  46.   (cond
  47.  
  48.    (t
  49.     (soleml_previous_token_to_words utt token name))))
  50.  
  51. (define (voice_soleml)
  52. "(soleml_voice)
  53. Speaker specific initialisation for SOLE museum data."
  54.   (voice_rab_diphone)
  55.   ;; Utterances only come at end of file
  56.   (set! eou_tree '((0)))
  57. )
  58.  
  59. (defvar soleml_elements
  60. '(
  61.   ("(SOLEML" (ATTLIST UTT)
  62.     ;; required to identify type 
  63.     (voice_soleml)  ;; so we know what state we start in
  64.     (set! soleml_utt (Utterance Tokens nil))
  65.     (utt.stream.create soleml_utt 'Token)
  66.     (utt.relation.create soleml_utt 'SOLEML)
  67.     (set! sole_current_node 
  68.       (utt.relation_append soleml_utt 'SOLEML (cons "sole-ml" ATTLIST)))
  69.     soleml_utt
  70.   )
  71.   (")SOLEML" (ATTLIST UTT)
  72.     ;; required to identify end token
  73.     ;; Don't really want to synthesize this
  74.     ;; (xxml_synth UTT)  ;;  Synthesis the remaining tokens
  75.     (set! soleml_utt UTT)         
  76.     UTT
  77.   )
  78.   ;; Utterance break elements
  79.   ("(LANGUAGE" (ATTLIST UTT)
  80.    ;; Select a new language
  81.    (select_language (car (xxml_attval "NAME" ATTLIST)))
  82.    UTT)
  83.   ("(VOICE" (ATTLIST UTT)
  84.    ;;(xxml_synth UTT)
  85.    ;; Select a new voice
  86.    (cond
  87.     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male1)
  88.      (voice_soleml_diphone))
  89.     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male2)
  90.      (voice_soleml_diphone))
  91.     ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male3)
  92.      (voice_soleml_diphone))
  93.     (t
  94.      (print "SOLEML: selecting unknown voice")
  95.      (voice_soleml_diphone)))
  96.    UTT)
  97.   ;; phrase-boundary  // mark on token (??)
  98.   ;; punct-elem     // mark on token
  99.   ;; sem-elem
  100.   ;; text-elem      // ignore
  101.   ;; rhet-elem  has nucleus and satellite
  102.   ;; anaphora-elem
  103.   ;; syn-elem
  104.   ;; info-struct-elem
  105.   ;; other-elem
  106.   ("(PUNCT-ELEM" (ATTLIST UTT) 
  107.    (soleml_push_word_features)
  108.    (set! xxml_word_features
  109.       (cons (list "punct-elem" "1")
  110.         (soleml_conv_attlist ATTLIST)))
  111.    UTT)
  112.   (")PUNCT-ELEM" (ATTLIST UTT) 
  113.    (set! xxml_word_features (soleml_pop_word_features))
  114.    UTT)
  115.   ("(PHRASE-BOUNDARY" (ATTLIST UTT)
  116.    (if (string-equal "4" (car (xxml_attval "STRENGTH" ATTLIST)))
  117.        (begin
  118. ;;     (xxml_synth UTT)
  119.      UTT)
  120.        (let ((last_token (car (last (utt.stream UTT 'Token)))))
  121.      (if last_token
  122.          (item.set_feat last_token "pbreak" "B"))
  123.      UTT)))
  124.   ;; For each recursive element simply build a new node
  125.   ("(RHET-ELEM" (ATTLIST UTT)
  126.    (let ((sdesc (list 'rhet-elem (soleml_conv_attlist ATTLIST))))
  127.      (set! sole_current_node
  128.        (node.append_daughter sole_current_node sdesc))
  129.      UTT))
  130.   (")RHET-ELEM" (ATTLIST UTT)
  131.     (set! sole_current_node (node.parent sole_current_node))
  132.     UTT)
  133.   ("(RHET-EMPH" (ATTLIST UTT)
  134.    (let ((sdesc (list 'rhet-emph (soleml_conv_attlist ATTLIST))))
  135.      (set! sole_current_node
  136.        (node.append_daughter sole_current_node sdesc))
  137.      UTT))
  138.   (")RHET-EMPH" (ATTLIST UTT)
  139.     (set! sole_current_node (node.parent sole_current_node))
  140.     UTT)
  141.   ("(ANAPHORA-ELEM" (ATTLIST UTT)
  142.    (let ((sdesc (list 'anaphora-elem (soleml_conv_attlist ATTLIST))))
  143.      (set! sole_current_node
  144.        (node.append_daughter sole_current_node sdesc))
  145.      UTT))
  146.   (")ANAPHORA-ELEM" (ATTLIST UTT)
  147.     (set! sole_current_node (node.parent sole_current_node))
  148.     UTT)
  149.   ("(SYN-ELEM" (ATTLIST UTT)
  150.    (let ((sdesc (list 'syn-elem (soleml_conv_attlist ATTLIST))))
  151.      (set! sole_current_node
  152.        (node.append_daughter sole_current_node sdesc))
  153.      UTT))
  154.   (")SYN-ELEM" (ATTLIST UTT)
  155.     (set! sole_current_node (node.parent sole_current_node))
  156.     UTT)
  157.   ("(CONNECTIVE" (ATTLIST UTT)
  158.    (let ((sdesc (list 'connective (soleml_conv_attlist ATTLIST))))
  159.      (set! sole_current_node
  160.        (node.append_daughter sole_current_node sdesc))
  161.      UTT))
  162.   (")CONNECTIVE" (ATTLIST UTT)
  163.     (set! sole_current_node (node.parent sole_current_node))
  164.     UTT)
  165.   ("(TEXT-ELEM" (ATTLIST UTT)
  166.    (let ((sdesc (list 'text-elem (soleml_conv_attlist ATTLIST))))
  167.      (set! sole_current_node
  168.        (node.append_daughter sole_current_node sdesc))
  169.      UTT))
  170.   (")TEXT-ELEM" (ATTLIST UTT)
  171.     (set! sole_current_node (node.parent sole_current_node))
  172.     UTT)
  173.   ("(SEM-ELEM" (ATTLIST UTT)
  174.    (let ((sdesc (list 'sem-elem (soleml_conv_attlist ATTLIST))))
  175.      (set! sole_current_node
  176.        (node.append_daughter sole_current_node sdesc))
  177.      UTT))
  178.   (")SEM-ELEM" (ATTLIST UTT)
  179.     (set! sole_current_node (node.parent sole_current_node))
  180.     UTT)
  181.   ("(INFO-STRUCT-ELEM" (ATTLIST UTT)
  182.    (let ((sdesc (list 'info-struct-elem (soleml_conv_attlist ATTLIST))))
  183.      (set! sole_current_node
  184.        (node.append_daughter sole_current_node sdesc))
  185.      UTT))
  186.   (")INFO-STRUCT-ELEM" (ATTLIST UTT)
  187.     (set! sole_current_node (node.parent sole_current_node))
  188.     UTT)
  189.   ("(OTHER-ELEM" (ATTLIST UTT)
  190.    (let ((sdesc (list 'other-elem (soleml_conv_attlist ATTLIST))))
  191.      (set! sole_current_node
  192.        (node.append_daughter sole_current_node sdesc))
  193.      UTT))
  194.   (")OTHER-ELEM" (ATTLIST UTT)
  195.     (set! sole_current_node (node.parent sole_current_node))
  196.     UTT)
  197.   ("(NUCLEUS" (ATTLIST UTT)
  198.    (let ((sdesc (list 'nucleus (soleml_conv_attlist ATTLIST))))
  199.      (set! sole_current_node
  200.        (node.append_daughter sole_current_node sdesc))
  201.      UTT))
  202.   (")NUCLEUS" (ATTLIST UTT)
  203.     (set! sole_current_node (node.parent sole_current_node))
  204.     UTT)
  205.   ("(SATELLITE" (ATTLIST UTT)
  206.    (let ((sdesc (list 'satellite (soleml_conv_attlist ATTLIST))))
  207.      (set! sole_current_node
  208.        (node.append_daughter sole_current_node sdesc))
  209.      UTT))
  210.   (")SATELLITE" (ATTLIST UTT)
  211.     (set! sole_current_node (node.parent sole_current_node))
  212.     UTT)
  213.   ;; Other control functions (probably not used in SOLE)  
  214.   ("(CALL" (ATTLIST UTT)
  215. ;;   (xxml_synth UTT)
  216.    (if (string-matches (car (xxml_attval "ENGID" ATTLIST)) "festival.*")
  217.        (let ((comstr ""))
  218.      (mapcar
  219.       (lambda (c) (set! comstr (string-append comstr " " c)))
  220.       (xxml_attval "COMMAND" ATTLIST))
  221.      (eval (read-from-string comstr))))
  222.    UTT)
  223.   ("(DEFINE" (ATTLIST UTT)
  224. ;;    (xxml_synth UTT)
  225.     (if (not (string-equal "NATIVE" (car (xxml_attval "SCHEME" ATTLIST))))
  226.     (format t "DEFINE: unsupported SCHEME %s, definition ignored\n"
  227.         (car (xxml_attval "SCHEME" ATTLIST)))
  228.     (lex.add.entry
  229.      (list
  230.       (car (xxml_attval "WORDS" ATTLIST))   ;; head form
  231.       nil          ;; pos
  232.       (lex.syllabify.phstress (xxml_attval "PRONS" ATTLIST)))))
  233.     UTT)
  234.   ("(SOUND" (ATTLIST UTT)
  235. ;;   (xxml_synth UTT)
  236.    (if (not soleml_omitted_mode)
  237.        (apply_hooks tts_hooks
  238.             (eval (list 'Utterance 'Wave 
  239.                 (car (xxml_attval "SRC" ATTLIST))))))
  240.    UTT)
  241.   ("(EMPH" (ATTLIST UTT)
  242.    ;; Festival is particularly bad at adding specific emphasis
  243.    ;; that's what happens when you use statistical methods that
  244.    ;; don't include any notion of emphasis
  245.    ;; This is *not* recursive
  246.    (soleml_push_word_features)
  247.    (set! xxml_word_features 
  248.      (cons (list "EMPH" "1") xxml_word_features))
  249.    UTT)
  250.   (")EMPH" (ATTLIST UTT)
  251.    (set! xxml_word_features (soleml_pop_word_features))
  252.    UTT)
  253.   ("(WORD" (ATTLIST UTT)
  254.    ;; a word in-line
  255.    (let ((name   (xxml_attval "NAME" ATTLIST))
  256.      (pos    (xxml_attval "POS" ATTLIST))
  257.      (accent (xxml_attval "ACCENT" ATTLIST))
  258.      (tone   (xxml_attval "TONE" ATTLIST))
  259.      (phonemes (xxml_attval "PHONEMES" ATTLIST))
  260.      token)
  261.      (utt.item.insert UTT 'Token)  ;; add new Token
  262.      (set! token (utt.stream.tail UTT 'Token))
  263.      (item.set_name token (car name))
  264.      (if pos (item.set_feat token "pos" (car pos)))
  265.      (if accent (item.set_feat token "accent" (car accent)))
  266.      (if tone (item.set_feat token "tone" (car tone)))
  267.      (if phonemes (item.set_feat token "phonemes" 
  268.                        (format nil "%l" phonemes)))
  269.      UTT))
  270. ))
  271.  
  272. (define (soleml_init_func)
  273.   "(soleml_init_func)
  274. Initialisation for SOLEML mode"
  275.   (voice_soleml)
  276.   (set! soleml_previous_elements xxml_elements)
  277.   (set! xxml_elements soleml_elements)
  278.   (set! xxml_token_hooks soleml_token_function)
  279.   (set! soleml_previous_token_to_words english_token_to_words)
  280.   (set! english_token_to_words soleml_token_to_words)
  281.   (set! token_to_words soleml_token_to_words))
  282.  
  283. (define (soleml_exit_func)
  284.   "(soleml_exit_func)
  285. Exit function for SOLEML mode"
  286.   (set! xxml_elements soleml_previous_elements)
  287.   (set! token_to_words soleml_previous_token_to_words)
  288.   (set! english_token_to_words soleml_previous_token_to_words))
  289.  
  290. (define (soleml_token_function si)
  291. "(soleml_token_function si)
  292. This is called for each token found."
  293.   (node.append_daughter sole_current_node si))
  294.  
  295. (define (soleml_push_word_features)
  296. "(soleml_push_word_features)
  297. Save current word features on stack."
  298.   (set! soleml_word_features_stack 
  299.     (cons xxml_word_features soleml_word_features_stack)))
  300.  
  301. (define (soleml_pop_word_features)
  302. "(soleml_pop_word_features)
  303. Pop word features from stack."
  304.   (let ((r (car soleml_word_features_stack)))
  305.     (set! soleml_word_features_stack (cdr soleml_word_features_stack))
  306.     r))
  307.  
  308. (define (soleml_conv_attlist alist)
  309. "(soleml_conv_attlist alist)
  310. Flatten alist arguments."
  311.   (cond
  312.    ((null alist) nil)
  313.    ((null (car (cdr (car alist))))
  314.      (soleml_conv_attlist (cdr alist)))
  315.    ((equal? (length (car (cdr (car alist)))) 1)
  316.     (cons
  317.      (list (car (car alist)) (car (car (cdr (car alist)))))
  318.      (soleml_conv_attlist (cdr alist))))
  319.    (t
  320.     (cons
  321.      (list (car (car alist)) (format nil "%l" (car (cdr (car alist)))))
  322.      (soleml_conv_attlist (cdr alist))))))
  323.  
  324. (set! tts_text_modes
  325.    (cons
  326.     (list
  327.       'soleml   ;; mode name
  328.       (list         ;; email mode params
  329.        (list 'init_func soleml_init_func)
  330.        (list 'exit_func soleml_exit_func)
  331.        '(analysis_type xxml)
  332.        (list 'filter 
  333.          (format nil "%s -D %s " sgml_parse_progname libdir))))
  334.     tts_text_modes))
  335.  
  336. (provide 'soleml-mode)
  337.