;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                     ;;;
;;;                  Language Technologies Institute                    ;;;
;;;                     Carnegie Mellon University                      ;;;
;;;                      Copyright (c) 2007-2009                        ;;;
;;;                        All Rights Reserved.                         ;;;
;;;                                                                     ;;;
;;; Permission is hereby granted, free of charge, to use and distribute ;;;
;;; this software and its documentation without restriction, including  ;;;
;;; without limitation the rights to use, copy, modify, merge, publish, ;;;
;;; distribute, sublicense, and/or sell copies of this work, and to     ;;;
;;; permit persons to whom this work is furnished to do so, subject to  ;;;
;;; the following conditions:                                           ;;;
;;;  1. The code must retain the above copyright notice, this list of   ;;;
;;;     conditions and the following disclaimer.                        ;;;
;;;  2. Any modifications must be clearly marked as such.               ;;;
;;;  3. Original authors' names are not deleted.                        ;;;
;;;  4. The authors' names are not used to endorse or promote products  ;;;
;;;     derived from this software without specific prior written       ;;;
;;;     permission.                                                     ;;;
;;;                                                                     ;;;
;;; CARNEGIE MELLON UNIVERSITY AND THE CONTRIBUTORS TO THIS WORK        ;;;
;;; DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING     ;;;
;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT  ;;;
;;; SHALL CARNEGIE MELLON UNIVERSITY NOR THE CONTRIBUTORS BE LIABLE     ;;;
;;; FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   ;;;
;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN  ;;;
;;; AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,         ;;;
;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF      ;;;
;;; THIS SOFTWARE.                                                      ;;;
;;;                                                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;             Author: Alan W Black (awb@cs.cmu.edu)                   ;;;
;;;               Date: November 2007                                   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                     ;;;
;;; Convert a clustergen voice to flite                                 ;;;
;;;                                                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Used for getting smaller models, if non-zero this will reduce the 
;; order of the dumped models from whatever it is (probably 24) to this
;; It does the right thing with statics and dynamics and stddev
(defvar cg_reduced_order 0)
(if (> cg_reduced_order 0) ;; just to remind me
    (format t "\n***** CG: note reducing order to %d *****\n\n" 
            cg_reduced_order))
(defvar F0MEAN 0.0)
(defvar F0STD 1.0)

