cl-patterns-helpers.el

;;;; cl-patterns-helpers.el --- helper functions for use with cl-patterns. -*- lexical-binding: t; -*-

;; Copyright (C) 2021 modula t.

;; Author: modula t. <defaultxr AT gmail DOT com>
;; Homepage: https://github.com/defaultxr/cl-patterns
;; Version: 0.5
;; Package-Requires: ((emacs "24.4") cl-lib)
;; Keywords: convenience, languages, lisp, multimedia

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This is a small library that makes it more convenient to work with
;; cl-patterns and the synthesis engines it supports. Incuded are functions
;; for:
;; - playing/stopping the pattern, buffer, proxy, or other object under point
;; - stopping all playing patterns, nodes, etc.
;; - opening the SuperCollider documentation for a specific class (w/completion)
;; - and a few others.
;;
;; Recommended setup for your Emacs init file:
;;
;; (defun cl-patterns-helpers-load ()
;;     (interactive)
;;     (sly-eval-async '(cl:let ((system (asdf:find-system "cl-patterns" nil)))
;;                              (cl:when system (cl:namestring (asdf:system-source-directory system))))
;;       (lambda (path)
;;         (load (concat path "res/emacs/cl-patterns-helpers") nil nil nil t)
;;         (load (concat path "res/emacs/cl-patterns-skeletons") nil nil nil t)))
;;     (define-key sly-mode-map (kbd "C-c p") 'cl-patterns-play-or-end-context-or-select-pdef)
;;     (define-key sly-mode-map (kbd "C-c P") 'cl-patterns-play-or-stop-context-or-select-pdef)
;;     (define-key sly-mode-map (kbd "C-c s") 'cl-patterns-stop-all)
;;     (define-key sly-doc-map (kbd "s") 'cl-patterns-supercollider-documentation))
;;
;; (add-hook 'sly-connected-hook 'cl-patterns-helpers-load)
;;
;; The above should also work with slime; just replace all instances of "sly"
;; with "slime".

;;; Code:

(require 'cl-lib)

(defgroup cl-patterns nil
  "cl-patterns helper functionality."
  :group 'external
  :prefix "cl-patterns-")

;;; Utility functions

(defvar cl-patterns-named-object-regexp "\[\(:\]\\(pdef\\|pb\\|defsynth\\|ds\\|proxy\\|dn\\|bdef\\)\[ \t\n\]+\\([:']?\[^ \t\n\]+\\)"
  "Regexp to find \"named objects\", i.e. pdef, pb, defsynth, proxy, bdef, etc.")

(defun cl-patterns-friendly-string (string)
  "Remove and replace special characters from STRING."
  (or (cl-patterns-lisp-eval `(cl:when (cl:find-package 'mutility)
                                       (cl:funcall
                                        (cl:find-symbol "FRIENDLY-STRING" 'mutility)
                                        ,string)))
      (replace-regexp-in-string "[^A-Za-z0-9-]+" "-" string)))

(defun cl-patterns-random-word (&optional file)
  "Get a random word from FILE, which defaults to /usr/share/dict/words. If no
 such file exists, simply returns nil."
  (let ((file (or file "/usr/share/dict/words")))
    (when (file-exists-p file)
      (with-temp-buffer
        (insert-file-contents file)
        (delete-matching-lines "'s$")
        (goto-char (point-min))
        (forward-line (random (count-lines (point-min) (point-max))))
        (downcase (thing-at-point 'word))))))

(defun cl-patterns-random-letters (&optional length)
  "Generate a string of random letters of the specified LENGTH. If no length is
 provided, a random length between 3 and 12 letters is chosen."
  (concat (let (res)
            (dotimes (n (or length (+ 3 (random 10))) res)
              (ignore n)
              (push (elt "abcdefghijklmnopqrstuvwxyz" (random 26)) res)))))

(defun cl-patterns-generate-random-name ()
  "Generate a random \"name\" by either grabbing a random word from the system
dictionary file if it exists, or generating random letters.

This is used as the default function for `cl-patterns-name-generator', to
generate a name for a skeleton when the user supplies only a period."
  (concat ":" (or (cl-patterns-random-word)
                  (cl-patterns-random-letters))))

(defun cl-patterns-increase-number-suffix (string)
  "Increase the number at the end of STRING by 1. If there is no number at the end
 of STRING, suffix it with \"-1\". Note that dashes count as a separator, not as
 a negative sign."
  (if-let ((match (string-match "\\([[:digit:]]+\\)$" string)))
      (concat (cl-subseq string 0 (match-beginning 1))
              (number-to-string (1+ (string-to-number (match-string-no-properties 1 string)))))
    (concat string "-1")))

(defun cl-patterns-ensure-symbol-syntax (string)
  "Ensure that STRING starts with either a colon or an apostrophe; if neither,
return it prefixed with a colon."
  (if (or (member (elt string 0) (list ?: ?'))
          (cl-every #'cl-digit-char-p string))
      string
    (concat ":" string)))

(defun cl-patterns-lisp-eval (sexp)
  "Evaluate SEXP via slime or sly."
  (if (fboundp 'slime-eval)
      (slime-eval sexp)
    (sly-eval sexp)))

(defun cl-patterns-lisp-interactive-eval (string)
  "Evaluate STRING via slime or sly."
  (let ((current-prefix-arg nil))
    (if (fboundp 'slime-interactive-eval)
        (slime-interactive-eval string)
      (sly-interactive-eval string))))

(defun cl-patterns-lisp-eval-region (start end)
  "Evaluate the specified region via slime or sly."
  (if (fboundp 'slime-eval-region)
      (slime-eval-region start end)
    (sly-eval-region start end)))

(defun cl-patterns-context ()
  "Get the type (i.e., pdef, defsynth, proxy, etc) and name of the current
context, or nil if there is nothing under the point."
  (when-let ((bounds (bounds-of-thing-at-point 'defun)))
    (save-excursion
      (save-restriction
        (narrow-to-region (car bounds) (cdr bounds))
        (goto-char (point-min))
        (search-forward-regexp cl-patterns-named-object-regexp nil t)
        (list (ignore-errors (intern (match-string-no-properties 1))) (match-string-no-properties 2))))))

(defun cl-patterns-get-name-of-previous-item (items)
  "Get the name of the previous form whose type is one of ITEMS. For example, if
 ITEMS is \\='(defsynth proxy) then find the nearest defsynth or proxy before
the point and return its name."
  (save-excursion
    (let ((context (or (cl-patterns-context)
                       (list nil))))
      (beginning-of-defun)
      (while (and (not (member (car context) items))
                  (not (= (point) (point-min))))
        (backward-sexp)
        (setf context (cl-patterns-context)))
      (cadr context))))

(defun cl-patterns-guess-pdef ()
  "Find the nearest pdef name before point."
  (cl-patterns-get-name-of-previous-item (list 'pb 'pdef)))

(defun cl-patterns-guess-instrument ()
  "Find the nearest instrument name before point."
  (cl-patterns-get-name-of-previous-item (list 'defsynth 'ds 'proxy 'dn)))

;; FIX: make this
;; (defun cl-patterns-guess-instrument-from-pattern ()
;;   "Find the nearest pattern before point with an :instrument key and return the key's value."
;;   (cl-patterns-get-name-of-previous-item (list 'defsynth 'ds 'proxy 'dn)))

;; FIX: make this too
;; (defun cl-patterns-guess-bdef-from-pattern ()
;;   "Find the nearest pattern before point with a :buffer or :bufnum key and return the key's value."
;;   (cl-patterns-get-name-of-previous-item (list 'defsynth 'ds 'proxy 'dn)))

(defun cl-patterns-guess-bdef ()
  "Find the nearest bdef name before point."
  (cl-patterns-get-name-of-previous-item (list 'bdef)))

(defun cl-patterns-select-instrument (&optional prompt)
  "Select an instrument from the list of currently-defined instruments."
  (interactive)
  (let* ((prompt (or prompt "Instrument? "))
         (instruments (cl-patterns-lisp-eval
                       `(cl:mapcar (cl:lambda (x) (cl:string-downcase (cl:write-to-string x)))
                                   (cl-patterns:all-instruments))))
         (guess (cl-patterns-guess-instrument)))
    (cl-patterns-ensure-symbol-syntax
     (completing-read prompt instruments nil nil (when (member guess instruments) guess) 'cl-patterns-instrument-history))))

(defun cl-patterns-instrument-arguments (instrument)
  "Get a list of INSTRUMENT's arguments, or nil if the arguments can't be
determined."
  (unless (cl-every #'cl-digit-char-p instrument) ;; if INSTRUMENT is a number then it's likely referring to a midi backend, in which case we don't really have a standard way to get a list of said instrument's controls.
    (cl-patterns-lisp-eval
     `(cl:mapcar
       (cl:lambda (x) (cl:symbol-name (cl:car (alexandria:ensure-list x))))
       (cl-patterns::backend-instrument-controls
        (cl:car (cl-patterns:all-backends :enabled-p t :started-p t))
        ,(intern (upcase (cl-patterns-ensure-symbol-syntax instrument))))))))

;;; Commands

(defun cl-patterns-stop-all ()
  "Stop all currently-playing patterns, nodes, etc. Sometimes referred to as
\"MIDI panic\"."
  (interactive)
  (cl-patterns-lisp-eval '(cl-patterns:stop t)))

(defun cl-patterns-play-or-end-context (&optional stop)
  "Play or end the pdef, synthdef, bdef, etc, underneath the point. When STOP is
true, play or stop instead."
  (interactive)
  (let* ((context (cl-patterns-context))
         (type (car context))
         (name (cadr context)))
    (cond
     ((member type (list 'pdef 'pb 'pbind))
      (cl-patterns-lisp-interactive-eval (concat "(cl-patterns:" (if stop "play-or-stop" "play-or-end") " " name ")")))
     ((member type (list 'proxy 'dn))
      (let ((bounds (bounds-of-thing-at-point 'defun)))
        (if (cl-patterns-lisp-eval `(cl-patterns:playing-p (cl-patterns::find-object-by-id ,(intern name))))
            (cl-patterns-lisp-interactive-eval (concat "(cl-patterns:" (if stop "play-or-stop" "play-or-end") " " name ")"))
          (cl-patterns-lisp-eval-region (car bounds) (cdr bounds)))))
     ((member type (list 'defsynth 'defsynth* 'ds))
      (cl-patterns-lisp-interactive-eval
       (concat "(cl-patterns:play (cl-patterns:event :instrument " name " :dur 2 :amp 1 :latency 0 :quant 0))")))
     ((member type (list 'bdef))
      (cl-patterns-lisp-interactive-eval (concat "(cl-patterns:play (bdef:bdef " name "))"))))))

(defun cl-patterns-play-or-stop-context ()
  "Play or stop the pdef, synthdef, bdef, etc, etc, underneath the point."
  (interactive)
  (cl-patterns-play-or-end-context t))

(defun cl-patterns--playing-stopped-pdefs ()
  "Get a list of two elements: a list of playing pdefs' names, and a list of
non-playing/stopped pdefs' names."
  (cl-patterns-lisp-eval
   `(cl:let* ((playing (cl-patterns:playing-pdef-names))
              (all (cl-patterns:all-pdef-names)))
             (cl:list playing (cl:remove-if (cl:lambda (pdef) (cl:member pdef playing))
                                            all)))))

(defun cl-patterns-play-or-end-pdef (&optional stop)
  "Select a pdef to play or end. With a prefix argument, stop instead of end."
  (interactive "P")
  (when-let* ((playing-stopped (cl-patterns--playing-stopped-pdefs))
              (pdefs (append (mapcar (lambda (pdef)
                                       (format "%s (playing)" pdef))
                                     (cl-first playing-stopped))
                             (mapcar #'symbol-name (cl-second playing-stopped))))
              (selection (completing-read (concat "Play or " (if stop "stop" "end") ": ") pdefs nil nil))
              (func (if stop "cl-patterns:play-or-stop" "cl-patterns:play-or-end")))
    (cl-patterns-lisp-interactive-eval (concat "(" func " " (cl-first (split-string selection)) ")"))))

(defun cl-patterns-play-or-stop-pdef ()
  "Select a pdef to play or stop."
  (interactive)
  (cl-patterns-play-or-end-pdef t))

(defun cl-patterns-play-or-end-context-or-select-pdef (&optional arg stop)
  "Play or end the current context, or if no relevant context was found (and ARG
was not provided), call `cl-patterns-play-or-end-pdef' to select a pdef to
play/end. When STOP is true, stop instead of end."
  (interactive "P")
  (let ((context (cl-patterns-context)))
    (if (or arg
            (not (car context)))
        (cl-patterns-play-or-end-pdef stop)
      (cl-patterns-play-or-end-context stop))))

(defun cl-patterns-play-or-stop-context-or-select-pdef (&optional arg)
  "Play or stop the current context, or if no relevant context was found (and ARG
was not provided), call `cl-patterns-play-or-stop-pdef' to select a pdef to
play/stop."
  (interactive "P")
  (let ((context (cl-patterns-context)))
    (if (or (not (car context)) arg)
        (cl-patterns-play-or-stop-pdef)
      (cl-patterns-play-or-stop-context))))

;;; SuperCollider documentation functionality

(defvar cl-patterns-supercollider-classes-list nil
  "List of SuperCollider classes for
`cl-patterns-supercollider-populate-classes-list'.")

(defun cl-patterns-populate-supercollider-classes-list (&optional force)
  "Populate `cl-patterns-supercollider-classes-list' if it is nil or FORCE is true."
  (when (or (not cl-patterns-supercollider-classes-list)
            force)
    (let ((separator "----- CLASSES -----")
          (file (concat (temporary-file-directory) "supercollider-populate-classes-list.scd")))
      (with-temp-file file
        (insert "\"" separator "\".postln;Object.allSubclasses.do(_.postcs);\"" separator "\".postln;s.isNil.if({0.exit},{s.waitForBoot({s.quit;0.exit;})});"))
      (let ((sclang-classes-process (start-process "sclang-classes-process" "*sclang-classes-output*" "sclang" file)))
        (set-process-sentinel sclang-classes-process
                              (lambda (process event)
                                (ignore process)
                                (when (string= "finished\n" event)
                                  (with-current-buffer "*sclang-classes-output*"
                                    (goto-char (point-min))
                                    (search-forward (concat "\n" separator "\n"))
                                    (setf cl-patterns-supercollider-classes-list
                                          (sort (split-string (buffer-substring-no-properties (point) (- (save-excursion (search-forward (concat "\n" separator "\n")) (point)) (length separator) 2)) "\n" t) #'string<)))
                                  (kill-buffer "*sclang-classes-output*"))))))))

(cl-patterns-populate-supercollider-classes-list)

(defun cl-patterns-supercollider-documentation (ugen)
  (interactive (list
                (completing-read "Class: " cl-patterns-supercollider-classes-list nil nil "^")))
  (browse-url (concat "http://doc.sccode.org/Classes/" ugen ".html")))

(provide 'cl-patterns-helpers)
;;; cl-patterns-helpers.el ends here