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