(define (cg_convert name festvoxdir odir)
  "(cg_convert name clcatfn clcatfnordered cltreesfn festvoxdir odir)
Convert a festvox clunits (processed) voice into a C file."

   (load (format nil "%s/festvox/%s_cg.scm" festvoxdir name))
   (eval (list (intern (format nil "voice_%s_cg" name))))

   (set! ofd (fopen (path-append odir (string-append name "_cg.c")) "w"))
   (format ofd "/*****************************************************/\n")
   (format ofd "/**  Autogenerated clustergen voice for %s    */\n" name)
   (format ofd "/*****************************************************/\n")
   (format ofd "\n")
   (format ofd "#include \"cst_string.h\"\n")
   (format ofd "#include \"cst_cg.h\"\n")
   (format ofd "#include \"cst_cart.h\"\n")

   (format t "cg_convert: converting F0 trees\n")
   ;; F0 trees
   (set! val_table nil) ;; different val number over the two sets of carts
   (cg_convert_carts 
    (load (format nil "festival/trees/%s_f0.tree" name) t)
    "f0" name odir)
   (format ofd "\n")
   (format ofd "extern const cst_cart * const %s_f0_carts[];\n" name )

   ;; spectral trees
   (set! val_table nil) ;; different val number over the two sets of carts

   (if cg:multimodel
       (begin ;; MULTIMODAL
         (format t "cg_convert: converting static spectral trees\n")
         (set! mfd (fopen (path-append odir "paramfiles.mak") "w"))
         (format mfd "PARAMMODEL=multimodel\n")
         (fclose mfd)
         (set! old_carttoC_extract_answer carttoC_extract_answer)
         (set! carttoC_extract_answer carttoC_extract_spectral_frame)
         (cg_convert_carts 
          (load (format nil "festival/trees/%s_mcep_static.tree" name) t)
          "static_mcep" name odir)
         (set! carttoC_extract_answer old_carttoC_extract_answer)
         (format ofd "\n")
         (format ofd "extern const cst_cart * const %s_static_mcep_carts[];\n" name )

         ;; spectral params
         (format t "cg_convert: converting static spectral params\n")
         (cg_convert_params
          (format nil "festival/trees/%s_mcep_static.params" name)
          (format nil "festival/trees/%s_min_range.scm" name)
          name "static" odir ofd)
         (format ofd "extern const unsigned short * const %s_static_model_vectors[];\n" name )

         (set! val_table nil)
         (format t "cg_convert: converting delta spectral trees\n")
         (set! old_carttoC_extract_answer carttoC_extract_answer)
         (set! carttoC_extract_answer carttoC_extract_spectral_frame)
         (cg_convert_carts 
          (load (format nil "festival/trees/%s_mcep_delta.tree" name) t)
          "delta_mcep" name odir)
         (set! carttoC_extract_answer old_carttoC_extract_answer)
         (format ofd "\n")
         (format ofd "extern const cst_cart * const %s_delta_mcep_carts[];\n" name )

         ;; spectral params
         (format t "cg_convert: converting delta spectral params\n")
         (cg_convert_params
          (format nil "festival/trees/%s_mcep_delta.params" name)
          (format nil "festival/trees/%s_min_range.scm" name)
          name "delta" odir ofd)
         (format ofd "extern const unsigned short * const %s_delta_model_vectors[];\n" name )

         )
       (begin ;; SINGLE MODEL
         (format t "cg_convert: converting single spectral trees\n")
         (set! mfd (fopen (path-append odir "paramfiles.mak") "w"))
         (format mfd "PARAMMODEL=single\n")
         (fclose mfd)
         (set! old_carttoC_extract_answer carttoC_extract_answer)
         (set! carttoC_extract_answer carttoC_extract_spectral_frame)

         (cg_convert_carts 
          (load (format nil "festival/trees/%s_mcep.tree" name) t)
          "single_mcep" name odir)
         (set! carttoC_extract_answer old_carttoC_extract_answer)
         (format ofd "\n")
         (format ofd "extern const cst_cart * const %s_single_mcep_carts[];\n" name )

         ;; spectral params
         (format t "cg_convert: converting single spectral params\n")
         (cg_convert_params
          (format nil "festival/trees/%s_mcep.params" name)
          (format nil "festival/trees/%s_min_range.scm" name)
          name "single" odir ofd)
         (format ofd "extern const unsigned short * const %s_single_model_vectors[];\n" name )
         ))
    
   ;; duration model (car conversion)
   (format t "cg_convert: converting duration model\n")
   (cg_convert_durmodel
    (format nil "festvox/%s_durdata_cg.scm" name)
    name odir)   
   (format ofd "extern const dur_stat * const %s_dur_stats[];\n" name)
   (format ofd "extern const cst_cart %s_dur_cart;\n" name)

   ;; phone to states
   (format t "cg_convert: converting phone to state map\n")
   (cg_phone_to_states 
    (format nil "festvox/%s_statenames.scm" name)
    name odir)
   (format ofd "extern const char * const *%s_phone_states[];\n" name)

   (format ofd "\n")
   (format ofd "const char * const %s_types[] = {\n" name)
   (mapcar
    (lambda (cart)
      (format ofd "   \"%s\",\n" (car cart)))
    (load (format nil "festival/trees/%s_f0.tree" name) t))
   (format ofd "   NULL};\n")
   (format ofd "#define %s_num_types  %d\n\n"
           name
           (length (load (format nil "festival/trees/%s_f0.tree" name) t)))

   (format ofd "const float %s_model_min[] = { \n" name)
   (mapcar
    (lambda (p)
      (format ofd "   %f,\n" (car p)))
    (reverse new_min_range))
   (format ofd "};\n")
   (format ofd "const float %s_model_range[] = { \n" name)
   (mapcar
    (lambda (p)
      (format ofd "   %f,\n" (cadr p)))
    (reverse new_min_range))
   (format ofd "};\n")

   (format ofd "const float %s_dynwin[] = { -0.5, 0.0, 0.5 };\n" name)
   (format ofd "#define %s_dynwinsize 3\n" name)

   (if cg:mixed_excitation
       (begin
         (set! memf me_mix_filters)
         (set! n 0)
         (while (< n 5)
            (format ofd "const double %s_me_filter_%d[] = {\n" name n)
            (set! o 0)
            (while (< o 47)
               (format ofd "%f, " (car memf))
               (set! memf (cdr memf))
               (set! o (+ o 1)))
            (format ofd "%f\n};\n" (car memf))
            (set! memf (cdr memf))
            (set! n (+ n 1))
         )
         (if memf
             (format t "Error still %d values left in me_filter\n"
                     (length memf)))
         (format ofd "const double * const %s_me_h[] = {\n" name)
         (format ofd "   %s_me_filter_0,\n" name)
         (format ofd "   %s_me_filter_1,\n" name)
         (format ofd "   %s_me_filter_2,\n" name)
         (format ofd "   %s_me_filter_3,\n" name)
         (format ofd "   %s_me_filter_4\n" name)
         (format ofd "};\n\n")
         ))

   (format ofd "const cst_cg_db %s_cg_db = {\n" name)
   (format ofd "  \"%s\",\n" name)
   (format ofd "  %s_types,\n" name)
   (format ofd "  %s_num_types,\n" name)
   (format ofd "  16000,\n") ;; sample rate

   (format ofd "  %f,%f,\n" F0MEAN F0STD) 

   (format ofd "  %s_f0_carts,\n" name)
   (if cg:multimodel
       (begin
         (format ofd "  %s_static_mcep_carts,\n" name)
         (format ofd "  %s_delta_mcep_carts,\n" name) 
         (format ofd "  NULL,\n")

         (format ofd "  %s_static_num_channels,\n" name)
         (format ofd "  %s_static_num_frames,\n" name)
         (format ofd "  %s_static_model_vectors,\n" name)

         (format ofd "  %s_delta_num_channels,\n" name)
         (format ofd "  %s_delta_num_frames,\n" name)
         (format ofd "  %s_delta_model_vectors,\n" name)

         (format ofd "  0,0,NULL,\n")
        )
       (begin
         (format ofd "  %s_single_mcep_carts,\n" name)
         (format ofd "  NULL,NULL,\n")

         (format ofd "  %s_single_num_channels,\n" name)
         (format ofd "  %s_single_num_frames,\n" name)
         (format ofd "  %s_single_model_vectors,\n" name)
         (format ofd "  0,0,NULL,\n")
         (format ofd "  0,0,NULL,\n")))

   (format ofd "  %s_model_min,\n" name)
   (format ofd "  %s_model_range,\n" name)
   (format ofd "  %f, /* frame_advance */\n" cg:frame_shift)

   (format ofd "  %s_dur_stats,\n" name)
   (format ofd "  &%s_dur_cart,\n" name)
   (format ofd "  %s_phone_states,\n" name)

   (format ofd "  1, /* 1 if mlpg required */\n")
   (format ofd "  %s_dynwin,\n" name)
   (format ofd "  %s_dynwinsize,\n" name)

   (format ofd "  %f, /* mlsa_alpha */\n" mlsa_alpha_param)
   (format ofd "  %f, /* mlsa_beta */\n" mlsa_beta_param)

   (if cg:multimodel
       (format ofd "  1, /* cg:multimodel */\n")
       (format ofd "  0, /* cg:multimodel */\n"))

   (if cg:mixed_excitation
       (begin
         (format ofd "  1, /* cg:mixed_excitation */\n")
         (format ofd "  5,48, /* filter sizes */\n")
         (format ofd "  %s_me_h \n" name))
       (begin
         (format ofd "  0, /* cg:mixed_excitation */\n")
         (format ofd "  0,0, /* cg:mixed_excitation */\n")
         (format ofd "  NULL \n")))
   (format ofd "};\n")

   (fclose ofd)
)

