1;;; Miscellaneous debugging functions for Czech synthesis 2 3;; Copyright (C) 2004, 2005 Brailcom, o.p.s. 4 5;; Author: Milan Zamazal <pdm@brailcom.org> 6 7;; COPYRIGHT NOTICE 8 9;; This program is free software; you can redistribute it and/or modify 10;; it under the terms of the GNU General Public License as published by 11;; the Free Software Foundation; either version 2 of the License, or 12;; (at your option) any later version. 13 14;; This program is distributed in the hope that it will be useful, but 15;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 16;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 17;; for more details. 18 19;; You should have received a copy of the GNU General Public License 20;; along with this program; if not, write to the Free Software 21;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA. 22 23;; Some data were created using the data files and tools contained in the 24;; ispell-czech package available under GPL at 25;; ftp://ftp.vslib.cz/pub/unix/ispell/czech. 26 27 28(require 'czech) 29 30 31(define (czech-debug-newline s) 32 (format s "\n\n")) 33 34(define (czech-debug-prompt s prompt) 35 (format s "* %s:\n" prompt)) 36 37(define (czech-debug-print-relation s utt relation features) 38 (czech-debug-prompt s relation) 39 (let ((i (utt.relation.first utt relation))) 40 (while i 41 (format s "%s " (item.name i)) 42 (let ((feats '()) 43 (features* features)) 44 (while features* 45 (let ((val (item.feat i (car features*)))) 46 (if (and (not (string-matches val "0?")) 47 (not (string-equal val "nil")) 48 (not (string-equal val "NB"))) 49 (set! feats (cons (cons (car features*) val) feats)))) 50 (set! features* (cdr features*))) 51 (if feats 52 (begin 53 (format s "(") 54 (mapcar (lambda (fv) 55 (if fv (format s " %s=%s " (car fv) (cdr fv)))) 56 (reverse feats)) 57 (format s ") ")))) 58 (set! i (item.next i))))) 59 60(define (czech-debug-print-randomization s utt) 61 (format s "randomized = %s" czech-randomize)) 62 63(define (czech-debug-print-tokens s utt) 64 (czech-debug-print-relation s utt 'Token '(punc prepunctuation))) 65 66(define (czech-debug-print-words s utt) 67 (czech-debug-print-relation s utt 'Word '(pbreak pos))) 68 69(define (czech-debug-print-segments s utt) 70 (czech-debug-print-relation s utt 'Segment '())) 71 72(define (czech-debug-print-units s utt) 73 (czech-debug-prompt s 'Units) 74 (format s "||") 75 (let ((i-unit (utt.relation.first utt 'IntStress))) 76 (while i-unit 77 (mapcar (lambda (s-unit) 78 (format s " ") 79 (mapcar (lambda (syl) 80 (mapcar (lambda (ph) (format s "%s " (item.name ph))) 81 (item.relation.daughters syl 'SylStructure))) 82 (item.relation.daughters s-unit 'StressUnit)) 83 (format s "%s/%s %l |" (item.feat s-unit 'position) 84 (item.feat s-unit 'contourtype) 85 (mapcar (lambda (x) (* 100 x)) 86 (item.feat s-unit 'contour)))) 87 (item.daughters i-unit)) 88 (format s "|") 89 (set! i-unit (item.next i-unit))))) 90 91(define (czech-debug-print-durfactors s utt) 92 (czech-debug-prompt s "Duration factors") 93 (let ((i (utt.relation.first utt 'Segment)) 94 (segs '()) 95 (last-dur 'none)) 96 (while i 97 (while (and i (eqv? (item.feat i 'dur_factor) last-dur)) 98 (set! segs (cons (item.name i) segs)) 99 (set! i (item.next i))) 100 (if segs 101 (begin 102 (format s "[") 103 (mapcar (lambda (seg) (format s "%s " seg)) (reverse segs)) 104 (if (not (string-equal last-dur '0)) 105 (format s "= %s" last-dur)) 106 (format s "] ") 107 (set! segs '()))) 108 (set! last-dur (and i (item.feat i 'dur_factor)))))) 109 110(define (czech-debug-print-durations s utt) 111 (czech-debug-prompt s 'Duration) 112 (let ((last-end 0)) 113 (mapcar 114 (lambda (seg) 115 (let ((dur (- (item.feat seg 'end) last-end))) 116 (format s "%s %s " (item.name seg) dur)) 117 (if (item.next seg) 118 (format s "- ")) 119 (set! last-end (item.feat seg 'end))) 120 (utt.relation.items utt 'Segment)))) 121 122(define (czech-debug-print-f0 s utt) 123 (czech-debug-prompt s 'F0) 124 (let ((last-end 0)) 125 (mapcar 126 (lambda (seg) 127 (let ((dur (- (item.feat seg 'end) last-end))) 128 (format s "%s " (item.name seg)) 129 (mapcar (lambda (f0) 130 (format s "%s/%d " (item.feat f0 'f0) 131 (/ (* 100 (- (item.feat f0 'pos) last-end)) dur))) 132 (item.relation.daughters seg 'Target))) 133 (if (item.next seg) 134 (format s "- ")) 135 (set! last-end (item.feat seg 'end))) 136 (utt.relation.items utt 'Segment)))) 137 138(define (czech-debug-print* s utt) 139 (czech-debug-print-randomization s utt) 140 (czech-debug-newline s) 141 (czech-debug-print-tokens s utt) 142 (czech-debug-newline s) 143 (czech-debug-print-words s utt) 144 (czech-debug-newline s) 145 (czech-debug-print-segments s utt) 146 (czech-debug-newline s) 147 (czech-debug-print-units s utt) 148 (czech-debug-newline s) 149 (czech-debug-print-durfactors s utt) 150 (czech-debug-newline s) 151 (czech-debug-print-durations s utt) 152 (czech-debug-newline s) 153 (czech-debug-print-f0 s utt) 154 (czech-debug-newline s) 155 (if (not (eq? s t)) 156 (fflush s))) 157 158(define (czech-debug-print utt) 159 (czech-debug-print* t utt)) 160 161 162(provide 'czech-debug) 163