editors/scel/el/sclang-server.el

   1 ;; copyright 2003-2005 stefan kersten <steve@k-hornz.de>
   2 ;;
   3 ;; This program is free software; you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation; either version 2 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; This program is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with this program; if not, write to the Free Software
  15 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
  16 ;; USA
  17
  18 (eval-when-compile
  19   (require 'cl)
  20   (require 'sclang-util)
  21   (require 'sclang-interp)
  22   (require 'sclang-language)
  23   (require 'sclang-mode))
  24
  25 (defcustom sclang-server-panel "Server.default.makeWindow"
  26   "*Expression to execute when `sclang-show-server-panel' is invoked."
  27   :group 'sclang-interface
  28   :type '(choice (const "Server.default.makeWindow")
  29                  (const "\\SCUM.asClass.do { \\SCUM.asClass.desktop.showServerPanel }")
  30                  string))
  31
  32 (defvar sclang-server-alist nil
  33   "Alist of currently defined synthesis servers.")
  34
  35 (defvar sclang-default-server nil
  36   "Default synthesis server.")
  37
  38 (defvar sclang-current-server nil
  39   "Currently selected synthesis server.")
  40
  41 (defvar sclang-current-server-initialized nil
  42   "Non nil when the current server has been initialized from the default server.")
  43
  44 (defconst sclang-server-running-face
  45   (let ((face (make-face 'sclang-server-running-face)))
  46     (set-face-foreground face "red")
  47     face)
  48   "Face for highlighting a server's running state in the mode-line.")
  49
  50 (defun sclang-get-server (&optional name)
  51   (unless name (setq name sclang-current-server))
  52   (cdr (assq name sclang-server-alist)))
  53
  54 (defun sclang-set-server (&optional name)
  55   (unless name (setq name sclang-current-server))
  56   (setq sclang-current-server
  57         (car (or (assq name sclang-server-alist)
  58                  (car sclang-server-alist)))))
  59
  60 (sclang-set-command-handler
  61  '_updateServer
  62  (lambda (arg)
  63    (setq sclang-server-alist
  64          (sort (cdr arg) (lambda (a b) (string< (car a) (car b)))))
  65    (setq sclang-default-server (car arg))
  66    (unless sclang-current-server-initialized
  67      ;; only set the current server automatically once after startup
  68      (setq sclang-current-server-initialized t)
  69      (sclang-set-server sclang-default-server))
  70    (sclang-update-server-info)))
  71
  72 (defun sclang-next-server ()
  73   "Select next server for display."
  74   (interactive)
  75   (sclang-set-server)
  76   (let ((list (or (cdr (member-if (lambda (assoc)
  77                                     (eq (car assoc) sclang-current-server))
  78                                   sclang-server-alist))
  79                   sclang-server-alist)))
  80     (setq sclang-current-server (car (car list))))
  81   (sclang-update-server-info))
  82
  83 (defun sclang-mouse-next-server (event)
  84   "Select next server for display."
  85   (interactive "e")
  86   (sclang-next-server))
  87
  88 (defun sclang-server-running-p (&optional name)
  89   (plist-get (sclang-get-server name) 'running))
  90
  91 (defun sclang-server-booting-p (&optional name)
  92   (plist-get (sclang-get-server name) 'booting))
  93
  94 (defun sclang-create-server-menu (title)
  95   (easy-menu-create-menu
  96    title
  97    '(
  98      ["Boot" sclang-server-boot]
  99      ["Quit" sclang-server-quit]
 100      "-"
 101      ["Free All" sclang-server-free-all :active (sclang-server-running-p)]
 102      ["Make Default" sclang-server-make-default]
 103      )))
 104
 105 (defun sclang-server-fill-mouse-map (map prefix)
 106   (define-key map (vector prefix 'mouse-1) 'sclang-mouse-next-server)
 107   (define-key map (vector prefix 'down-mouse-3) (sclang-create-server-menu "Commands"))
 108   map)
 109
 110 (defvar sclang-server-mouse-map (sclang-server-fill-mouse-map (make-sparse-keymap) 'mode-line)
 111   "Keymap used for controlling servers in the mode line.")
 112
 113 (defun sclang-server-fill-key-map (map)
 114   "Fill server prefix map."
 115   (define-key map [?b] 'sclang-server-boot)
 116   (define-key map [?d] 'sclang-server-display-default)
 117   (define-key map [?f] 'sclang-server-free-all)
 118   (define-key map [?m] 'sclang-server-make-default)
 119   (define-key map [?n] 'sclang-next-server)
 120   (define-key map [?o] 'sclang-server-dump-osc)
 121   (define-key map [?p] 'sclang-show-server-panel)
 122   (define-key map [?q] 'sclang-server-quit)
 123   (flet ((fill-record-map (map)
 124                           (define-key map [?n] 'sclang-server-prepare-for-record)
 125                           (define-key map [?p] 'sclang-server-pause-recording)
 126                           (define-key map [?r] 'sclang-server-record)
 127                           (define-key map [?s] 'sclang-server-stop-recording)
 128                           map))
 129     (define-key map [?r] (fill-record-map (make-sparse-keymap))))
 130   map)
 131
 132 (defvar sclang-server-key-map (sclang-server-fill-key-map (make-sparse-keymap))
 133   "Keymap used for controlling servers.")
 134
 135 (defun sclang-get-server-info-string ()
 136   "Return a mode-line string for the current server."
 137   (let* ((name (if sclang-current-server (symbol-name sclang-current-server) "-------"))
 138          (server (sclang-get-server))
 139          (running-p (if server (plist-get server 'running)))
 140          (string (propertize
 141                   name
 142                   'face (if running-p sclang-server-running-face)
 143                   'help-echo "mouse-1: next server, mouse-3: command menu"
 144                   'keymap sclang-server-mouse-map))
 145          ;; (make-mode-line-mouse-map 'mouse-1 'sclang-mouse-next-server)))
 146          (address (if (and server (not (eq (plist-get server 'type) 'internal)))
 147                       (format " (%s)" (plist-get server 'address))
 148                     ""))
 149          (info (if running-p
 150                    (mapcar 'number-to-string
 151                            (plist-get (sclang-get-server) 'info))
 152                  '("---" "---" "----" "----" "----" "----"))))
 153     (apply 'format "%s%s %3s|%3s %% u: %4s s: %4s g: %4s d: %4s" string address info)))
 154
 155 (defvar sclang-server-info-string (sclang-get-server-info-string)
 156   "Info string used in the post buffer mode line.")
 157
 158 (defun sclang-update-server-info ()
 159   (interactive)
 160   (sclang-set-server)
 161   (setq sclang-server-info-string (sclang-get-server-info-string))
 162   (force-mode-line-update))
 163
 164 ;; =====================================================================
 165 ;; language control
 166 ;; =====================================================================
 167
 168 (defun sclang-perform-server-command (command &rest args)
 169   (sclang-eval-string
 170    (sclang-format "Server.named.at(%o.asSymbol).performList(\\tryPerform, %o.asSymbol.asArray ++ %o)"
 171                   sclang-current-server command args)
 172    nil))
 173
 174 (defun sclang-server-boot ()
 175   "Boot the current server."
 176   (interactive)
 177   (sclang-perform-server-command "boot"))
 178
 179 (defun sclang-server-reboot ()
 180   "Reboot the current server."
 181   (interactive)
 182   (sclang-perform-server-command "reboot"))
 183
 184 (defun sclang-server-quit ()
 185   "Quit the current server."
 186   (interactive)
 187   (sclang-perform-server-command "quit"))
 188
 189 (defun sclang-server-free-all ()
 190   "Free all nodes on the current server."
 191   (interactive)
 192   (sclang-perform-server-command "freeAll"))
 193
 194 (defun sclang-server-display-default ()
 195   "Display default server."
 196   (interactive)
 197   (when sclang-default-server
 198     (sclang-set-server sclang-default-server)
 199     (sclang-update-server-info)))
 200
 201 (defun sclang-server-make-default ()
 202   "Make current server the default server."
 203   (interactive)
 204   (when sclang-current-server
 205     (sclang-eval-string
 206      (sclang-format "
 207 var server;
 208 server = Server.named.at(%o);
 209 if (server.notNil) {
 210     Server.default = server;
 211     thisProcess.interpreter.s = server;
 212     \"Default server: %\n\".postf(server.name);
 213 };
 214 " sclang-current-server))
 215     nil))
 216
 217 (defun sclang-server-dump-osc (&optional code)
 218   "Set the current server's dump OSC mode."
 219   (interactive "P")
 220   (sclang-perform-server-command "dumpOSC"
 221                                  (cond ((consp code) 0)
 222                                        ((null code) 1)
 223                                        (t code))))
 224
 225 (defun sclang-server-prepare-for-record (&optional path)
 226   "Prepare current server for recording a sound file."
 227   (interactive
 228    (list
 229     (and current-prefix-arg (read-file-name "Record to file: "))))
 230   (sclang-perform-server-command "prepareForRecord" path))
 231
 232 (defun sclang-server-record ()
 233   "Record a sound file on the current server."
 234   (interactive)
 235   (sclang-perform-server-command "record"))
 236
 237 (defun sclang-server-pause-recording ()
 238   "Pause recording on the current server."
 239   (interactive)
 240   (sclang-perform-server-command "pauseRecording"))
 241
 242 (defun sclang-server-stop-recording ()
 243   "Stop recording on the current server."
 244   (interactive)
 245   (sclang-perform-server-command "stopRecording"))
 246
 247 (defun sclang-set-server-latency (lat)
 248   "Set the current server's `latency' instance variable."
 249   (interactive "nSet latency: ")
 250   (sclang-perform-server-command "latency_" lat))
 251
 252 (defun sclang-show-server-latency ()
 253   "Show the current server's latency."
 254   (interactive)
 255   (let ((server (sclang-get-server)))
 256     (message "%s" (and server (plist-get server 'latency)))))
 257
 258 (defun sclang-show-server-panel ()
 259   "Show graphical server panel if available."
 260   (interactive)
 261   (sclang-eval-string sclang-server-panel))
 262
 263 ;; =====================================================================
 264 ;; module setup
 265 ;; =====================================================================
 266
 267 (add-hook 'sclang-mode-hook
 268           (lambda ()
 269             ;; install server mode line in post buffer
 270             (when (string= (buffer-name) sclang-post-buffer)
 271               (setq mode-line-format '("-" sclang-server-info-string)))
 272             ;; install server prefix keymap
 273             (define-key sclang-mode-map "\C-c\C-p" sclang-server-key-map)))
 274
 275 (add-hook 'sclang-library-shutdown-hook
 276           (lambda ()
 277             (setq sclang-current-server-initialized nil)))
 278
 279 (provide 'sclang-server)
 280
 281 ;; EOF