(define (unit_type u)
  (apply
   string-append
   (reverse
    (symbolexplode 
     (string-after 
      (apply
       string-append
       (reverse (symbolexplode u)))
      "_")))))

(define (unit_occur u)
  (apply
   string-append
   (reverse
    (symbolexplode 
     (string-before
      (apply
       string-append
       (reverse (symbolexplode u)))
      "_")))))

(define (cg_convert_durmodel durmodelfn name odir)

  (set! durmodel (load durmodelfn t))
  (set! phonedurs (cadr (car (cddr (car durmodel)))))
  (set! zdurtree (cadr (car (cddr (cadr durmodel)))))

  (set! dfd (fopen (path-append odir (string-append name "_cg_durmodel.c")) "w"))
  (set! dfdh (fopen (path-append odir (string-append name "_cg_durmodel.h")) "w"))
  (format dfd "/*****************************************************/\n")
  (format dfd "/**  Autogenerated durmodel_cg for %s    */\n" name)
  (format dfd "/*****************************************************/\n")

  (format dfd "#include \"cst_synth.h\"\n")
  (format dfd "#include \"cst_string.h\"\n")
  (format dfd "#include \"cst_cart.h\"\n")
  (format dfd "#include \"%s_cg_durmodel.h\"\n\n" name)

  (mapcar
   (lambda (s)
     (format dfd "static const dur_stat dur_state_%s = { \"%s\", %f, %f };\n"
             (cg_normal_phone_name (car s)) 
             (car s) (car (cdr s)) (car (cddr s)))
     )
   phonedurs)
  (format dfd "\n")

  (format dfd "const dur_stat * const %s_dur_stats[] = {\n" name)
  (mapcar
   (lambda (s)
     (format dfd "   &dur_state_%s,\n" (cg_normal_phone_name (car s))))
   phonedurs)  
  (format dfd "   NULL\n};\n")

  (set! val_table nil)
  (set! current_node -1)
  (set! feat_nums nil)
  (do_carttoC dfd dfdh 
              (format nil "%s_%s" name "dur")
              zdurtree)

  (fclose dfd)
  (fclose dfdh)
)

