File: soleml-mode.scm

package info (click to toggle)
festival 1%3A2.4~release-3
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 7,432 kB
  • ctags: 6,364
  • sloc: cpp: 27,729; lisp: 15,695; ansic: 6,022; sh: 5,660; java: 1,536; makefile: 769; xml: 291; perl: 87
file content (336 lines) | stat: -rw-r--r-- 12,480 bytes parent folder | download | duplicates (7)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                       ;;
;;;                Centre for Speech Technology Research                  ;;
;;;                     University of Edinburgh, UK                       ;;
;;;                         Copyright (c) 1998                            ;;
;;;                        All Rights Reserved.                           ;;
;;;                                                                       ;;
;;;  Permission is hereby granted, free of charge, to use and distribute  ;;
;;;  this software and its documentation without restriction, including   ;;
;;;  without limitation the rights to use, copy, modify, merge, publish,  ;;
;;;  distribute, sublicense, and/or sell copies of this work, and to      ;;
;;;  permit persons to whom this work is furnished to do so, subject to   ;;
;;;  the following conditions:                                            ;;
;;;   1. The code must retain the above copyright notice, this list of    ;;
;;;      conditions and the following disclaimer.                         ;;
;;;   2. Any modifications must be clearly marked as such.                ;;
;;;   3. Original authors' names are not deleted.                         ;;
;;;   4. The authors' names are not used to endorse or promote products   ;;
;;;      derived from this software without specific prior written        ;;
;;;      permission.                                                      ;;
;;;                                                                       ;;
;;;  THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK        ;;
;;;  DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING      ;;
;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT   ;;
;;;  SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE     ;;
;;;  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES    ;;
;;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN   ;;
;;;  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,          ;;
;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF       ;;
;;;  THIS SOFTWARE.                                                       ;;
;;;                                                                       ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Support for an SGML based mark-up language used in the SOLE
;;;  project.  This is all still experimental.
;;;
;;;  This currently treats one file as one utterance (to make dealing with
;;;  the SOLE museaum database easy

(set! soleml_word_features_stack nil)
(defvar sole_current_node nil)

(define (soleml_token_to_words utt token name)
  "(soleml_token_to_words utt token name)
SOLEML mode token specific analysis."
  (cond

   (t
    (soleml_previous_token_to_words utt token name))))

(define (voice_soleml)
"(soleml_voice)
Speaker specific initialisation for SOLE museum data."
  (voice_rab_diphone)
  ;; Utterances only come at end of file
  (set! eou_tree '((0)))
)

(defvar soleml_elements
'(
  ("(SOLEML" (ATTLIST UTT)
    ;; required to identify type 
    (voice_soleml)  ;; so we know what state we start in
    (set! soleml_utt (Utterance Tokens nil))
    (utt.stream.create soleml_utt 'Token)
    (utt.relation.create soleml_utt 'SOLEML)
    (set! sole_current_node 
	  (utt.relation_append soleml_utt 'SOLEML (cons "sole-ml" ATTLIST)))
    soleml_utt
  )
  (")SOLEML" (ATTLIST UTT)
    ;; required to identify end token
    ;; Don't really want to synthesize this
    ;; (xxml_synth UTT)  ;;  Synthesis the remaining tokens
    (set! soleml_utt UTT)	     
    UTT
  )
  ;; Utterance break elements
  ("(LANGUAGE" (ATTLIST UTT)
   ;; Select a new language
   (select_language (car (xxml_attval "NAME" ATTLIST)))
   UTT)
  ("(VOICE" (ATTLIST UTT)
   ;;(xxml_synth UTT)
   ;; Select a new voice
   (cond
    ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male1)
     (voice_soleml_diphone))
    ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male2)
     (voice_soleml_diphone))
    ((equal? (car (xxml_attval "NAME" ATTLIST)) 'male3)
     (voice_soleml_diphone))
    (t
     (print "SOLEML: selecting unknown voice")
     (voice_soleml_diphone)))
   UTT)
  ;; phrase-boundary  // mark on token (??)
  ;; punct-elem     // mark on token
  ;; sem-elem
  ;; text-elem      // ignore
  ;; rhet-elem  has nucleus and satellite
  ;; anaphora-elem
  ;; syn-elem
  ;; info-struct-elem
  ;; other-elem
  ("(PUNCT-ELEM" (ATTLIST UTT) 
   (soleml_push_word_features)
   (set! xxml_word_features
	  (cons (list "punct-elem" "1")
		(soleml_conv_attlist ATTLIST)))
   UTT)
  (")PUNCT-ELEM" (ATTLIST UTT) 
   (set! xxml_word_features (soleml_pop_word_features))
   UTT)
  ("(PHRASE-BOUNDARY" (ATTLIST UTT)
   (if (string-equal "4" (car (xxml_attval "STRENGTH" ATTLIST)))
       (begin
;;	 (xxml_synth UTT)
	 UTT)
       (let ((last_token (car (last (utt.stream UTT 'Token)))))
	 (if last_token
	     (item.set_feat last_token "pbreak" "B"))
	 UTT)))
  ;; For each recursive element simply build a new node
  ("(RHET-ELEM" (ATTLIST UTT)
   (let ((sdesc (list 'rhet-elem (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")RHET-ELEM" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(RHET-EMPH" (ATTLIST UTT)
   (let ((sdesc (list 'rhet-emph (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")RHET-EMPH" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(ANAPHORA-ELEM" (ATTLIST UTT)
   (let ((sdesc (list 'anaphora-elem (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")ANAPHORA-ELEM" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(SYN-ELEM" (ATTLIST UTT)
   (let ((sdesc (list 'syn-elem (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")SYN-ELEM" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(CONNECTIVE" (ATTLIST UTT)
   (let ((sdesc (list 'connective (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")CONNECTIVE" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(TEXT-ELEM" (ATTLIST UTT)
   (let ((sdesc (list 'text-elem (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")TEXT-ELEM" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(SEM-ELEM" (ATTLIST UTT)
   (let ((sdesc (list 'sem-elem (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")SEM-ELEM" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(INFO-STRUCT-ELEM" (ATTLIST UTT)
   (let ((sdesc (list 'info-struct-elem (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")INFO-STRUCT-ELEM" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(OTHER-ELEM" (ATTLIST UTT)
   (let ((sdesc (list 'other-elem (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")OTHER-ELEM" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(NUCLEUS" (ATTLIST UTT)
   (let ((sdesc (list 'nucleus (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")NUCLEUS" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ("(SATELLITE" (ATTLIST UTT)
   (let ((sdesc (list 'satellite (soleml_conv_attlist ATTLIST))))
     (set! sole_current_node
	   (node.append_daughter sole_current_node sdesc))
     UTT))
  (")SATELLITE" (ATTLIST UTT)
    (set! sole_current_node (node.parent sole_current_node))
    UTT)
  ;; Other control functions (probably not used in SOLE)  
  ("(CALL" (ATTLIST UTT)
;;   (xxml_synth UTT)
   (if (string-matches (car (xxml_attval "ENGID" ATTLIST)) "festival.*")
       (let ((comstr ""))
	 (mapcar
	  (lambda (c) (set! comstr (string-append comstr " " c)))
	  (xxml_attval "COMMAND" ATTLIST))
	 (eval (read-from-string comstr))))
   UTT)
  ("(DEFINE" (ATTLIST UTT)
;;    (xxml_synth UTT)
    (if (not (string-equal "NATIVE" (car (xxml_attval "SCHEME" ATTLIST))))
	(format t "DEFINE: unsupported SCHEME %s, definition ignored\n"
		(car (xxml_attval "SCHEME" ATTLIST)))
	(lex.add.entry
	 (list
	  (car (xxml_attval "WORDS" ATTLIST))   ;; head form
	  nil          ;; pos
	  (lex.syllabify.phstress (xxml_attval "PRONS" ATTLIST)))))
    UTT)
  ("(SOUND" (ATTLIST UTT)
;;   (xxml_synth UTT)
   (if (not soleml_omitted_mode)
       (apply_hooks tts_hooks
		    (eval (list 'Utterance 'Wave 
				(car (xxml_attval "SRC" ATTLIST))))))
   UTT)
  ("(EMPH" (ATTLIST UTT)
   ;; Festival is particularly bad at adding specific emphasis
   ;; that's what happens when you use statistical methods that
   ;; don't include any notion of emphasis
   ;; This is *not* recursive
   (soleml_push_word_features)
   (set! xxml_word_features 
	 (cons (list "EMPH" "1") xxml_word_features))
   UTT)
  (")EMPH" (ATTLIST UTT)
   (set! xxml_word_features (soleml_pop_word_features))
   UTT)
  ("(WORD" (ATTLIST UTT)
   ;; a word in-line
   (let ((name   (xxml_attval "NAME" ATTLIST))
	 (pos    (xxml_attval "POS" ATTLIST))
	 (accent (xxml_attval "ACCENT" ATTLIST))
	 (tone   (xxml_attval "TONE" ATTLIST))
	 (phonemes (xxml_attval "PHONEMES" ATTLIST))
	 token)
     (utt.item.insert UTT 'Token)  ;; add new Token
     (set! token (utt.stream.tail UTT 'Token))
     (item.set_name token (car name))
     (if pos (item.set_feat token "pos" (car pos)))
     (if accent (item.set_feat token "accent" (car accent)))
     (if tone (item.set_feat token "tone" (car tone)))
     (if phonemes (item.set_feat token "phonemes" 
				       (format nil "%l" phonemes)))
     UTT))
))

(define (soleml_init_func)
  "(soleml_init_func)
Initialisation for SOLEML mode"
  (voice_soleml)
  (set! soleml_previous_elements xxml_elements)
  (set! xxml_elements soleml_elements)
  (set! xxml_token_hooks soleml_token_function)
  (set! soleml_previous_token_to_words english_token_to_words)
  (set! english_token_to_words soleml_token_to_words)
  (set! token_to_words soleml_token_to_words))

(define (soleml_exit_func)
  "(soleml_exit_func)
Exit function for SOLEML mode"
  (set! xxml_elements soleml_previous_elements)
  (set! token_to_words soleml_previous_token_to_words)
  (set! english_token_to_words soleml_previous_token_to_words))

(define (soleml_token_function si)
"(soleml_token_function si)
This is called for each token found."
  (node.append_daughter sole_current_node si))

(define (soleml_push_word_features)
"(soleml_push_word_features)
Save current word features on stack."
  (set! soleml_word_features_stack 
	(cons xxml_word_features soleml_word_features_stack)))

(define (soleml_pop_word_features)
"(soleml_pop_word_features)
Pop word features from stack."
  (let ((r (car soleml_word_features_stack)))
    (set! soleml_word_features_stack (cdr soleml_word_features_stack))
    r))

(define (soleml_conv_attlist alist)
"(soleml_conv_attlist alist)
Flatten alist arguments."
  (cond
   ((null alist) nil)
   ((null (car (cdr (car alist))))
     (soleml_conv_attlist (cdr alist)))
   ((equal? (length (car (cdr (car alist)))) 1)
    (cons
     (list (car (car alist)) (car (car (cdr (car alist)))))
     (soleml_conv_attlist (cdr alist))))
   (t
    (cons
     (list (car (car alist)) (format nil "%l" (car (cdr (car alist)))))
     (soleml_conv_attlist (cdr alist))))))

(set! tts_text_modes
   (cons
    (list
      'soleml   ;; mode name
      (list         ;; email mode params
       (list 'init_func soleml_init_func)
       (list 'exit_func soleml_exit_func)
       '(analysis_type xxml)
       (list 'filter 
	     (format nil "%s -D %s " sgml_parse_progname datadir))))
    tts_text_modes))

(provide 'soleml-mode)