git.gag.com Git - debian/freetts/blob - tools/ArcticToFreeTTS/scheme/dump_trees.scm

   1 ; Portions Copyright 2004 Sun Microsystems, Inc.
   2 ; Portions Copyright 1999-2003 Language Technologies Institute,
   3 ; Carnegie Mellon University.
   4 ; All Rights Reserved.  Use is subject to license terms.
   5 ;
   6 ; See the file "license.terms" for information on usage and
   7 ; redistribution of this file, and for a DISCLAIMER OF ALL
   8 ; WARRANTIES.
   9
  10 ; Dumps the clunit_selection_trees to standard out.
  11 ;
  12 ; Expects clunit_selection_trees to be defined.
  13 ;
  14 (define (dump_trees)
  15   (mapcar
  16    (lambda (cart)
  17      (set! current_node 0)
  18      (let ((tree (cadr cart))
  19            (name (car cart)))
  20        (set! cart_nodes_text (format nil "%s" (print_cart_nodes tree)))
  21        (format t "CART %s %d\n" name current_node)
  22        (format t "%s" cart_nodes_text)
  23        ))
  24    clunits_selection_trees))
  25
  26 (defvar cart_operators
  27   '(("is" "=")
  28     ("in" "IN")
  29     ("<" "<")
  30     (">" ">")
  31     ("matches" "REGEX")
  32     ("=" "EQUALS"))) ; CST_CART_OP_EQUALS not handled in
  33                      ;    Flite->FreeTTS Conversion
  34                      ; May cause problems.
  35
  36 (define (print_cart_list l)
  37     (cond
  38         ((null? l))
  39         ((cdr l) (format nil "%f,%s" (caar l) (print_cart_list (cdr l))))
  40         (t (format nil "%f" (caar l)))
  41 ))
  42
  43 (define (print_cart_nodes tree)
  44   (set! current_node (+ 1 current_node))
  45   (cond
  46    ((cdr tree) ;node (non-leaf)
  47     (let ((operator (cadr (assoc_string (cadr (car tree)) cart_operators)))
  48           (val (nth 2 (car tree))))
  49       (let ((type (cond
  50                    ((string-equal operator "=") (format nil "String(%s)" val))
  51                    ((string-equal operator "REGEX") (format nil "Integer(%d)" val))
  52                    ((number? val) (format nil "Float(%f)" val))
  53                    ((consp val) (format stderr "List vals not supported here yet\n")
  54                     (error val))
  55                    (t (format nil "String(%s)" val))
  56                    )))
  57         (let ((left_val (print_cart_nodes (car (cdr tree)))))
  58           (let ((this_node_val (format nil "NODE %s %s %s %d\n"
  59                                        (caar tree) ;feat
  60                                        operator
  61                                        type
  62                                        current_node)))
  63             (let ((right_val (print_cart_nodes (car (cdr (cdr tree))))))
  64               (string-append this_node_val left_val right_val))))
  65         )))
  66    (t (cond
  67        ((consp (caar tree))    ;leaf = (caar tree)
  68         (format nil "LEAF List(%s)\n"
  69                 (print_cart_list (caar tree)))
  70         )
  71        (t (format stderr "Unknown leaf format\n") (error 1))
  72        ))))