(define (cg_phone_to_states phonestatefn name odir)

  (set! dfd (fopen (path-append odir (string-append name "_cg_phonestate.c")) "w"))
  (format dfd "/*****************************************************/\n")
  (format dfd "/**  Autogenerated phonestate_cg for %s    */\n" name)
  (format dfd "/*****************************************************/\n")

  (set! phonestates (load phonestatefn t))

  (mapcar
   (lambda (x)
     (format dfd "const char * const %s_%s_ps[] = { " name 
             (cg_normal_phone_name (car x)))
     (mapcar 
      (lambda (y) (format dfd "\"%s\", " y))
      x)
     (format dfd " 0};\n"))
   (cadr (caddr (car phonestates))))

  (format dfd "const char * const * const %s_phone_states[] = {\n" name)
  (mapcar
   (lambda (x)
     (format dfd "   %s_%s_ps,\n" name 
             (cg_normal_phone_name (car x))))
   (cadr (caddr (car phonestates))))
  (format dfd "   0};\n")

  (fclose dfd)
)

(define (cg_convert_params mcepfn mcepminrangefn name type odir cofd)
  (let ((param.track (track.load mcepfn))
        (i 0) (mfd))

    (set! mfd (fopen (path-append odir (string-append name "_cg_" type "_params.c")) "w"))
    (format mfd "/*****************************************************/\n")
    (format mfd "/**  Autogenerated model_vectors for %s    */\n" name)
    (format mfd "/*****************************************************/\n")
    (set! num_channels (track.num_channels param.track))
    (set! num_frames (track.num_frames param.track))
    ;; Output each frame
    (set! mcep_min_range (load mcepminrangefn t))
    (while (< i num_frames)
       (output_param_frame name type param.track i mfd)      
       (set! i (+ 1 i)))
    (format mfd "\n\n")
    ;; Output each frame
    (format mfd "const unsigned short * const %s_%s_model_vectors[] = {\n" name type)
    (set! i 0)
    (while (< i num_frames)
       (format mfd "   %s_%s_param_frame_%d,\n" name type i)
       (set! i (+ 1 i)))
    (format mfd "};\n\n")

    (if (> cg_reduced_order 0)
        (format cofd "#define %s_%s_num_channels %d\n" 
                name type (+ 4 (* 4 cg_reduced_order)))
        (format cofd "#define %s_%s_num_channels %d\n" name type num_channels))

    (format cofd "#define %s_%s_num_frames %d\n" name type num_frames)

    (fclose mfd)

))

