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