home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / share / festival / apml.scm < prev    next >
Encoding:
Text File  |  2006-12-20  |  10.4 KB  |  372 lines

  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;                                                                       ;;
  3. ;;;                Centre for Speech Technology Research                  ;;
  4. ;;;                     University of Edinburgh, UK                       ;;
  5. ;;;                         Copyright (c) 2002                            ;;
  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. ;;;                         Author: Rob Clark
  34. ;;;                         Date:   July 2002
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ;;
  37. ;; Sets up the current voice to synthesise from APML.
  38. ;;
  39. ;;
  40.  
  41. ;; apml sythesis wrappers.
  42.  
  43. (define (apml_client_synth apml)
  44.   "(apml_client_synth apml)
  45. Synthesise apml and return waveform(s) to client."
  46.   (utt.send.wave.client (apml_synth apml)))
  47.  
  48. (define (apml_synth apml)
  49. "(apml_synth xml)
  50. Synthesis an apml string."
  51. (let ((tmpfile (make_tmp_filename))
  52.       utt)
  53.   (string_to_file tmpfile apml)
  54.   (set! utt (apml_file_synth tmpfile))
  55.   (delete-file tmpfile)
  56.   utt))
  57.  
  58. (define (apml_file_synth filename)
  59.   "(apml_file_synth filename)
  60. Synthesis an apml file."
  61.   (let ((utt (Utterance Concept nil)))
  62.     (utt.load utt filename)
  63.     (utt.synth utt)))
  64.  
  65. (define (string_to_file file s)
  66. "(string_to_file file string)
  67.  Write string to file."
  68. (let ((fd))
  69.   (set! fd (fopen file "wb"))
  70.   (format fd "%s" s)
  71.   (fclose fd)))
  72.  
  73.  
  74. ;;;
  75. ;;; Phrasing.
  76. ;;;
  77.  
  78. ;; phrasing CART.
  79. ;
  80. ; This is a first attempt to do something sensible and  will probably change.
  81. ;
  82. (set! apml_phrase_tree
  83.       '
  84.       ((lisp_apml_punc in ("?" "." ":"))         ; big punctuation
  85.        ((BB))
  86.        ((lisp_apml_punc in ("'" "\"" "," ";"))   ; else little punctuation
  87.     ((B))
  88.     ((lisp_apml_is_boundary > 0)             ; else boundary
  89.      ((B))
  90.      ((lisp_apml_is_break > 0)               ; else misc. break information
  91.       ((B))
  92.       ((NB)))))))                            ; else nothing.
  93.  
  94. ;; feature functions for phrasing
  95. (define (apml_punc word)
  96.   (item.feat word 'punc))
  97.  
  98. (define (apml_is_break word)
  99.   0)
  100.  
  101. (define (apml_is_boundary word)
  102.   (if (item.relation word 'Boundary)
  103.       1
  104.       0))
  105.  
  106.  
  107.  
  108. ;;;
  109. ;;; Intonation.
  110. ;;;
  111.  
  112. ;; accent prediction (well transfer really).
  113.  
  114. (set! apml_accent_cart
  115.       '
  116.       ((lisp_apml_accent is "Hstar")
  117.        ((H*))
  118.        ((lisp_apml_accent is "Lstar")
  119.     ((L*))
  120.     ((lisp_apml_accent is "LplusHstar")
  121.      ((L+H*))
  122.      ((lisp_apml_accent is "LstarplusH")
  123.       ((L*+H))
  124.       ((NONE)))))))
  125.  
  126. (set! apml_boundary_cart
  127.       '
  128.       ((lisp_apml_boundary is "LL")
  129.        ((L-L%))
  130.        ((lisp_apml_boundary is "LH")
  131.     ((L-H%))
  132.     ((lisp_apml_boundary is "HH")
  133.      ((H-H%))
  134.      ((lisp_apml_boundary is "HL")
  135.       ((H-L%))
  136.       ((NONE)))))))
  137.  
  138. ;; feature functions.
  139. (define (apml_accent syl)
  140.   (let ((word (item.relation.parent syl 'SylStructure)))
  141.     (if (and (eq (item.feat syl 'stress) 1)
  142.          (item.relation.parent word 'Emphasis))
  143.     (item.feat (item.relation.parent word 'Emphasis) 'x-pitchaccent)
  144.     0)))
  145.          
  146. (define (apml_boundary syl)
  147.   (let ((word (item.relation.parent syl 'SylStructure)))
  148.     (if (and (> (item.feat syl 'syl_break) 0)
  149.          (item.relation.parent word 'Boundary))
  150.     (item.feat (item.relation.parent word 'Boundary) 'type)
  151.     0)))
  152.  
  153. ;; f0 generation.
  154. (require 'apml_f2bf0lr)
  155.  
  156.  
  157. ;;;; feature functions:
  158.  
  159. (define (apml_tgtype syl)
  160.   (let ((l (apml_boundl (item.relation.parent syl 'SylStructure)))
  161.     (r (apml_boundr (item.relation.parent syl 'SylStructure))))
  162.     (if (eq (item.feat syl 'accented) 0)
  163.     0   ; this is a quirk related to the way the models were trained
  164.     (cond
  165.      ((eq l 0)
  166.       1)
  167.      ((eq r 1)
  168.       3)
  169.      (t 2)))))
  170.   
  171.  
  172. (define (apml_iecount syl)
  173.   (if (eq (item.feat syl 'accented) 0)
  174.       0   ; this is a quirk related to the way the models were trained
  175.       (+ (item.feat syl 'asyl_in) 1)))
  176.  
  177. ;; suport functions.
  178. (define (apml_boundl word)
  179. "(apml_boundl word)
  180. Number of boundaries in this performative to the left of this word."
  181.   (let ((w (item.prev word))
  182.     (c 0))
  183.     (while (and w (apml_same_p w word))
  184.        (if (item.relation.parent w 'Boundary)
  185.            (set! c (+ c 1)))
  186.        (set! w (item.prev w)))
  187.     c))
  188.  
  189. (define (apml_boundr word)
  190. "(apml_boundr word)
  191. Number of boundaries in this performative to the right of this word."
  192.   (let ((w word)
  193.     (c 0))
  194.     (while (and w (apml_same_p w word))
  195.        (if (item.relation.parent w 'Boundary)
  196.            (set! c (+ c 1)))
  197.        (set! w (item.next w)))
  198.     c))
  199.  
  200. (define (apml_same_p w1 w2)
  201. "(apml_same_p w1 w2)
  202.  Are these two words in the same performative?"
  203. (let ((p1 (item.parent (item.relation.parent w1 'SemStructure)))
  204.       (p2 (item.parent (item.relation.parent w1 'SemStructure))))
  205. (equal? p1 p2)))
  206.  
  207. ;;;
  208. ;;; segment timings
  209. ;;;
  210.  
  211. (define (apml_seg_times utt)
  212.   "(apml_seg_times utt)
  213. Output the segment timings for an apml utterance."
  214.   (let ((segs (utt.relation.items utt 'Segment)))
  215.     (mapcar
  216.      (lambda (x)
  217.        (format t "%s %s\n" (item.name x) (item.feat x 'end)))
  218.      segs)
  219.     t))
  220.  
  221. ;;;
  222. ;;; Debuging and other useful stuff.
  223. ;;;
  224.  
  225.  
  226.  
  227. (define (apml_print_semstruct utt)
  228. "(apml_print_semstruct utt)
  229. Pretty print APML semantic structure."
  230.   (let ((i (utt.relation.first utt 'SemStructure)))
  231.     (while (not (null i))
  232.        (apml_pss_item 0 i)
  233.        (apml_pss_daughters 1 (item.daughters i))
  234.        (set! i (item.next i)))))
  235.               
  236. (define (apml_pss_daughters depth list)
  237.   (mapcar
  238.    (lambda (x)
  239.      (apml_pss_item depth x)
  240.      (apml_pss_daughters (+ depth 1) (item.daughters x))
  241.      )
  242.    list))
  243.  
  244.  
  245. (define (apml_pss_item depth item)
  246.   (let ((c 0))
  247.     (while (< c depth)
  248.        (format t " ")
  249.        (set! c (+ c 1)))
  250.     (format t "%s\n" (item.name item))))
  251.  
  252.  
  253. (define (apml_print_words utt)
  254. "(apml_print_words utt)
  255.  Pretty print APML words with associated accents."
  256.   (mapcar
  257.    (lambda (x)
  258.      (format t "%s (" (item.name x))
  259.      (apml_pww_accent x)
  260.      (apml_pww_boundary x)
  261.      (format t ")\n"))
  262.    (utt.relation.items utt 'Word))
  263.   t)
  264.  
  265. (define (apml_pww_accent item)
  266.   (let ((p (item.relation.parent item 'Emphasis)))
  267.     (if p (apml_ppw_list (item.features p)))))
  268.  
  269. (define (apml_pww_boundary item)
  270.   (let ((p (item.relation.parent item 'Boundary)))
  271.     (if p (apml_ppw_list (item.features p)))))
  272.  
  273. (define (apml_ppw_list l)
  274.   (mapcar
  275.    (lambda (x)
  276.      (format t " %s" x))
  277.    (flatten l)))
  278.  
  279.  
  280. (define (apml_print_sylstructure utt)
  281. "(apml_print_sylstructure utt)
  282. Pretty print APML syllable structure."
  283.   (mapcar
  284.    (lambda (x)
  285.      (format t "%s\n" (item.name x))
  286.      (apml_psyl x))
  287.    (utt.relation.items utt 'Word))
  288.   t)
  289.  
  290. (define (apml_psyl word)
  291.   (mapcar
  292.    (lambda (x)
  293.      (apml_psegs x)
  294.      (if (eq (item.feat x 'stress) 1)
  295.      (format t " (1)"))
  296.      (if (item.relation.daughter1 x 'Intonation)
  297.      (begin
  298.        (let ((ie (item.relation.daughter1 x 'Intonation)))
  299.          (format t " [")
  300.          (while ie
  301.             (format t "%s" (item.name ie))
  302.             (set! ie (item.next ie))
  303.             (if ie (format t " ")))
  304.          (format t "]"))))
  305.      (format t "\n"))
  306.    (item.daughters (item.relation word 'SylStructure))))
  307.  
  308. (define (apml_psegs syl)
  309.   (let ((segs (item.daughters syl)))
  310.     (format t " ")
  311.     (while segs
  312.        (format t "%s" (item.name (car segs)))
  313.        (if (cdr segs)
  314.            (format t "."))
  315.        (set! segs (cdr segs)))))
  316.  
  317.  
  318. (define (apml_get_lr_params)
  319.   (let ((m (car (cdr (car int_lr_params))))
  320.         (s (car (cdr (car (cdr int_lr_params))))))
  321.     (if (not (> m 0))
  322.         (set! m 100))
  323.     (if (not (> s 0))
  324.         (set! m 20))
  325.     (list m s)))
  326.  
  327.  
  328.  
  329. (define (apml_initialise)
  330.   "(apml_initialise)
  331. Set up the current voice for apml use."
  332.   ;; set up phrasing
  333.   (Parameter.set 'Phrase_Method 'cart_tree)
  334.   (set! phrase_cart_tree apml_phrase_tree)
  335.   ;; Lexicon
  336.   (if (not (member_string "apmlcmu" (lex.list)))
  337.       (load (path-append lexdir "apmlcmu/apmlcmulex.scm")))
  338.   (lex.select "apmlcmu")
  339.   ;; Add other lex entries here:
  340.   (lex.add.entry '("dont" v (((d ow n t) 1))))
  341.   (lex.add.entry '("pectoris" nil (((p eh k) 2) ((t ao r) 1) ((ih s) 0))))
  342.   (lex.add.entry '("sideeffects" nil (((s ay d) 1) ((ax f) 0) ((eh k t s) 2))))
  343.  
  344.   ;; Intonation
  345.   (set! int_accent_cart_tree apml_accent_cart)
  346.   (set! int_tone_cart_tree   apml_boundary_cart)
  347.   (Parameter.set 'Int_Method Intonation_Tree)
  348.   (set! f0_lr_start apml_f2b_f0_lr_start)
  349.   (set! f0_lr_mid apml_f2b_f0_lr_mid)
  350.   (set! f0_lr_end apml_f2b_f0_lr_end)
  351. ;  (set! int_lr_params
  352. ;    '((target_f0_mean 100) (target_f0_std 20)
  353. ;      (model_f0_mean 170) (model_f0_std 34)))
  354.   (set! int_lr_params
  355.     (list (list 'target_f0_mean (car (apml_get_lr_params)))
  356.           (list 'target_f0_std (car (cdr (apml_get_lr_params))))
  357.           (list 'model_f0_mean 170)
  358.           (list 'model_f0_std 34)))
  359.   (Parameter.set 'Int_Target_Method Int_Targets_LR)
  360. t
  361. )
  362.  
  363.  
  364.  
  365. (provide 'apml)
  366.   
  367.   
  368.  
  369.  
  370.  
  371.  
  372.