197 lines
8.3 KiB
Common Lisp
197 lines
8.3 KiB
Common Lisp
;; sliders.lsp -- communicate with NyquistIDE to implement control panels
|
|
;; Roger B. Dannenberg
|
|
;; April 2015
|
|
|
|
;; (stop-on-zero s) -- a sound that returns 1 until s goes to zero, then
|
|
;; the sound terminates. If s comes from a slider and you multiply
|
|
;; a sound by (stop-on-zero s), you can interactively stop it
|
|
;; (make-slider-panel "name" color) -- sets panel name for the following
|
|
;; sliders
|
|
;; (make-slider "param" [initial [low high]]) -- create slider named
|
|
;; "param" with optional range and initial value. Also returns
|
|
;; a sound.
|
|
;; (make-button "param" normal) -- create a button named "param" with
|
|
;; a starting value of normal (either 0 or 1). While the button
|
|
;; in the panel is pressed, the value changes to 1 or 0.
|
|
;; (get-slider-value "param") -- when called with a string, this looks up
|
|
;; the slider value by name
|
|
;; (slider-panel-close "name") -- close the panel window. Values of any
|
|
;; existing sliders become undefined.
|
|
;; (slider "panel" "name" [dur]) -- make a signal from slider value
|
|
;; (slider "name" [dur]) -- make a signal from slider in current panel
|
|
;; (get-slider-value "panel" "name") -- get a float value
|
|
;; (get-slider-value "name") -- get a float in current panel
|
|
|
|
;; *active-slider-panel* is the current panel to which sliders are added
|
|
;;
|
|
(if (not (boundp '*active-slider-panel*))
|
|
(setf *active-slider-panel* nil))
|
|
|
|
;; *panels-in-use* is an assoc list of panels, where each panel
|
|
;; is a list of allocated sliders stored as (name number)
|
|
;;
|
|
(if (not (boundp '*panels-in-use*))
|
|
(setf *panels-in-use* nil))
|
|
|
|
;; allocate-slider-num -- find an unused slider number
|
|
;; linear search is used to avoid maintaining a parallel structure
|
|
;; for faster searching. We search starting at slider #10, leaving
|
|
;; sliders 0-9 unused; for example, you might want to control them
|
|
;; via open sound control, so this gives you 10 sliders that are
|
|
;; off limits to allocation by the SLIDER function.
|
|
;;
|
|
;; This code takes advantage of the fact that dotimes and dolist
|
|
;; return nil when they end normally, so we signal that we found
|
|
;; or did not find i by explicitly returning. Note that RETURN
|
|
;; returns from the innermost dotimes or dolist -- they do not
|
|
;; return from allocate-slider-num.
|
|
;;
|
|
(defun allocate-slider-num ()
|
|
(dotimes (n 990)
|
|
(let ((i (+ n 10)))
|
|
(cond ((not (dolist (panel *panels-in-use*)
|
|
(cond ((dolist (pair (cdr panel))
|
|
(cond ((eql (second pair) i) (return t))))
|
|
(return t)))))
|
|
(return i))))))
|
|
|
|
;; remove panel from list of panels
|
|
(defun slider-panel-free (panel)
|
|
(setf *panels-in-use* (remove panel *panels-in-use* :test #'equal)))
|
|
|
|
(setfn stop-on-zero snd-stoponzero)
|
|
|
|
(defun make-slider-panel (name &optional (color 0))
|
|
(let ((panel (assoc name *panels-in-use* :test #'equal)))
|
|
;; first find if panel already exists. If so, free the resources
|
|
(cond (panel
|
|
(slider-panel-free panel)))
|
|
(setf *active-slider-panel* (list name))
|
|
(setf *panels-in-use* (cons *active-slider-panel* *panels-in-use*))
|
|
(format t "slider-panel-create: \"~A\" ~A~%" name color)))
|
|
|
|
(defun make-slider (name &optional (init 0) (low 0) (high 1))
|
|
(let ((num (allocate-slider-num)))
|
|
(cond ((null num)
|
|
(format t "WARNING: MAKE-SLIDER is out of slider numbers. ~A~%"
|
|
"No slider created."))
|
|
((not (and (stringp name) (numberp init)
|
|
(numberp low) (numberp high)))
|
|
(display
|
|
"WARNING: MAKE-SLIDER called with bad arguments. No slider created"
|
|
name init low high)))
|
|
;; make sure we have an active panel
|
|
(cond ((null *active-slider-panel*)
|
|
(make-slider-panel "Controls")))
|
|
;; insert new slider into list of sliders in active panel. This
|
|
;; is aliased with an element in the assoc list *panels-in-use*.
|
|
(rplacd *active-slider-panel* (cons (list name num)
|
|
(cdr *active-slider-panel*)))
|
|
(format t "slider-create: \"~A\" ~A ~A ~A ~A~%" name num init low high)
|
|
num))
|
|
|
|
(defun make-button (name &optional (normal 0))
|
|
(let ((num (allocate-slider-num)))
|
|
(cond ((null num)
|
|
(format t "WARNING: MAKE-BUTTON is out of slider numbers. ~A~%"
|
|
"No button created."))
|
|
((not (and (stringp name) (numberp normal)))
|
|
(display
|
|
"WARNING: MAKE-BUTTON called with bad arguments. No button created"
|
|
name normal)))
|
|
;; make sure we have an active panel
|
|
(cond ((null *active-slider-panel*)
|
|
(slider-panel "Controls")))
|
|
;; insert new button into list of controls in active panel. This
|
|
;; is aliased with an element in the assoc list *panels-in-use*.
|
|
(rplacd *active-slider-panel* (cons (list name num)
|
|
(cdr *active-slider-panel*)))
|
|
(format t "button-create: \"~A\" ~A ~A~%" name num normal)
|
|
num))
|
|
|
|
(defun close-slider-panel (name)
|
|
(let ((panel (assoc name *panels-in-use* :test #'equal)))
|
|
(cond ((not (stringp name))
|
|
(display "WARNING: SLIDER-PANEL-CLOSED called with bad argument."
|
|
name)))
|
|
(cond (panel
|
|
(slider-panel-free panel)
|
|
(format t "slider-panel-close: \"~A\"~%" name))
|
|
(t
|
|
(format t "WARNING: slider panel ~A not found.~%" name)))))
|
|
|
|
;; SLIDER-LOOKUP - find the slider by name
|
|
;;
|
|
(defun slider-lookup (name slider)
|
|
(let ((panel (assoc name *panels-in-use* :test #'equal)) s)
|
|
(cond ((null panel)
|
|
(error "Could not find slider panel named" name)))
|
|
(setf s (assoc slider (cdr panel) :test #'equal))
|
|
(cond ((null s)
|
|
(error "Could not find slider named" s)))
|
|
(second s)))
|
|
|
|
|
|
;; SLIDER - creates a signal from real-time slider input
|
|
;;
|
|
;; options are:
|
|
;; (SLIDER number [dur])
|
|
;; (SLIDER "name" [dur]) -- look up slider in current slider panel
|
|
;; (SLIDER "panel" "name" [dur]) -- look up panel, then look up slider
|
|
;;
|
|
(defun slider (id &optional slider-name dur)
|
|
(cond ((and (numberp id) (null slider-name))
|
|
(setf dur 1.0))
|
|
((and (numberp id) (numberp slider-name) (null dur))
|
|
(setf dur slider-name))
|
|
((and (stringp id) (null slider-name))
|
|
(setf dur 1.0)
|
|
(setf id (slider-lookup (car *active-slider-panel*) id)))
|
|
((and (stringp id) (numberp slider-name) (null dur))
|
|
(setf dur slider-name)
|
|
(setf id (slider-lookup (car *active-slider-panel*) id)))
|
|
((and (stringp id) (stringp slider-name) (null dur))
|
|
(setf dur 1.0)
|
|
(setf id (slider-lookup id slider-name)))
|
|
((and (stringp id) (stringp slider-name) (numberp dur))
|
|
(setf id (slider-lookup id slider-name)))
|
|
(t
|
|
(error "SLIDER called with invalid arguments")))
|
|
(setf dur (get-duration dur))
|
|
(setf id (round id)) ;; just to make sure it's an integer
|
|
(cond ((or (< id 0) (>= id 1000))
|
|
(error "SLIDER index out of bounds" id)))
|
|
(display "slider" id slider-name dur)
|
|
(snd-slider id *rslt* *sound-srate* dur))
|
|
|
|
|
|
(if (not (boundp '*lpslider-cutoff*))
|
|
(setf *lpslider-cutoff* 20.0))
|
|
|
|
(defun lpslider (id &optional slider-name dur)
|
|
(lp (slider id slider-name dur) 20.0))
|
|
|
|
;; save built-in get-slider-value so we can redefine it
|
|
(if (not (fboundp 'prim-get-slider-value))
|
|
(setfn prim-get-slider-value get-slider-value))
|
|
|
|
(defun get-slider-value (id &optional slider-name)
|
|
(cond ((and (numberp id) (null slider-name)) nil)
|
|
((and (stringp id) (null slider-name))
|
|
(setf id (slider-lookup (car *active-slider-pael*) id)))
|
|
((and (stringp id) (stringp slider-name))
|
|
(setf id (slider-lookup id slider-name)))
|
|
(t
|
|
(error "GET-SLIDER-VALUE called with invalid arguments")))
|
|
;; further parameter checking is done in get-slider-value:
|
|
(prim-get-slider-value id))
|
|
|
|
(autonorm-off)
|
|
(snd-set-latency 0.02)
|
|
(print "**********sliders.lsp************************")
|
|
(print "WARNING: AUTONORM IS NOW TURNED OFF")
|
|
(print "WARNING: AUDIO LATENCY SET TO 20MS")
|
|
(print "To restore settings, execute (autonorm-on) and")
|
|
(print " (set-audio-latency 0.3)")
|
|
(print "*********************************************")
|