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