1;;; Support of miscellaneous kinds of speech events
2
3;; Copyright (C) 2003, 2004, 2005, 2006 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
24(require 'cap-signalization)
25(require 'punctuation)
26(require 'ssml-mode)
27(require 'util)
28(require 'wave)
29(require 'word-mapping)
30
31;;; Configuration variables
32
33(defvar sound-icon-directory "/usr/share/sounds/sound-icons"
34  "Directory where sound icons are placed by default.")
35
36(defvar logical-event-mapping
37  '((capital sound "capital")
38    (empty-text sound "empty-text")
39    (start sound "start")
40    (prompt sound "prompt")
41    (message sound "message")
42    (finish sound "finish")
43    (beginning-of-line sound "beginning-of-line")
44    (end-of-line sound "end-of-line"))
45  "Alist mapping logical sound events to any events.
46Each element of the alist is of the form (LOGICAL-EVENT EVENT-TYPE
47EVENT-VALUE), where LOGICAL-EVENT is the symbol naming the event to transform,
48EVENT-TYPE is the symbol naming the type of the transformed event and
49EVENT-VALUE is the corresponding transformed event value.
50The following event types are supported:
51`logical' -- just this event type again, the value is a symbol naming the event
52`text' -- plain text (the event value) to be synthesized
53`sound' -- a WAV file to be played, the value is a string naming the file;
54  either as an absolute pathname starting with the slash character or a
55  pathname relative to `sound-icon-directory'
56`key' -- a key event, the value is a string naming the key
57`character' -- a character event, the value is a string naming the character
58")
59
60(defvar key-event-mapping
61  '(("control_i" text "tab")
62    ("control_m" text "enter")
63    ("control_[" text "escape")
64    ("f1" text "f 1")
65    ("f2" text "f 2")
66    ("f3" text "f 3")
67    ("f4" text "f 4")
68    ("f5" text "f 5")
69    ("f6" text "f 6")
70    ("f7" text "f 7")
71    ("f8" text "f 8")
72    ("f9" text "f 9")
73    ("f10" text "f 10")
74    ("f11" text "f 11")
75    ("f12" text "f 12"))
76  "Alist mapping key events to any events.
77The form of the alist is the same as in `logical-event-mapping', except
78LOGICAL-EVENT is replaced by a string naming the key.")
79
80(defvar character-event-mapping
81  '(("\000" text "control space")
82    ("\001" text "control a")
83    ("\002" text "control b")
84    ("\003" text "control c")
85    ("\004" text "control d")
86    ("\005" text "control e")
87    ("\006" text "control f")
88    ("\007" text "control g")
89    ("\010" text "control h")
90    ("\t" text "tab")
91    ("\n" text "newline")
92    ("\013" text "control k")
93    ("\014" text "control l")
94    ("\r" text "control m")
95    ("\016" text "control n")
96    ("\017" text "control o")
97    ("\020" text "control p")
98    ("\021" text "control q")
99    ("\022" text "control r")
100    ("\023" text "control s")
101    ("\024" text "control t")
102    ("\025" text "control u")
103    ("\026" text "control v")
104    ("\027" text "control w")
105    ("\030" text "control x")
106    ("\031" text "control y")
107    ("\032" text "control z")
108    ("\0240" text "hard space"))
109  "Alist mapping character events to any events.
110The form of the alist is the same as in `logical-event-mapping', except
111LOGICAL-EVENT is replaced by a string naming the character.")
112
113(defvar event-mappings
114  (list
115   (list 'logical logical-event-mapping)
116   (list 'key key-event-mapping)
117   (list 'character character-event-mapping))
118  "Alist mapping event types to new events.
119Each element of the alist is of the form (EVENT-TYPE EVENT-MAPPING), where
120EVENT-TYPE is one of the symbols `logical', `text', `sound', `key',
121`character', and EVENT-MAPPING is the of the same form as
122`logical-event-mapping'.")
123
124
125(defvar event-debug nil)
126
127;;; Internal functions
128
129(define (event-print object)
130  (if event-debug
131      (if (and (symbol-bound? 'server_log_file)
132               (eq (typeof server_log_file) 'string))
133          (unwind-protect
134            (let ((f (fopen (string-append server_log_file "-e") "a")))
135              (format f "%l\n" object)
136              (fclose f))
137            (print object))
138          (print object))))
139
140(defmac (event-with-mode form)
141  (let ((mode-name (nth 0 (nth 1 form)))
142        (mode-value (nth 1 (nth 1 form)))
143        (body (nth_cdr 2 form)))
144    (let ((mode-var (intern (string-append mode-name "-mode")))
145          (mode-func (intern (string-append "set-" mode-name "-mode"))))
146      `(let ((,mode-name ,mode-var))
147         (,mode-func ,mode-value)
148         (unwind-protect* (begin ,@body)
149           (,mode-func ,mode-name))))))
150
151(define (event-find-seg-1 utt word placement)
152  (cond
153   ((not word)
154    (list ((if (eq? placement 'after) utt.relation.first utt.relation.last) utt 'Segment)
155          placement))
156   ((not (string-equal (item.feat word "R:SylStructure.daughter1.daughter1.name") 0))
157    (let ((d (if (eq placement 'after) item.daughtern item.daughter1)))
158      (list (d (d (item.relation word 'SylStructure))) placement)))
159   (t
160    (event-find-seg-1 utt ((if (eq? placement 'after) item.prev item.next) word) placement))))
161
162(define (event-find-seg utt word placement)
163  (if (utt.relation.items utt 'Segment)
164      (if (eq? placement 'after)
165          (event-find-seg-1 utt (item.next word) 'before)
166          (event-find-seg-1 utt (item.prev word) 'after))
167      (begin
168        (utt.relation.append
169         utt 'Segment (list (caar (cdar (PhoneSet.description '(silences))))))
170        (list (utt.relation.first utt 'Segment) placement))))
171
172(define (event-eat-utt utt wave-eater)
173  (utt.relation.create utt 'Event)
174  (do-relation-items (w utt Word)
175    (let* ((events '())
176           (get-events (lambda (item)
177                         (let ((events* (item-events utt item)))
178                           (when events*
179                             (set! events (append (mapcar (lambda (e)
180                                                            (list (first e)
181                                                                  (if (string-equal (second e) 'prev)
182                                                                      'before
183                                                                      'after)))
184                                                          events*)
185                                                  events)))))))
186      (get-events w)
187      (let ((token (item.parent (item.relation w 'Token))))
188        (if (and token
189                 (or (not (item.next w))
190                     (not (equal? token (item.parent (item.relation (item.next w) 'Token))))))
191            (while token
192              (get-events token)
193              (set! token (item.next token))
194              (when (and token (item.daughters token))
195                (set! token nil)))))
196      (mapcar (lambda (event-direction)
197                (let* ((event (first event-direction))
198                       (direction (second event-direction))
199                       (seg-placement (event-find-seg utt w direction))
200                       (seg (first seg-placement))
201                       (placement (second seg-placement))
202                       (event* (utt.relation.append
203                                utt 'Event
204                                `(event ((event ,event)
205                                         (event-placement ,placement)
206                                         (end ,(item.feat seg 'end))
207                                         (pend ,(item.feat seg "R:Segment.p.end")))))))
208                  (item.set_feat seg 'event event*)))
209              (reverse events))))
210  (let ((w (utt.wave utt)))
211    (if (utt.relation.items utt 'Event)
212        (let ((last-break 0.0))
213          (do-relation-items (event utt Event)
214            (let ((break (if (string-equal (item.feat event 'event-placement)
215                                           'after)
216                             (item.feat event 'end)
217                             (or (item.feat event 'pend) 0.0)))
218                  (event* (item.feat event 'event)))
219              (wave-eater (wave-subwave w last-break break))
220              (event-synth-plain (first event*) (second event*) wave-eater)
221              (set! last-break break)))
222          (wave-eater (wave-subwave
223                       w last-break
224                       (item.feat (utt.relation.last utt 'Segment) 'end))))
225        (wave-eater w)))
226  utt)
227
228(define (event-synth-text text wave-eater)
229  (unless (string-equal text "")
230    (event-eat-utt (SynthText text) wave-eater)))
231
232(define (event-synth-ssml value wave-eater)
233  (ssml-parse value)
234  (let ((utt (ssml-next-chunk))
235        (last-utt nil))
236    (while utt
237      (set! last-utt utt)
238      (unless (symbol? utt)
239        (utt.synth utt)
240        (event-eat-utt utt wave-eater))
241      (set! utt (ssml-next-chunk)))
242    last-utt))
243
244(define (event-synth-key value wave-eater)
245  (let ((text (string-append value)))
246    (while (string-matches text ".*_.*")
247      (aset text (length (string-before text "_")) 32))
248    (event-synth-text text wave-eater)))
249
250(define (event-synth-character value wave-eater)
251  (event-synth-text value wave-eater))
252
253(define (event-synth-sound value wave-eater)
254  (let ((utt (wave-import-utt
255              (if (string-matches value "^/.*")
256                  value
257                  (string-append sound-icon-directory "/" value)))))
258    (wave-eater (utt.wave utt))
259    (when (string-matches value "^.*\.delete-after-play$")
260      (delete-file value))
261    utt))
262
263(define (event-synth-plain type value wave-eater)
264  (cond
265   ((eq? type 'text)
266    (event-synth-text value wave-eater))
267   ((eq? type 'ssml)
268    (event-synth-ssml value wave-eater))
269   ((eq? type 'sound)
270    (event-synth-sound value wave-eater))
271   ((eq? type 'mark)
272    (wave-eater (intern value)))
273   (t
274    (let ((transformed
275           (cdr (assoc value (cadr (assq type (langvar 'event-mappings)))))))
276      (cond
277       (transformed
278        (event-synth-1 (first transformed) (second transformed) wave-eater))
279       ((or (eq? type 'key) (eq? type 'character))
280        (event-with-mode (punctuation 'all)
281          (event-with-mode (cap-signalization t)
282            ((if (eq? type 'key) event-synth-key event-synth-character)
283             value wave-eater))))
284       ((eq? type 'logical)
285        (event-synth-text (if (string-matches value "^_.*") "" value)
286                          wave-eater))
287       (t
288        (error "Event description not found" (cons type value))))))))
289
290(define (event-synth-1 type value wave-eater)
291  (event-print (list 'event event-debug type value))
292  (if (and (eq? type 'logical)
293           (string-matches value "^_.*"))
294      (cond
295       ((string-matches value "^_debug_on.*")
296        (set! event-debug (string-after value '_debug_on))
297        (set_backtrace t)
298        (event-print value))
299       ((string-matches value "^_debug_off.*")
300        (set! event-debug nil)
301        (set_backtrace nil)
302        (event-print value))))
303  (event-synth-plain type value wave-eater))
304
305;;; External functions
306
307(define (event-synth type value)
308  (let* ((waves '())
309         (utt (event-synth-1 type value
310                             (lambda (w) (set! waves (cons w waves))))))
311    (if (<= (length waves) 1)
312        utt
313        (wave-utt (wave-concat (reverse waves))))))
314
315(define (event-play type value)
316  (utt.play (event-synth type value)))
317
318(define (set-event-mapping! type value new-type new-value)
319  (set! event-mappings
320        (assoc-set event-mappings type
321                   (assoc-set (cadr (assoc type event-mappings))
322                              value
323                              (list new-type new-value)))))
324
325(define (item-events utt item)
326  (mapcar (lambda (event) (list (nth 1 event) (nth 3 event)))
327          (remove-if (lambda (annotation) (not (eq? (car annotation) 'event)))
328                     (get-annotations utt item))))
329
330(define (add-event utt item event stick-to)
331  (add-annotation utt item (list 'event event 'event-stick-to stick-to)))
332
333
334;;; Announce
335
336(provide 'events)
337