home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Multimed / Multimed.zip / fest-141.zip / festival / lib / lts_build.scm < prev    next >
Lisp/Scheme  |  1999-06-17  |  18KB  |  566 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. ;;;  Functions for building LTS rules sets from lexicons
  35. ;;;
  36. ;;;
  37.  
  38. (defvar pl-table nil)
  39.  
  40. (define (allaligns phones letters)
  41.   "(cummulate phones lets)
  42. Aligns all possible ways for these strings."
  43.   (cond
  44.    ((null letters)
  45.     ;; (wrongly) assume there are never less letters than phones
  46.     (if phones
  47.     (format t "wrong end: %s\n" word))
  48.     nil)
  49.    ((null phones)
  50.     nil)
  51.    (t
  52.     (if (< (length phones) (length letters))
  53.     (begin
  54.       (cummulate '_epsilon_ (car letters))
  55.       (allaligns phones (cdr letters))))
  56.     (cummulate (car phones) (car letters))
  57.     (allaligns (cdr phones) (cdr letters)))))
  58.  
  59. (define (valid-pair phone letter)
  60.   "(valid-pair phone letter)
  61. If predefined to be valid."
  62.   (let ((entry1 (assoc letter pl-table)))
  63.     (if entry1
  64.     (assoc phone (cdr entry1))
  65.     nil)))
  66.  
  67.  
  68. (define (valid-pair-e phone nphone letter)
  69.   "(valid-pair-e phone letter)
  70. Special cases for when epsilon may be inserted before letter."
  71.   (let ((ll (assoc letter pl-table))
  72.     (pp (intern (string-append phone "-" nphone))))
  73.     (assoc pp (cdr ll))))
  74.  
  75. (define (find-aligns phones letters)
  76.   "(find-aligns phones letters)
  77. Find all feasible alignments."
  78.   (let ((r nil))
  79.     (cond
  80.      ((and (null (cdr phones)) (null (cdr letters))
  81.        (equal? (car phones) (car letters))
  82.        (equal? '# (car phones)))
  83.       (list (list (cons '# '#)))) ;; valid end match
  84.      (t
  85.       (if (valid-pair '_epsilon_ (car letters))
  86.       (set! r (mapcar
  87.            (lambda (p)
  88.              (cons (cons '_epsilon_ (car letters)) p))
  89.            (find-aligns phones (cdr letters)))))
  90.       (if (valid-pair (car phones) (car letters))
  91.       (set! r 
  92.         (append r
  93.             (mapcar
  94.              (lambda (p)
  95.                (cons (cons (car phones) (car letters)) p))
  96.              (find-aligns (cdr phones) (cdr letters))))))
  97.       ;; Hmm, change this to always check doubles
  98.       (if (valid-pair-e (car phones) (car (cdr phones)) (car letters))
  99.       (set! r
  100.         (append r
  101.             (mapcar
  102.              (lambda (p)
  103.                (cons (cons (intern (format nil "%s-%s"
  104.                                (car phones)
  105.                                (car (cdr phones))))
  106.                        (car letters)) p))
  107.              (find-aligns (cdr (cdr phones)) 
  108.                       (cdr letters))))))
  109.       r))))
  110.  
  111. (define (findallaligns phones letters)
  112.   (let ((a (find-aligns phones letters)))
  113.     (if (null a)
  114.     (format t "failed: %l %l\n" letters phones))
  115.     a))
  116.  
  117. (define (cummulate phone letter)
  118.   "(cummulate phone letter)
  119. record the alignment of this phone and letter."
  120.   (if (or (equal? phone letter)
  121.       (and (not (equal? phone '#))
  122.            (not (equal? letter '#))))
  123.   (let ((entry1 (assoc letter pl-table))
  124.     score)
  125.     (if (equal? phone '_epsilon_)
  126.     (set! score 0.1)
  127.     (set! score 1))
  128.     (if entry1
  129.     (let ((entry2 (assoc phone (cdr entry1))))
  130.       (if entry2
  131.           (set-cdr! entry2 (+ score (cdr entry2)))
  132.           (set-cdr! entry1 (cons (cons phone 1) (cdr entry1)))))
  133.     (set! pl-table
  134.           (cons 
  135.            (cons letter
  136.              (list (cons phone score)))
  137.            pl-table)))
  138.     t)))
  139.  
  140. (define (score-pair phone letter)
  141. "(score-pair phone letter)
  142. Give score for this particular phone letter pair."
  143.   (let ((entry1 (assoc letter pl-table)))
  144.     (if entry1
  145.     (let ((entry2 (assoc phone (cdr entry1))))
  146.       (if entry2
  147.           (cdr entry2)
  148.           0))
  149.     0)))
  150.  
  151. (define (cummulate-aligns aligns)
  152.   (mapcar
  153.    (lambda (a)
  154.      (mapcar 
  155.       (lambda (p)
  156.     (cummulate (car p) (cdr p)))
  157.       a))
  158.    aligns)
  159.   t)
  160.  
  161. (define (cummulate-pairs trainfile)
  162.   "(cummulate-pairs trainfile)
  163. Build cummulatation table from allowable alignments in trainfile."
  164.   (if (not pl-table)
  165.       (set! pl-table
  166.         (mapcar
  167.          (lambda (l)
  168.            (cons (car l) (mapcar (lambda (c) (cons c 0)) (cdr l))))
  169.          allowables)))
  170.   (let ((fd (fopen trainfile "r"))
  171.     (c 0) (d 0)
  172.     (entry))
  173.     (while (not (equal? (set! entry (readfp fd)) (eof-val)))
  174.        (if (equal? c 1000)
  175.            (begin
  176.          (format t "ENTRY: %d %l\n" (set! d (+ 1000 d)) entry)
  177.          (set! c 0)))
  178.        (set! word (car entry))
  179.        (cummulate-aligns
  180.         (findallaligns 
  181.          (enworden (car (cdr (cdr entry))))
  182.          (enworden (symbolexplode (car entry)))))
  183.        (set! c (+ 1 c)))
  184.     (fclose fd)))
  185.  
  186. (define (find_best_alignment phones letters)
  187.   "(find_best_alignment phones letters)
  188. Find the alignement containg the most frequent alignment pairs."
  189.   ;; hackily do this as a global
  190.   (set! fba_best_score 0)
  191.   (set! fba_best nil)
  192.   (find-best-align phones letters nil 0)
  193.   fba_best
  194. )
  195.  
  196. (define (find-best-align phones letters path score)
  197.   "(find-best-align phones letters)
  198. Find all feasible alignments."
  199.   (cond
  200.    ((null letters)
  201.     (if (> score fba_best_score)
  202.     (begin
  203.       (set! fba_best_score score)
  204.       (set! fba_best (reverse path))))
  205.     nil)
  206.    (t
  207.     (if (valid-pair '_epsilon_ (car letters))
  208.     (find-best-align phones (cdr letters)
  209.              (cons (cons '_epsilon_ (car letters)) path)
  210.              (+ score (score-pair '_epsilon_ (car letters)))))
  211.     (if (valid-pair (car phones) (car letters))
  212.     (find-best-align (cdr phones) (cdr letters)
  213.              (cons (cons (car phones) (car letters))path)
  214.              (+ score (score-pair (car phones) (car letters)))))
  215.     (if (valid-pair-e (car phones) (car (cdr phones)) (car letters))
  216.     (find-best-align (cdr (cdr phones)) (cdr letters)
  217.              (cons (cons (intern (format nil "%s-%s"
  218.                              (car phones)
  219.                              (car (cdr phones))))
  220.                      (car letters))
  221.                    path)
  222.              (+ score (score-pair 
  223.                    (intern (format nil "%s-%s"
  224.                            (car phones)
  225.                            (car (cdr phones))))
  226.                    (car letters))))))))
  227.  
  228. (define (align_and_score phones letters path score)
  229.   "(align_and_score phones lets)
  230. Aligns all possible ways for these strings."
  231.   (cond
  232.    ((null letters)
  233.     (if (> score fba_best_score)
  234.     (begin
  235.       (set! fba_best_score score)
  236.       (set! fba_best (reverse path))))
  237.     nil)
  238.    (t
  239.     (if (< (length phones) (length letters))
  240.     (align_and_score
  241.      phones
  242.      (cdr letters)
  243.      (cons '_epsilon_ path)
  244.      (+ score
  245.         (score-pair '_epsilon_ (car letters)))))
  246.     (align_and_score
  247.      (cdr phones)
  248.      (cdr letters)
  249.      (cons (car phones) path)
  250.      (+ score
  251.     (score-pair (car phones) (car letters)))))))
  252.  
  253. (define (aligndata file ofile)
  254.   (let ((fd (fopen file "r"))
  255.     (ofd (fopen ofile "w"))
  256.     (c 1)
  257.     (entry))
  258.     (while (not (equal? (set! entry (readfp fd)) (eof-val)))
  259.        (set! lets (enworden (symbolexplode (car entry))))
  260.        (set! bp (find_best_alignment
  261.              (enworden (car (cdr (cdr entry))))
  262.              lets))
  263.        (if (not bp)
  264.            (format t "failed: %l\n" lets)
  265.            (save_info (car (cdr entry)) bp ofd))
  266.        (set! c (+ 1 c)))
  267.     (fclose fd)
  268.     (fclose ofd)))
  269.  
  270. (define (enworden lets)
  271.   (cons '# (reverse (cons '# (reverse lets)))))
  272.  
  273. (define (save_info pos bp ofd)
  274.   "(save_info pos bp ofd)
  275. Cut out one expensive step and 50M of diskspace and just save it
  276. in a simpler format."
  277.   (format ofd "( ")
  278.   (mapcar
  279.    (lambda (l) 
  280.      (if (not (string-equal "#" (cdr l)))
  281.      (format ofd "%s" (cdr l))))
  282.    bp)
  283.   (format ofd " %s" pos)
  284.   (mapcar
  285.    (lambda (l)
  286.      (if (not (string-equal "#" (car l)))
  287.      (format ofd " %s" (car l))))
  288.    bp)
  289.   (format ofd " )\n"))
  290.  
  291. (define (normalise-table pl-table)
  292.   "(normalise-table pl-table)
  293. Change scores into probabilities."
  294.   (mapcar
  295.    (lambda (s)
  296.      (let ((sum (apply + (mapcar cdr (cdr s)))))
  297.        (mapcar
  298.     (lambda (p)
  299.       (set-cdr! p (/ (cdr p) sum)))
  300.     (cdr s))))
  301.    pl-table)
  302.   t)
  303.  
  304. (define (save-table pre)
  305.   (normalise-table pl-table)
  306.   (set! fd (fopen (string-append pre "pl-tablesp.scm") "w"))
  307.   (format fd "(set! pl-table '\n")
  308.   (pprintf pl-table fd)
  309.   (format fd ")\n")
  310.   (fclose fd)
  311.   t)
  312.  
  313. (define (build-feat-file alignfile featfile)
  314. "(build-feat-file alignfile featfile)
  315. Build a feature file from the given align file.  The feature
  316. file contain predicted phone, and letter with 3 preceding and
  317. 3 succeeding letters."
  318.   (let ((fd (fopen alignfile "r"))
  319.     (ofd (fopen featfile "w"))
  320.     (entry)
  321.     (pn)
  322.     (sylpos 1))
  323.     (while (not (equal? (set! entry (readfp fd)) (eof-val)))
  324.        (set! lets (append '(0 0 0 0 #) (symbolexplode (car entry))
  325.                   '(# 0 0 0 0)))
  326.        (set! phones (cdr (cdr entry)))
  327.        (set! pn 5)
  328.        (mapcar
  329.         (lambda (p)
  330.           (format ofd
  331.               "%s  %s %s %s %s  %s  %s %s %s %s  %s\n"
  332.               p
  333.               (nth (- pn 4) lets)
  334.               (nth (- pn 3) lets)
  335.               (nth (- pn 2) lets)
  336.               (nth (- pn 1) lets)
  337.               (nth pn lets)
  338.               (nth (+ pn 1) lets)
  339.               (nth (+ pn 2) lets)
  340.               (nth (+ pn 3) lets)
  341.               (nth (+ pn 4) lets)
  342.               (car (cdr entry)) ;; pos
  343.               ;; sylpos
  344.               ;; numsyls
  345.               ;; num2end
  346.               )
  347.           (set! pn (+ 1 pn)))
  348.         phones))
  349.     (fclose fd)
  350.     (fclose ofd))
  351. )
  352.  
  353. (define (merge_models name filename)
  354. "(merge_models name filename)
  355. Merge the models into a single list of cart trees as a variable
  356. named by name, in filename."
  357.   (require 'cart_aux)
  358.   (let (trees fd)
  359.     (set! trees
  360.       (mapcar 
  361.        (lambda (l)
  362.              (format t "%s\n" l)
  363.          (set! tree (car (load (format nil "lts.%s.tree" l) t)))
  364.          (set! tree (cart_simplify_tree tree nil))
  365.          (list l tree))
  366.        '(a b c d e f g h i j k l m n o p q r s t u v w x y z )
  367.        ))
  368.     (set! fd (fopen filename "w"))
  369.     (format fd ";; LTS rules \n")
  370.     (format fd "(set! %s '\n" name)
  371.     (pprintf trees fd)
  372.     (format fd ")\n")
  373.     (fclose fd))
  374. )
  375.  
  376. (define (lts_testset file cartmodels)
  377.   "(lts_testset file cartmodels)
  378. Test an aligned lexicon file against a set of cart trees.  Prints out
  379. The number of letters correct (for each letter), total number of 
  380. letters correct and the total number of words correct.  cartmodels is
  381. the structure as saved by merge_models."
  382.   (let ((fd (fopen file "r"))
  383.     (entry)
  384.     (wordcount 0)
  385.     (correctwords 0)
  386.     (phonecount 0)
  387.     (correctphones 0))
  388.     (while (not (equal? (set! entry (readfp fd)) (eof-val)))
  389.        (let ((letters (enworden (symbolexplode (car entry))))
  390.          (phones (enworden (cdr (cdr entry))))
  391.          (pphones))
  392.          (set! wordcount (+ 1 wordcount))
  393.          (set! pphones (gen_cartlts letters (car (cdr entry)) cartmodels))
  394. ;         (set! pphones (gen_vilts letters (car (cdr entry))
  395. ;                      cartmodels wfstname))
  396.          (if (equal? (ph-normalize pphones) (ph-normalize phones))
  397.          (set! correctwords (+ 1 correctwords))
  398.          (or nil
  399.              (format t "failed %s %l %l\n" (car entry) phones pphones)))
  400.          (count_correct_letters   ;; exclude #, cause they're always right
  401.           (cdr letters)
  402.           (cdr phones)
  403.           (cdr pphones))
  404.          (set! phonecount (+ (length (cdr (cdr letters))) phonecount))
  405.          ))
  406.     (fclose fd)
  407.     (mapcar
  408.      (lambda (linfo)
  409.        (format t "%s %d correct %d (%2.2f)\n"
  410.            (car linfo) (car (cdr linfo))
  411.            (car (cdr (cdr linfo)))
  412.            (/ (* (car (cdr (cdr linfo))) 100) (car (cdr linfo))))
  413.        (set! correctphones (+ correctphones (car (cdr (cdr linfo))))))
  414.      correct_letter_table)
  415.     (format t "phones %d correct %d (%2.2f)\n"
  416.         phonecount correctphones (/ (* correctphones 100) phonecount))
  417.     (format t "words %d correct %d (%2.2f)\n"
  418.         wordcount correctwords (/ (* correctwords 100) wordcount))
  419.     (format t "tree model has %d nodes\n"
  420.         (apply + (mapcar (lambda (a) (cart_tree_node_count (car (cdr a))))
  421.                  cartmodels)))
  422.     ))
  423.  
  424. (define (cart_tree_node_count tree)
  425.   "(tree_node_count tree)
  426. Count the number nodes (questions and leafs) in the given CART tree."
  427.   (cond
  428.    ((cdr tree)
  429.     (+ 1
  430.        (cart_tree_node_count (car (cdr tree)))
  431.        (cart_tree_node_count (car (cdr (cdr tree))))))
  432.    (t
  433.     1)))
  434.  
  435. (defvar correct_letter_table
  436.   (mapcar
  437.    (lambda (l) (list l 0 0))
  438.    '(a b c d e f g h i j k l m n o p q r s t u v w x y z))
  439.   "correct_letter_table
  440. List used to cummulate the number of correct (and incorrect) letter to
  441. phone predictions.  This list will be extended if there are more letters
  442. in your alphabet, though it doesn't take a fairly western european
  443. view of the alphabet,  but you can change this yourself is necessary.")
  444.  
  445. (define (count_correct_letters lets phs pphs)
  446.  "(count_correct_letters lets phs pphs)
  447. Count which letters have the correct phone prediction.  Cummulate this
  448. is a per letter table."
  449.  (cond
  450.   ((or (null phs) (null pphs) (null lets))
  451.    (format t "misaligned entry\n") 
  452.    nil)
  453.   ((and (null (cdr lets)) (null (cdr phs)) (null (cdr pphs)))
  454.    nil)  ;; omit final #
  455.   (t
  456.    (let ((letinfo (assoc (car lets) correct_letter_table)))
  457.      (if (not letinfo)
  458.      (set! correct_letter_table
  459.            (append correct_letter_table
  460.                (set! letinfo (list (list (car lets) 0 0))))))
  461.      (set-car! (cdr letinfo) (+ 1 (car (cdr letinfo)))) ;; total
  462.      (if (equal? (car phs) (car pphs))                  ;; correct 
  463.      (set-car! (cdr (cdr letinfo)) (+ 1 (car (cdr (cdr letinfo))))))
  464.      (count_correct_letters (cdr lets) (cdr phs) (cdr pphs))))))
  465.  
  466. (define (ph-normalize ph)
  467.   (cond
  468.    ((null ph) nil)
  469.    ((string-equal "_epsilon_" (car ph))
  470.     (ph-normalize (cdr ph)))
  471.    ((string-matches (car ph) ".*-.*")
  472.     (cons
  473.      (string-before (car ph) "-")
  474.      (cons
  475.       (string-after (car ph) "-")
  476.       (ph-normalize (cdr ph)))))
  477.    (t
  478.     (cons (car ph) (ph-normalize (cdr ph))))))
  479.  
  480. (define (make_let_utt_p letters pos)
  481. "(make_let_utt letters)
  482. Build an utterances from th4ese letters."
  483.   (let ((utt (Utterance Text "")))
  484.     (utt.relation.create utt 'LTS)
  485.     (utt.relation.create utt 'LETTER)
  486.     (utt.relation.create utt 'PHONE)
  487.     ;; Create letter stream
  488.     (mapcar
  489.      (lambda (l)
  490.        (let ((lsi (utt.relation.append utt 'LETTER)))
  491.      (item.set_name lsi l)
  492.      (item.set_feat lsi "pos" pos)))
  493.      letters)
  494.     utt))
  495.  
  496. (define (gen_vilts letters pos cartmodels ngram)
  497.   "(get_vilts letters pos cartmodels ngram)
  498. Use cart plus ngrams in viterbi search."
  499.   (require 'lts)
  500.   (let ((utt (make_let_utt_p letters pos)))
  501.     (set! gen_vit_params
  502.       (list
  503.        (list 'Relation "LETTER")
  504.        (list 'return_feat "phone")
  505.        (list 'p_word "#")
  506.        (list 'pp_word "0")
  507.        (list 'wfstname ngram)
  508.        (list 'cand_function 'lts_cand_function)))
  509.     (Gen_Viterbi utt)
  510.     (mapcar 
  511.       (lambda (lsi)
  512.     (intern (item.feat lsi "phone")))
  513.       (utt.relation.items utt 'LETTER))))
  514.  
  515. (define (gen_cartlts letters pos cartmodels)
  516.   "(get_cartlts letters cartmodels)
  517. Generate the full list of predicted phones, including
  518. epsilon and unexpanded multi-phones."
  519.   (require 'lts)
  520.   (let ((utt (make_let_utt_p letters pos)))
  521.     (enworden
  522.      (mapcar
  523.       (lambda (lsi)
  524.     (let ((tree (car (cdr (assoc_string (item.name lsi) cartmodels))))
  525.           (p))
  526.       (if (not tree)
  527.           (begin
  528.         (format t "failed to find tree for %s\n" (item.name lsi))
  529.         nil)
  530.           (begin
  531.         (set! p (wagon_predict lsi tree))
  532.         (item.set_feat lsi "val" p)
  533.         p))))
  534.       (reverse (cdr (reverse (cdr (utt.relation.items utt 'LETTER)))))))))
  535.  
  536. (define (reduce_lexicon entryfile exceptionfile lts_function)
  537.   "(reduce_lexicon entryfile exceptionfile lts_function)
  538. Look up each word in entryfile using the current lexicon, if the entry
  539. doesn't match save it in the exception file.  This is a way of reducing
  540. the lexicon based on a letter to sound model (and lexical stress 
  541. model, if appropriate)."
  542.   (let ((fd (fopen entryfile "r"))
  543.     (ofd (fopen exceptionfile "w"))
  544.     (entry)
  545.     (wordcount 0)
  546.     (correctwords 0))
  547.     (while (not (equal? (set! entry (readfp fd)) (eof-val)))
  548.        (if (and (consp entry) 
  549.             (> (length entry) 1))
  550.            (let ((lts (lts_function (car entry) (car (cdr entry))))
  551.              (encount (lex.entrycount (car entry))))
  552.          (set! wordcount (+ 1 wordcount))
  553.          (if (and (equal? (nth 2 entry) (nth 2 lts))
  554.               (< encount 2))
  555.              (set! correctwords (+ 1 correctwords))
  556.              (format ofd "%l\n" entry))
  557.          )))
  558.     (fclose fd)
  559.     (fclose ofd)
  560.     (format t "words %d correct %d (%2.2f)\n"
  561.         wordcount correctwords (/ (* correctwords 100) wordcount))
  562.     ))
  563.  
  564. (provide 'lts_build)
  565.  
  566.