1;;; Speech Synthesis Interface Protocol (SSIP) interface 2 3;; Author: Milan Zamazal <pdm@brailcom.org> 4 5;; Copyright (C) 2004 Brailcom, o.p.s. 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 Lesser General Public License as published by 11;; the Free Software Foundation; either version 2.1 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 Lesser General Public License 17;; for more details. 18 19;; You should have received a copy of the GNU Lesser General Public License 20;; along with this program. If not, see <https://www.gnu.org/licenses/>. 21 22 23;;; Note: This library was ported from the Elisp library, so don't wonder much 24;;; about elispisms found here... 25 26 27(in-package :ssip) 28 29 30;;; Exported variables 31 32 33(defvar *application-name* "lisp" 34 "String defining current application name.") 35 36(defvar *client-name* "default" 37 "String defining current client name. 38This variable's value defines which connection is used when communicating via 39SSIP, each connection has its own client name. Usually, you select the proper 40client (connection) by assigning a value to this variable locally through 41`let'.") 42 43(defvar *language* nil 44 "If non-nil, it is an RFC 1766 language code, as a string. 45If text is read and this variable is non-nil, the text is read in the given 46language.") 47 48(defvar *spell* nil 49 "If non-nil, any spoken text is spelled.") 50 51 52;;; Internal constants and configuration variables 53 54 55(defparameter +version+ "$Id: ssip.lisp,v 1.3 2006-02-17 13:18:55 pdm Exp $" 56 "Version stamp of the source file. 57Useful only for diagnosing problems.") 58 59(defvar *language-codes* 60 '(("czech" . "cs") 61 ("english" . "en") 62 ("american english" . "en-US") 63 ("french" . "fr") 64 ("german" . "de")) 65 "Mapping of LANG values to language ISO codes.") 66 67(defvar *default-voice* "male1") 68(defvar *default-language* (or (cdr (assoc (getenv "LANG") *language-codes* 69 :test #'string=)) 70 "en")) 71 72(defparameter +parameter-names+ 73 '((client-name . "CLIENT_NAME") 74 (language . "LANGUAGE") 75 (message-priority . "PRIORITY") 76 (punctuation-mode . "PUNCTUATION") 77 (pause-context . "PAUSE_CONTEXT") 78 (capital-character-mode . "CAP_LET_RECOGN") 79 (voice . "VOICE") 80 (rate . "RATE") 81 (pitch . "PITCH") 82 (pitch_range . "PITCH_RANGE") 83 (spelling-mode . "SPELLING") 84 (output-module . "OUTPUT_MODULE") 85 )) 86 87(defparameter +list-parameter-names+ 88 '((voices . "VOICES"))) 89 90(defparameter +parameter-value-mappings+ 91 '((message-priority 92 (:important . "IMPORTANT") 93 (:message . "MESSAGE") 94 (:text . "TEXT") 95 (:notification . "NOTIFICATION") 96 (:progress . "PROGRESS") 97 ) 98 (punctuation-mode 99 (:none . "none") 100 (:some . "some") 101 (:most . "most") 102 (:all . "all")) 103 (capital-character-mode 104 (:none . "none") 105 (:spell . "spell") 106 (:icon . "icon")) 107 (spelling-mode 108 (t . "on") 109 (nil . "off")))) 110 111(defparameter +volatile-parameters+ '(output-module)) 112 113(defparameter +punctuation-modes+ '(("none" . none) 114 ("some" . some) 115 ("most" . most) 116 ("all" . all))) 117 118(defparameter +capital-character-modes+ '(("none" . none) 119 ("spell" . spell) 120 ("icon" . icon))) 121 122 123;;; Internal variables 124 125 126(defstruct connection 127 name 128 host 129 port 130 (failure-p nil) 131 stream 132 (paused-p nil) 133 (in-block nil) 134 (transaction-state nil) 135 (parameters ()) 136 (forced-priority nil) 137 (last-command nil)) 138 139(defstruct request 140 string 141 (transaction-state '(nil nil))) 142 143(defvar *connections* (make-hash-table :test #'equal) 144 "Hash table mapping client names to `connection' instances.") 145 146(defvar *connection* nil 147 "Current connection.") 148 149 150 151;;; Utilities 152 153 154(defmacro iterate-clients (&rest body) 155 `(maphash #'(lambda (*client-name* _) (declare (ignore _)) ,@body) 156 *connections*)) 157 158(defmacro iterate-connections (&rest body) 159 `(maphash #'(lambda (_ *connection*) (declare (ignore _)) ,@body) 160 *connections*)) 161 162(defun connection-names () 163 "Return the list of all present connection names." 164 (let ((names '())) 165 (iterate-clients 166 (push *client-name* names)) 167 names)) 168 169(defmacro with-current-connection (&rest body) 170 `(let ((*connection* (get-connection))) 171 ,@body)) 172 173(defmacro with-connection-setting (var value &rest body) 174 (let ((accessor (intern (concat "CONNECTION-" (symbol-name var)))) 175 (orig-value (gensym))) 176 `(let ((,orig-value (,accessor *connection*))) 177 (setf (,accessor *connection*) ,value) 178 (unwind-protect 179 (progn 180 ,@body) 181 (setf (,accessor *connection*) ,orig-value))))) 182 183(defmacro with-connection-parameters (parameters &rest body) 184 (let (($parameters (gensym)) 185 ($orig-parameters (gensym)) 186 ($cparameters (gensym)) 187 ($p (gensym)) 188 ($v (gensym)) 189 ($orig-v (gensym)) 190 ($pv (gensym))) 191 `(let* ((,$parameters ,parameters) 192 (,$orig-parameters ())) 193 (unwind-protect 194 (progn 195 (while ,$parameters 196 (let* ((,$p (first ,$parameters)) 197 (,$v (second ,$parameters)) 198 (,$cparameters 199 (connection-parameters *connection*)) 200 (,$orig-v (plist-get ,$cparameters ,$p))) 201 (when (and (not (equal ,$v ,$orig-v)) 202 (or ,$v 203 (not (member ,$p '(language))))) 204 (when (plist-member ,$cparameters ,$p) 205 (push (cons ,$p ,$orig-v) ,$orig-parameters)) 206 (set-parameter ,$p ,$v))) 207 (setq ,$parameters (nthcdr 2 ,$parameters))) 208 ,@body) 209 (dolist (,$pv ,$orig-parameters) 210 (set-parameter (car ,$pv) (cdr ,$pv))))))) 211 212 213;;; Process management functions 214 215 216(defun get-connection (&optional (name *client-name*) (create-if-needed t)) 217 (or (gethash name *connections*) 218 (and create-if-needed 219 (let ((*client-name* name)) 220 (open-connection))))) 221 222(defun close-connection-stream (connection) 223 (let ((stream (connection-stream connection))) 224 (when stream 225 (ignore-errors (close-network-stream stream))) 226 (setf (connection-stream connection) nil))) 227 228(defun open-connection (&optional host port &key quiet force-reopen) 229 "Open SSIP connection to given HOST and PORT. 230If the connection corresponding to the current `*client-name*' value 231already exists, close it and reopen again, with the same connection parameters. 232 233The optional arguments HOST and PORT identify the speechd server location 234differing from the values of `speechd-host' and `speechd-port'. 235 236If the key argument QUIET is non-nil, don't report failures and quit silently. 237If the key argument FORCE-REOPEN is non-nil, try to reopen an existent 238connection even if it previously failed. 239 240Return the opened connection on success, nil otherwise." 241 (let ((connection (gethash *client-name* *connections*))) 242 (let ((host (or host *host*)) 243 (port (or port *port*))) 244 (when connection 245 (close-connection connection) 246 (setq host (connection-host connection) 247 port (connection-port connection))) 248 (let* ((name *client-name*) 249 (default-parameters (append 250 (cdr (assoc *client-name* 251 *connection-parameters* 252 :test #'string=)) 253 (cdr (assoc t *connection-parameters*)))) 254 (parameters (if connection 255 (append 256 (connection-parameters connection) 257 default-parameters) 258 default-parameters)) 259 (stream (when (or (not connection) 260 (not (connection-failure-p connection)) 261 force-reopen) 262 (ignore-errors 263 (open-network-stream host port))))) 264 (when (and (not stream) (not quiet)) 265 (error "Connection to SSIP failed")) 266 (setq connection (make-connection 267 :name name :host host :port port 268 :stream stream :failure-p (not stream))) 269 (setf (gethash name *connections*) connection) 270 (when stream 271 (set-connection-name name) 272 (setq parameters (append parameters 273 (list 'language *default-language* 274 'voice *default-voice*))) 275 (let ((already-set '(client-name))) 276 (while parameters 277 (destructuring-bind (parameter value . next) parameters 278 (unless (member parameter already-set) 279 (push parameter already-set) 280 (set-parameter parameter value)) 281 (setq parameters next))))) 282 (let ((priority (and 283 connection 284 (plist-get default-parameters 'message-priority)))) 285 (when priority 286 (set-parameter 'message-priority priority) 287 (setf (connection-forced-priority connection) t))))) 288 connection)) 289 290(defun close-connection (&optional (name *client-name*)) 291 "Close speechd connection named NAME." 292 (let ((connection (get-connection name nil))) 293 (when connection 294 (close-connection-stream connection) 295 (remhash name *connections*)))) 296 297(defun reopen-connection () 298 "Close and open again all the connections to speechd." 299 (iterate-clients (open-connection :quiet t :force-reopen t))) 300 301(defun running-p () 302 "Return non-nil, if the current speechd client name process is running." 303 (let ((connection (get-connection))) 304 (and connection (connection-stream connection)))) 305 306 307;;; Process communication functions 308 309 310(defun permanent-connection-failure (connection) 311 (close-connection-stream connection) 312 (setf (connection-failure-p connection) t 313 (connection-paused-p connection) nil 314 (connection-transaction-state connection) nil 315 (connection-parameters connection) ())) 316 317(defun send-string (string) 318 (with-current-connection 319 (let ((stream (connection-stream *connection*))) 320 (when stream 321 (unwind-protect 322 (format stream "~A" string) 323 (when (not (running-p)) 324 (permanent-connection-failure *connection*))))))) 325 326(defun process-request (request) 327 (with-current-connection 328 ;; Ensure proper transaction state 329 (let* ((state-spec (request-transaction-state request)) 330 (required-state (first state-spec)) 331 (new-state (second state-spec))) 332 (labels ((check-state (reopen-if-needed) 333 (let ((current-state (connection-transaction-state 334 *connection*))) 335 (when (and (not (eq current-state required-state)) 336 (not (eq current-state new-state))) 337 (cond 338 ((and (eq required-state 'in-data) 339 (not (eq new-state nil))) 340 (send-data-begin)) 341 ((eq required-state nil) 342 (send-data-end)))) 343 (setq current-state (connection-transaction-state 344 *connection*)) 345 (if (and reopen-if-needed 346 (not (eq current-state required-state)) 347 (not (eq current-state new-state)) 348 (not (connection-failure-p *connection*))) 349 (progn 350 (open-connection) 351 (setq *connection* (get-connection)) 352 (check-state nil)) 353 (eq current-state required-state))))) 354 ;; Continue only if the state can be set properly after reopen, 355 ;; otherwise give up and ignore the request completely. 356 ;; This also works for the "." command when in non-data state. 357 (when (check-state t) 358 (send-string (request-string request)) 359 ;; Read command answer 360 (unless (equal state-spec '(in-data in-data)) 361 (destructuring-bind (answer-line . data-lines) 362 (loop with stream = (connection-stream *connection*) 363 for line = (read-line stream) 364 for lines = (list line) then (cons line lines) 365 while (and (> (length line) 3) 366 (char= (char line 3) #\-)) 367 finally (return lines)) 368 (let* ((code (subseq answer-line 0 3)) 369 (answer (subseq answer-line 4)) 370 (success (member (char code 0) '(#\1 #\2))) 371 (data (and success 372 (mapcar #'(lambda (line) (subseq line 4)) 373 data-lines)))) 374 (when success 375 (setf (connection-transaction-state *connection*) new-state)) 376 (list success data code answer))))))))) 377 378(defun send-request (request) 379 (with-current-connection 380 (process-request request))) 381 382(defparameter +block-commands+ 383 '(("speak") 384 ("sound_icon") 385 ("char") 386 ("key") 387 ("quit") 388 ("block" ("end")) 389 ("set" ("self" ("rate" "pitch" "pitch_range" "voice" "language"))))) 390 391(defun block-command-p (command &optional allowed) 392 (unless allowed 393 (setq allowed +block-commands+)) 394 (let* ((match (assoc (first command) allowed :test #'string-equal)) 395 (rest-allowed (cdr match))) 396 (and match 397 (or (not rest-allowed) 398 (block-command-p (rest command) rest-allowed))))) 399 400(defun send-command (command &optional (transaction-state '(nil nil))) 401 (unless (listp command) 402 (setq command (list command))) 403 (with-current-connection 404 (setf (connection-last-command *connection*) command) 405 (when (or (not (connection-in-block *connection*)) 406 (block-command-p command)) 407 (send-request 408 (make-request 409 :string (format nil "~{~A~^ ~}~A~A" command #\Return #\Linefeed) 410 :transaction-state transaction-state))))) 411 412(defun send-data-begin () 413 (send-command "SPEAK" '(nil in-data))) 414 415(defun send-data (text) 416 (let ((text* text)) 417 (flet ((send (string) 418 (unless (string= string "") 419 (send-request (make-request 420 :string string 421 :transaction-state '(in-data in-data)))))) 422 (loop with eol = (format nil "~A~A" #\Return #\Linefeed) 423 for length = (length text*) 424 for nlpos = (or (position #\Linefeed text*) length) 425 for dotted = (and (> (length text*) 0) 426 (char= (char text* 0) #\.)) 427 until (string= text* "") 428 do (progn 429 (when dotted 430 (send ".")) 431 (send (subseq text* 0 nlpos)) 432 (send eol) 433 (setq text* (subseq text* (min (1+ nlpos) length)))))))) 434 435(defun send-data-end () 436 (send-command "." '(in-data nil))) 437 438 439;;; Value retrieval functions 440 441 442(defun list-values (parameter) 443 (second (send-command 444 (list "LIST" (cdr (assoc parameter +list-parameter-names+)))))) 445 446 447;;; Parameter setting functions 448 449 450(defun convert-numeric (number) 451 (cond ((< number -100) -100) 452 ((> number 100) 100) 453 (t number))) 454 455(defun transform-parameter-value (parameter value) 456 (cond 457 ((stringp value) 458 value) 459 ((integerp value) 460 (format nil "~D" (convert-numeric value))) 461 ((symbolp value) 462 (cdr (assoc value 463 (cdr (assoc parameter +parameter-value-mappings+))))))) 464 465(defun set-parameter (parameter value) 466 (with-current-connection 467 (let* ((plist (connection-parameters *connection*)) 468 (orig-value (if (plist-member plist parameter) 469 (plist-get plist parameter) 470 'unknown))) 471 (when (or (member parameter +volatile-parameters+) 472 (and (not (equal orig-value value)) 473 (or (not (eq parameter 'message-priority)) 474 (not (connection-forced-priority *connection*))))) 475 (let ((answer 476 (send-command 477 (let ((p (cdr (assoc parameter +parameter-names+))) 478 (v (transform-parameter-value parameter value))) 479 (unless p 480 (error "Invalid parameter name: `~A'" parameter)) 481 (unless v 482 (error "Invalid parameter value: ~A=~A" parameter value)) 483 (list "SET" "self" p v))))) 484 (setq *connection* (get-connection)) 485 (when (first answer) 486 (setf (connection-parameters *connection*) 487 (plist-put (connection-parameters *connection*) 488 parameter value)))))))) 489 490(defun set-connection-name (name) 491 (set-parameter 492 'client-name 493 (format nil "~A:~A:~A" (user-login-name) *application-name* name))) 494 495(defun set-language (language) 496 "Set language of the current client connection to LANGUAGE. 497Language must be an RFC 1766 language code, as a string." 498 (set-parameter 'language language) 499 (setq *language* language)) 500 501 502;;; Blocks 503 504 505(defmacro with-block (parameters &rest body) 506 "Set PARAMETERS and enclose BODY by an SSIP block. 507Before invoking BODY, the BLOCK BEGIN command is sent, and the BLOCK END 508command is sent afterwards. 509PARAMETERS is a property list defining parameters to be set before sending the 510BLOCK BEGIN command. The property-value pairs correspond to the arguments of 511the `set-parameter' function." 512 `(with-current-connection 513 (with-connection-parameters ,parameters 514 (if (and *connection* (connection-in-block *connection*)) 515 (progn ,@body) 516 (let ((block-connection *connection*)) 517 (send-command '("BLOCK BEGIN")) 518 (unwind-protect 519 (progn 520 (with-current-connection 521 (when *connection* 522 (setf (connection-in-block *connection*) t))) 523 ,@body) 524 (let ((*connection* block-connection)) 525 (when *connection* 526 (setf (connection-in-block *connection*) nil) 527 (let ((*client-name* 528 (connection-name *connection*))) 529 (send-command '("BLOCK END"))))))))))) 530 531 532;;; Speaking functions 533 534 535(defun say-text (text &key (priority *default-text-priority*)) 536 "Speak the given TEXT, represented by a string. 537The key argument `priority' defines the priority of the message and must be one 538of the symbols `important', `message', `text', `notification' or 539`progress'." 540 (set-parameter 'message-priority priority) 541 (unless (string= text "") 542 (send-data-begin) 543 (send-data text) 544 (send-data-end))) 545 546(defun say-sound (name &key (priority *default-sound-priority*)) 547 "Play an auditory icon. 548NAME is the name of the icon, any string acceptable by speechd. 549The key argument `priority' defines the priority of the message and must be one 550of the symbols `important', `message', `text', `notification' or 551`progress'." 552 (set-parameter 'message-priority priority) 553 (send-command (list "SOUND_ICON" name))) 554 555(defun say-char (char &key (priority *default-char-priority*)) 556 "Speak the given CHAR, any UTF-8 character. 557The key argument `priority' defines the priority of the message and must be one 558of the symbols `important', `message', `text', `notification' or 559`progress'." 560 (set-parameter 'message-priority priority) 561 (with-current-connection 562 (with-connection-parameters `(language ,*language*) 563 (send-command 564 (list "CHAR" (format nil "~A" (case char 565 (? "space") 566 (?\n "linefeed") 567 (t (format nil "~A" char))))))))) 568 569 570;;; Control functions 571 572 573(defun control-command (command all &optional repeatable) 574 (cond 575 ((not all) 576 (when (or repeatable 577 (not (equal (first (connection-last-command (get-connection))) 578 command))) 579 (send-command (list command "self")))) 580 ((numberp all) 581 (iterate-clients (control-command command nil))) 582 (t 583 (send-command (list command "all"))))) 584 585(defun cancel (&optional all) 586 "Stop speaking all the messages sent through the current client so far. 587If the universal argument is given, stop speaking messages of all clients. 588If a numeric argument is given, stop speaking messages of all current Emacs 589session clients." 590 (control-command "CANCEL" all)) 591 592(defun stop (&optional all) 593 "Stop speaking the currently spoken message (if any) of this client. 594If the optional argument ALL is non-nil, stop speaking the currently spoken 595messages of all clients." 596 (control-command "STOP" all t)) 597 598(defun pause (&optional all) 599 "Pause speaking in the current client. 600If the optional argument ALL is non-nil, pause speaking in all clients." 601 (if all 602 (iterate-connections 603 (setf (connection-paused-p *connection*) t)) 604 (setf (connection-paused-p (get-connection)) t)) 605 (control-command "PAUSE" (not (not all)))) 606 607(defun resume (&optional all) 608 "Resume previously stopped speaking in the current client. 609If the optional argument ALL is non-nil, resume speaking messages of all 610clients." 611 (when (or all (connection-paused-p (get-connection))) 612 (control-command "RESUME" (not (not all))) 613 (if all 614 (setf (connection-paused-p (get-connection)) nil) 615 (iterate-connections 616 (setf (connection-paused-p *connection*) nil))))) 617