;; ==================================================-*-mode:scheme-*-
;; Copyright (c) 1996-2000 Carnegie Mellon University.  All rights 
;; reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer. 
;;
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in
;;    the documentation and/or other materials provided with the
;;    distribution.
;;
;; 3. The names "Sphinx" and "Carnegie Mellon" must not be used to
;;    endorse or promote products derived from this software without
;;    prior written permission. To obtain permission, contact 
;;    sphinx@cs.cmu.edu.
;;
;; 4. Redistributions of any form whatsoever must retain the following
;;    acknowledgment:
;;    "This product includes software developed by Carnegie
;;    Mellon University (http://www.speech.cs.cmu.edu/)."
;;
;; THIS SOFTWARE IS PROVIDED BY CARNEGIE MELLON UNIVERSITY ``AS IS'' AND 
;; ANY EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 
;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY
;; NOR ITS EMPLOYEES BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Analyse transcripts to find out what words eixts and collected
;; their pronunciations
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Because this is a --script type file it has to explicitly
;;; load the initfiles: init.scm and user's .festivalrc
(if (not (symbol-bound? 'caar))
    (begin
      (load (path-append libdir "init.scm"))
      (if (probe_file (format nil "%s/.festivalrc" (getenv "HOME")))
	  (load (format nil "%s/.festivalrc" (getenv "HOME"))))))


(define (make_dict_help)
  (format t "%s\n"
  "make_dict [options] txt/*
  Build a dictionary of words in transcripts and missing/unpronouncable words
  Options
  -eval <file>
             Load in scheme file with run specific code, if file name
             starts with a left parent the string itself is interpreted.
             This can be used to select the appropriate phoneset.
  -out_dir <directory>
             Directory where the dicts will placed (default \"etc/\")
  -noise_dict <ifile>
             File containing list of words to be classified as noise (filler).
  -extra_dict <ifile>
             File containing list of extra words to allow.
  -lexicon LEXNAME
             Festival lexicon to use (e.g. CMU, CMU, CMUSPHINX2)
  -lab_ext <string>
             File extention for label files (default \".lab\")
")
  (quit))

(set! st_eou_tree 
  '((n.whitespace matches ".*\n.*")  ;; breaks at new lines
    ((1))
    ((0))))
(set! st.token.punctuation ".,")
(set! st.token.prepunctuation "")
(set! st.token.whitespace " \t\n\r")
(set! st.token.singlecharsymbols "")

(defvar out_dir "etc/")
(defvar known_words nil)
(defvar unknown_words nil)
(defvar noise_words nil)
(defvar extra_words nil)
(defvar transcript_file nil)
;(defvar lexicon 'CMUSPHINX2)
(defvar lexicon 'cmu)

;;; Get options
(define (get_options)
  (let ((files nil) (o argv))
    (if (or (member_string "-h" argv)
	    (member_string "-help" argv)
	    (member_string "--help" argv)
	    (member_string "-?" argv))
	(make_dict_help))
    (while o
      (begin
	(cond
	 ((string-equal "-eval" (car o))
	  (if (not (cdr o))
	      (make_dict_error "no file specified to load"))
	  (if (string-matches (car (cdr o)) "^(.*")
	      (eval (read-from-string (car (cdr o))))
	      (load (car (cdr o))))
	  (set! o (cdr o)))
	 ((string-equal "-out_dir" (car o))
	  (if (not (cdr o))
	      (make_dict_error "no output directory specified"))
	  (set! out_dir (car (cdr o)))
	  (set! o (cdr o)))
	 ((string-equal "-noise_dict" (car o))
	  (if (not (cdr o))
	      (make_dict_error "no noise_dict specified"))
	  (set! noise_words (load_dict_list (car (cdr o))))
	  (set! o (cdr o)))
	 ((string-equal "-extra_dict" (car o))
	  (if (not (cdr o))
	      (make_dict_error "no extra_dict specified"))
	  (load_extra_dict (car (cdr o)))
	  (set! o (cdr o)))
	 ((string-equal "-lexicon" (car o))
	  (if (not (cdr o))
	      (make_dict_error "no extra_dict specified"))
	  (set! lexicon (car (cdr o)))
	  (set! o (cdr o)))
	 (t
	  (set! files (cons (car o) files))))
	(set! o (cdr o))))
    (if (not (equal? 1 (length files)))
	(make_dict_help))
    (set! transcript_file (car files))
))

(define (add_noise_dict_list utt)
  (set! noise_words
	(cons 
	 (item.name (utt.relation.first utt 'Token))
	 noise_words)))

(define (load_dict_list filename)
  (set! noise_words nil)
  (set! tts_hooks add_noise_dict_list)
  (tts filename nil)
)

(define (add_extra_word_list utt)
  (set! known_words
	(cons 
	 (upcase (item.name (utt.relation.first utt 'Token)))
	 known_words))
  (format t "name %s\n" (car known_words))
  (set! extra_words
	(cons
	 (mapcar item.name (utt.relation.items utt 'Token))
	 extra_words))
  (set-car! 
   (car extra_words)
   (upcase (caar extra_words)))
  utt)

(define (load_extra_dict filename)
  (set! extra_words nil)
  (set! tts_hooks add_extra_word_list)
  (tts filename nil)
)

(define (make_dict_error message)
  (format stderr "%s: %s\n" "make_dict" message)
  (make_dict_help))

(define (lex_check utt)
  (let ((tokens (utt.relation.items utt 'Token)))
    (format t "%s\n" (item.name (car (last tokens))))
    (mapcar
     (lambda (token)
       (let ((name (upcase (item.name token))))
	 (cond
	  ((string-matches name "[-a-zA-Z]*") 
	   (cond
	    ((lex.lookup_all name)
	     (if (not (member_string name known_words))
		 (set! known_words (cons name known_words))))
	    ((member_string name known_words)
	     t)
	    (t
	     (set! unknown_words (cons name unknown_words)))))
	  ((or (member_string name unknown_words)
	       (member_string name known_words)
	       (member_string name noise_words))
	   t)
	  (t
	   (set! unknown_words (cons name unknown_words))))))
     (reverse (cdr (reverse tokens))))
  utt))

(define (output_word_pronunciation fd w)
  (let ((lll (lex.lookup w nil)))
    (format fd "%s" w)
    (format fd (format nil "%%%ds" 
		       (if (> (length w) 19)
			   1
			   (- 20 (length w))))
	    " ")
    (mapcar
     (lambda (syl)
       (mapcar 
	(lambda (seg)
	  ;; Let's just upcase this for CMUSPHINX2 phones
	  (format fd "%s " (upcase seg)))
	(car syl)))
     (car (cddr lll)))
    (format fd "\n")))

(define (make_dict_main)

  (set! eou_tree st_eou_tree)
  (set! token.punctuation st.token.punctuation)
  (set! token.prepunctuation st.token.prepunctuation)
  (set! token.whitespace st.token.whitespace)
  (set! token.singlecharsymbols st.token.singlecharsymbols)

  (get_options)

  (lex.select lexicon)

  (format t "known words is %d\n" (length known_words))

  (set! tts_hooks lex_check)
  (set_backtrace t)
  (tts transcript_file 'nil)
  
  (let (unk_fd word_fd noise_fd)
    ;; words we couldn't find 
    (set! unk_fd (fopen (path-append out_dir "word.unknown") "w"))
    (mapcar 
     (lambda (w)
       (format unk_fd "%s\n" w))
     unknown_words)
    (fclose unk_fd)
    (format t "%d word unfound\n" (length unknown_words))

    ;; words we could find 
    (set! word_fd (fopen (path-append out_dir "word.known") "w"))
    (mapcar
     (lambda (wp)
       (mapcar
	(lambda (p) (format word_fd "%s " p))
	wp)
       (format word_fd "\n"))
     extra_words)
    (mapcar 
     (lambda (w)
       (if (not (assoc_string w extra_words))
	   (output_word_pronunciation word_fd w)))
     known_words)
    (fclose word_fd)
    )

)

(make_dict_main)


