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

   1 ;;; These are preordained by the LTS building process
   2 (set! lts_context_window_size 4)
   3 (set! lts_context_extra_feats 1)
   4
   5 (define (dump_ltsregex idir)
   6   (let ((ifd) (rule_index nil))
   7     (set! lts_pos 0)
   8     (set! phone_table (list "epsilon"))
   9     (set! letter_table (list "nothing" "#" "0"
  10                              "a" "b" "c" "d" "e" "f" "g"
  11                              "h" "i" "j" "k" "l" "m" "n"
  12                              "o" "p" "q" "r" "s" "t" "u"
  13                              "v" "w" "x" "y" "z"))
  14     (format t "here\n");
  15     (mapcar
  16      (lambda (l)
  17        (let ((ifd (fopen (path-append
  18                           idir
  19                           (string-append l ".tree.wfst")) "r")))
  20          (format t "doing: %s\n" l)))
  21      (cdr (cddr letter_table))
  22      )))
  23
  24 (define (dump_lts_wfst l ifd ofde ofdh lts_pos)
  25   "(dump_lts_wfst ifd ofde ofdh lts_pos)
  26 Dump the WFST as a byte table to ifd.  Jumps are dumped as
  27 #define's to ofdh so forward references work.  lts_pos is the
  28 rule position.  Each state is saves as
  29     feature  value  true_addr  false_addr
  30 Feature and value are single bytes, which addrs are double bytes."
  31   (let ((state))
  32     ;; Skip WFST header
  33     (while (not (string-equal (set! state (readfp ifd)) "EST_Header_End"))
  34        (if (equal? state (eof-val))
  35            (error "eof in lts regex file")))
  36     (while (not (equal? (set! state (readfp ifd)) (eof-val)))
  37       (format ofdh "#define LTS_STATE_%s_%d %s\n"
  38               l (car (car state))
  39               (lts_bytify lts_pos))
  40       (cond
  41        ((string-equal "final" (car (cdr (car state))))
  42         (set! lts_pos (- lts_pos 1))
  43         t) ;; do nothing
  44        ((string-matches (car (car (cdr state))) ".*_.*")
  45         (format ofde "   %s, %s, %s , %s , \n"
  46                 (lts_feat (car (car (cdr state))))
  47 ;               (lts_val (car (car (cdr state))))
  48                 (lts_phone (lts_letter (car (car (cdr state)))) 0 letter_table)
  49                 (format nil "LTS_STATE_%s_%d" l
  50                         (car (cdr (cdr (car (cdr (cdr state)))))))
  51                 (format nil "LTS_STATE_%s_%d" l
  52                         (car (cdr (cdr (car (cdr state))))))))
  53        (t ;; its a letter output state
  54         (format ofde "   255, %s, 0,0 , 0,0 , \n"
  55                 (lts_phone (car (car (cdr state))) 0 phone_table))))
  56       (set! lts_pos (+ 1 lts_pos)))
  57     lts_pos))
  58
  59 (define (lts_feat trans)
  60   "(lts_feat trans)
  61 Returns the feature number represented in this transition name."
  62   (let ((fname (substring trans 5 (- (length trans) 11))))
  63     (if (string-matches fname ".*_i?")
  64         (set! fname (string-before fname "_")))
  65     (cond
  66      ((string-equal fname "p.p.p.p.name") 0)
  67      ((string-equal fname "p.p.p.name") 1)
  68      ((string-equal fname "p.p.name") 2)
  69      ((string-equal fname "p.name") 3)
  70      ((string-equal fname "n.name") 4)
  71      ((string-equal fname "n.n.name") 5)
  72      ((string-equal fname "n.n.n.name") 6)
  73      ((string-equal fname "n.n.n.n.name") 7)
  74      (t (error (format nil "ltsregex2C: unknown feat %s %s\n" fname trans ))))))
  75
  76 (define (lts_letter trans)
  77   "(lts_val trans)
  78 The letter being tested."
  79   (string-before (string-after trans "is_") "_"))
  80
  81 (define (lts_phone p n table)
  82   (cond
  83    ((string-equal p (car table))
  84     n)
  85    ((not (cdr table))  ;; new p
  86     (set-cdr! table (list p))
  87     (+ 1 n))
  88    (t
  89     (lts_phone p (+ 1 n) (cdr table)))))
  90
  91 (define (lts_bytify n)
  92   "(lts_bytify n)
  93 Return this short as a two byte comma separated string."
  94   (let ((xx (format nil "%04x" n)))
  95     ;; This is unfortunately byte order specific
  96     (format nil "0x%s,0x%s"
  97             (substring xx 2 2)
  98             (substring xx 0 2))))
  99
 100 (provide 'make_lts)