git.gag.com Git - debian/freetts/blob - tools/FestVoxToFreeTTS/FestVoxDiphoneToFreeTTS.scm

   1 ; Modeled on flite/tools/make_didb.scm.scm
   2 ; Portions Copyright 2003 Sun Microsystems, Inc.
   3 ; Portions Copyright 1999-2003 Language Technologies Institute,
   4 ; Carnegie Mellon University.
   5 ; All Rights Reserved.  Use is subject to license terms.
   6 ;
   7 ; See the file "license.terms" for information on usage and
   8 ; redistribution of this file, and for a DISCLAIMER OF ALL
   9 ; WARRANTIES.
  10 ;
  11 ; Convert festvox voice to FreeTTS
  12
  13 ; I'm not sure why these are hard-coded here, but I think they should
  14 ; be left that way unless changed in the equivalent flite program
  15 (defvar lpc_min -7.992630)
  16 (defvar lpc_max  7.829990)
  17
  18 ; Dump a diphone voice to text
  19 (define (dump_diphone name voicedir outdir header_filename data_filename diphindexfn)
  20   (let ((diphindex (load diphindexfn t))
  21         (header_file (fopen (format nil "%s/%s" outdir header_filename) "w"))
  22         (data_file (fopen (format nil "%s/%s" outdir data_filename) "w"))
  23         (stsdir (string-append voicedir "/sts"))
  24        )
  25
  26     (set! pm_pos 0)
  27
  28     ; Print data
  29     (while diphindex
  30      (set! pms (find_pm_pos
  31         (car diphindex)
  32         stsdir
  33         data_file))
  34
  35         (format data_file "DIPHONE %s %d %d %d\n"
  36             (nth 0 pms)
  37             (nth 2 pms)
  38             (nth 3 pms)
  39             (nth 4 pms))
  40         (print_data (nth 1 pms) data_file)
  41     (set! diphindex (cdr diphindex)))
  42
  43     ; Print header
  44     (format header_file "NAME %s\n" name)
  45     (format header_file "SAMPLE_RATE %d\n" sample_rate)
  46     (format header_file "NUM_CHANNELS %d\n" lpc_order)
  47     (format header_file "COEFF_MIN %f\n" lpc_min)
  48     (format header_file "COEFF_RANGE %f\n" lpc_range)
  49
  50     (fclose header_file)
  51     (fclose data_file)
  52 ))
  53
  54 ; Print the data for an individual diphone
  55 (define (print_data entries data_file)
  56     (cond
  57      (entries (cond
  58         ((string-equal (caar entries) "frame")
  59             (format data_file "FRAME     ")
  60             (print_nums (cdr (car entries)) data_file)
  61         )
  62         ((string-equal (caar entries) "residual")
  63             (format data_file "RESIDUAL %d     " (cadr (car entries)))
  64             (print_nums (cddr (car entries)) data_file)
  65         ))
  66       (print_data (cdr entries) data_file)
  67     ))
  68 )
  69
  70 ; Recursively print a list of integers to data file, terminating with a newline
  71 (define (print_nums numlist data_file)
  72     (cond (numlist
  73             (format data_file "%d " (car numlist))
  74             (print_nums (cdr numlist) data_file)
  75         )
  76         (t (format data_file "\n"))
  77     )
  78 )
  79
  80
  81 (define (find_pm_pos entry stsdir)
  82   "(find_pm_pos entry stsdir)
  83 Diphone dics give times in seconds here we want them as indexes.  This
  84 function converts the lpc to ascii and finds the pitch marks that
  85 go with this unit.  These are written with ulaw residual
  86 as short term signal."
  87   (let ((sts_coeffs (load
  88                      (format nil "%s/%s.sts" stsdir (cadr entry))
  89                      t))
  90         (start_time (nth 2 entry))
  91         (phoneboundary_time (nth 3 entry))
  92         (end_time (nth 4 entry))
  93         start_pm pb_pm end_pm)
  94     (format t "%l\n" entry)
  95     (set! outlist nil)
  96     (set! sts_info (car sts_coeffs))
  97     (set! sts_coeffs (cdr sts_coeffs))
  98     (while (and sts_coeffs
  99             (> (absdiff start_time (car (car sts_coeffs)))
 100               (absdiff start_time (car (cadr sts_coeffs)))))
 101      (set! sts_coeffs (cdr sts_coeffs)))
 102     (set! sample_rate (nth 2 sts_info))
 103     (set! lpc_order (nth 1 sts_info))
 104     (set! lpc_min (nth 3 sts_info))
 105     (set! lpc_range (nth 4 sts_info))
 106     (set! start_pm pm_pos)
 107     (while (and sts_coeffs
 108             (> (absdiff phoneboundary_time (car (car sts_coeffs)))
 109                (absdiff phoneboundary_time (car (cadr sts_coeffs)))))
 110      (output_sts (car sts_coeffs))
 111      (set! sts_coeffs (cdr sts_coeffs)))
 112     (set! pb_pm pm_pos)
 113     (while (and sts_coeffs (cdr sts_coeffs)
 114             (> (absdiff end_time (car (car sts_coeffs)))
 115                (absdiff end_time (car (cadr sts_coeffs)))))
 116      (output_sts (car sts_coeffs))
 117      (set! sts_coeffs (cdr sts_coeffs)))
 118     (set! end_pm pm_pos)
 119
 120     (list
 121      (car entry)
 122      (reverse outlist) ;was (cadr entry) in awb code.
 123      start_pm
 124      pb_pm
 125      end_pm)))
 126
 127 (define (output_sts frame)
 128   "(output_sts frame)
 129 Ouput this LPC frame."
 130   (let ((time (nth 0 frame))
 131         (coeffs (nth 1 frame))
 132         (size (nth 2 frame))
 133         (r (nth 3 frame)))
 134
 135     ; Build frame
 136     (set! framevals nil)
 137     (while (cdr coeffs)
 138      (set! framevals (cons (car coeffs) framevals))
 139      (set! coeffs (cdr coeffs))
 140      (if (not (cdr coeffs)) (set! framevals (cons (car coeffs) framevals))))
 141     (set! outlist (cons (cons "frame" (reverse framevals)) outlist))
 142
 143     ; Build residual
 144     (set! resvals nil)
 145     (while (cdr r)
 146      (set! resvals (cons (car r) resvals))
 147      (set! r (cdr r))
 148      (if (not (cdr r)) (set! resvals (cons (car r) resvals))))
 149     (set! outlist
 150         (cons (cons "residual" (cons size (reverse resvals))) outlist))
 151
 152     (set! pm_pos (+ 1 pm_pos))
 153 ))
 154
 155 (define (absdiff a b)
 156   (let ((d (- a b )))
 157     (if (< d 0)
 158         (* -1 d)
 159         d)))