(define (mcepcoeff_norm c min range)
  (* (/ (- c min) range) 65535))

(define (output_param_frame name type track f ofd)
  "(output_param_frame name track frame ofd)
Ouput this frame."
  (let ((i 0) (nc (track.num_channels track)))
    (format ofd "static const unsigned short %s_%s_param_frame_%d[] = { \n" name type f)
    (set! min_range mcep_min_range)
    (set! real_order (/ (- nc 4) 4))
    (set! new_min_range nil)
      
    (while (< i nc)
       (if (or (eq cg_reduced_order 0)
               (< i (* 2 (+ 1 cg_reduced_order))) ;; static and static_stddev
               (and (> i (- (/ nc 2) 1))  ;; deltas and delta_stddev
                    (< i (+ (/ nc 2) (* 2 cg_reduced_order))))
               (> i (- nc 3)))
           (begin
            ; (format t "i is %d %d\n" i (+ (/ nc 2) (* 2 cg_reduced_order)))
             (format ofd " %d," 
                     (mcepcoeff_norm 
                      (track.get track f i)
                      (caar min_range)
                      (cadr (car min_range))))
             (set! new_min_range (cons (car min_range) new_min_range))
             ))
       (set! min_range (cdr min_range))
       (set! i (+ 1 i)))
    (format ofd " };\n")
    )
)

(define (carttoC_extract_spectral_frame ofdh tree)
  "(carttoC_extract_spectral_frame tree)
Get list of answers from leaf node."
  (carttoC_val_table ofdh 
		     (car (car tree))
		     'none))

(define (cg_convert_carts carts prefix name odir)
 "(define cg_convert_carts cartfn name)
Output cg selection carts into odir/name_carts.c"
 (let (ofd ofdh)
   ;; Set up to dump full list of things at leafs
   ;; default processing of leaf (int or float) is fine

   (set! ofd (fopen (format nil "%s/%s_cg_%s_trees.c" odir name prefix) "w"))
   (set! ofdh (fopen (format nil "%s/%s_cg_%s_trees.h" odir name prefix) "w"))
   (format ofd "/*****************************************************/\n")
   (format ofd "/**  Autogenerated %s %s carts    */\n" name prefix)
   (format ofd "/*****************************************************/\n")
   (format ofd "\n")
   (format ofd "#include \"cst_string.h\"\n")
   (format ofd "#include \"cst_cart.h\"\n")
   (format ofd "#include \"%s_cg_%s_trees.h\"\n" name prefix)

   (mapcar
    (lambda (cart)
      (if (string-equal "string" (typeof (car cart)))
          (begin
            (set! current_node -1)
            (set! feat_nums nil)
            (do_carttoC ofd ofdh 
                        (format nil "%s_%s_%s" name prefix 
                                (cg_normal_phone_name (car cart)))
                        (cadr cart)))))
    carts)
 
   (format ofd "\n\n")
   (format ofd "const cst_cart * const %s_%s_carts[] = {\n" name prefix)
   (mapcar
    (lambda (cart)
      (if (string-equal "string" (typeof (car cart)))
          (format ofd " &%s_%s_%s_cart,\n" name prefix 
                  (cg_normal_phone_name (car cart))))
      )
    carts)
   (format ofd " 0 };\n")

   (fclose ofd)
   (fclose ofdh)

   )
)

(define (cg_normal_phone_name x)
  ;; Some phonenames aren't valid C labels
  (cond
   ((string-matches x ".*@.*" x) 
    (intern
     (string-append
      (string-before x "@")
      "atsign"
      (string-after x "@"))))
   ((string-matches x ".*:.*")
    (intern
     (string-append
      (string-before x ":")
      "sc"
      (string-after x ":"))))
   (t x)))

(provide 'make_cg)