From 73ca64cbea897e6158ce307014fef1b226f281a9 Mon Sep 17 00:00:00 2001 From: nik Date: Wed, 3 May 2017 22:18:06 +0200 Subject: [PATCH] setting event definition to a new base ... --- megra-constructors.lisp | 95 ----------- megra-event-base.lisp | 220 ++++++++++++++++++++++++++ megra-event-definitions.lisp | 202 ++++++++++++++++++++++++ megra-events.lisp | 298 ----------------------------------- megra-object-handling.lisp | 40 +++++ megra-package.lisp | 4 +- megra-start.lisp | 9 -- 7 files changed, 465 insertions(+), 403 deletions(-) create mode 100644 megra-event-base.lisp create mode 100644 megra-event-definitions.lisp delete mode 100644 megra-events.lisp create mode 100644 megra-object-handling.lisp diff --git a/megra-constructors.lisp b/megra-constructors.lisp index 0073702..617c301 100644 --- a/megra-constructors.lisp +++ b/megra-constructors.lisp @@ -212,101 +212,6 @@ (setf (gethash name *processor-directory*) new-inst)) name) -;; events -(defun string-event (msg) - (make-instance 'string-event :msg msg :tags nil)) - -(defun mid (pitch &key (dur 512) (lvl 0.4) (tags nil) (combi-fun #'replace-value)) - (make-instance 'midi-event :pitch pitch :lvl lvl :dur dur :tags tags :combi-fun combi-fun)) - -(defun grain (folder file &key - (tags nil) - (dur 256) - (lvl 0.5) - (pos 0.5) - (start 0.0) - (rate 1.0) - (hp-freq 10) - (hp-q 0.4) - (pf-freq 1000) - (pf-q 10) - (pf-gain 0.0) - (lp-freq 19000) - (lp-q 0.4) - (lp-dist 0.0) - (atk 7) - (rel 7) - (rev 0.0) - (azi 0.0) - (ele 0.0) - (ambi nil) - (combi-fun #'replace-value)) - (make-instance 'grain-event :lvl lvl :dur dur :start start :pos pos :hp-freq hp-freq - :rate rate :hp-freq hp-freq :hp-q hp-q - :pf-freq pf-freq :pf-q pf-q :pf-gain pf-gain - :lp-freq lp-freq :lp-q lp-q :lp-dist lp-dist :rev rev - :atk atk :rel rel :sample-folder folder :sample-file file :tags tags :azi azi - :ele ele :dist 1.0 :ambi-p ambi :combi-fun combi-fun)) - -(in-package :megra) -(defun gendy (&key - (adstr 1) - (ddstr 1) - (adstr-par 1) - (ddstr-par 1) - (freq-min 400) - (freq-max 410) - (tags nil) - (dur 256) - (a-scl 0.01) - (d-scl 0.01) - (lp-freq 19000) - (lp-q 0.4) - (lp-dist 0.0) - (atk 7) - (rel 7) - (rev 0.0) - (lvl 0.5) - (pos 0.5) - (azi 0.0) - (ele 0.0) - (ambi nil) - (combi-fun #'replace-value)) - (make-instance 'gendy-event :lvl lvl :dur dur - :adstr adstr :ddstr ddstr :adstr-par adstr-par - :ddstr-par ddstr-par :freq-max freq-max :freq-min freq-min - :a-scl a-scl :d-scl d-scl - :lp-freq lp-freq :lp-q lp-q :lp-dist lp-dist :rev rev - :atk atk :rel rel :tags tags :azi azi :pos pos - :ele ele :dist 1.0 :ambi-p ambi :combi-fun combi-fun) - ) - -(defun ctrl (ctrl-fun &key (tags nil)) - (make-instance 'control-event :control-function ctrl-fun :tags tags)) - -(defun dur (dur &key (tags nil) (combi-fun #'replace-value)) - (make-instance 'duration-event :dur dur :tags tags :combi-fun combi-fun)) - -(defun lvl (lvl &key (tags nil) (combi-fun #'replace-value)) - (make-instance 'level-event :lvl lvl :tags tags :combi-fun combi-fun)) - -(defun pitch (pitch &key (tags nil) (combi-fun #'replace-value)) - (make-instance 'pitch-event :pitch pitch :tags tags :combi-fun combi-fun)) - -(defun pos (pos &key (azi 0) (ele 0) (dist 0) (tags nil) (combi-fun #'replace-value)) - (make-instance 'spatial-event :pos pos :azi azi :ele ele - :dist dist :tags tags :combi-fun combi-fun)) - -(defun ambi-pos (azi ele &key (dist 0) (tags nil) (combi-fun #'replace-value)) - (make-instance 'spatial-event :pos 0.0 :azi azi :ele ele - :dist dist :tags tags :ambi-p t :combi-fun combi-fun)) - -(defun rate (rate &key (tags nil) (combi-fun #'replace-value)) - (make-instance 'rate-event :rate rate :tags tags :combi-fun combi-fun)) - -(defun start (start &key (tags nil) (combi-fun #'replace-value)) - (make-instance 'start-event :start start :tags tags :combi-fun combi-fun)) - ;; deactivate ... if it's a modifying event processor, delete it ... (defun deactivate (event-processor-id &key (del nil)) (setf (is-active (gethash event-processor-id *processor-directory*)) nil) diff --git a/megra-event-base.lisp b/megra-event-base.lisp new file mode 100644 index 0000000..52e4c4c --- /dev/null +++ b/megra-event-base.lisp @@ -0,0 +1,220 @@ +;; stateful parameter modifier ... (yes, really ...) +;; every one of those needs an "evaluate" function ... +(defclass param-mod-object () + ((step :accessor pmod-step :initform 0) + (time :accessor pmod-time :initform 0) + (current-value :accessor pmod-current-value :initarg :current-value))) + +;; before each evaluation, set time ... +(defmethod evaluate :before ((p param-mod-object)) + (setf (pmod-time p) (incudine:now))) + +(require :incudine) +;; after each evaluation, increment step counter +(defmethod evaluate :after ((p param-mod-object)) + (incf (pmod-step p))) + +;; this one is stateless, not dependent on current value ... +(defclass param-oscillate-between (param-mod-object) nil) + +(defmethod evaluate ((o param-oscillate-between)) + (let* ((osc-range (- upper lower)) + (degree-increment (/ 360 cycle o)) + (degree (mod (* degree-increment (mod step cycle)) 360)) + (abs-sin (abs (sin (radians degree))))) + (+ lower (* abs-sin osc-range)))) + +(defclass generic-brownian-motion () + (upper-boundary :accessor ubound :initarg :upper-boundary) + (lower-boundary :accessor lbound :initarg :lower-boundary) + (step-size :accessor step-size :initarg :step-size) + (is-bounded :accessor is-bounded :initarg :is-bounded) + (is-wrapped :accessor is-wrapped :initarg :is-wrapped)) + +;; cap or wrap ... +(defmethod cap ((b generic-brownian-motion) value &key) + (cond ((is-bounded b) + (cond ((< value (lbound b)) (lbound b)) + ((> value (ubound b)) (ubound b)) + (t value))) + ((is-wrapped b) + (cond ((< value (lbound b)) (ubound b)) + ((> value (ubound b)) (lbound b)) + (t value))) + (t value))) + +;; this one is stateful ... +(defclass param-brownian-motion (generic-brownian-motion param-mod-object)) + +(defmethod evaluate ((b param-brownian-motion)) + (let* ((new-value (cap b (+ (pmod-current-value b) + (* (nth (random 2) '(-1 1)) (step-size b)))))) + ;; stateful - don't forget to set value ! + (setf (pmod-current-value b) new-value) + ;; return new value + new-value)) + +;; the atomic units of music - event and transition ... +(defclass event () + ((source :accessor event-source) + (tags :accessor event-tags :initarg :tags) + (backends :accessor event-backends :initarg :backends :initform `(,*default-dsp-backend*)) + (value-combine-function :accessor value-combine-function + :initarg :combi-fun :initform #'replace-value))) + +;; the default value combination function +(defun replace-value (b a) a) + +;; DIRECTLY EVENT-RELEATED OBJECT HANDLING METHODS ... +(defmethod event-has-slot ((e event) slot &key) + (member slot (class-slots (class-of e)) :test 'slot-eq)) + +(defmethod event-has-slot-by-name ((e event) slot-name &key) + (member slot-name (mapcar #'slot-definition-name (class-slots (class-of e))))) + +;; check if event b has all slots that event a has +(defmethod events-compatible ((a event) (b event) &key) + (subsetp (class-slots (class-of a)) (class-slots (class-of b)) :test 'slot-eq)) + +(defmethod overwrite-slots ((a event) (b event) &key) + (loop for slot in (class-slots (class-of a)) + do (when (slot-boundp-using-class (class-of b) b slot) + (unless (member (slot-definition-name slot) *protected-slots*) + (setf (slot-value b (slot-definition-name slot)) + (funcall (value-combine-function a) (slot-value b (slot-definition-name slot)) + (slot-value a (slot-definition-name slot))))))) b) + +(defmethod copy-slots-to-class ((a event) (b event) &key) + (loop for slot in (class-direct-slots (class-of a)) + do (unless (event-has-slot b slot) + (add-slot-to-class (class-name (class-of b)) (slot-definition-name slot) + :readers (slot-definition-readers slot) + :writers (slot-definition-writers slot))))) + +;; will be an accumulator ... +(defclass incomplete-event (event) ()) + +;; copied ... +(defun interleave (l1 l2) + (cond ((and (eql l1 nil) (eql l2 nil)) nil) ;; rule #1 + ((eql l1 nil) (cons nil (interleave l2 l1))) ;; rule #2, current value is nil + (t (cons (first l1) (interleave l2 (rest l1)))))) ;; rule #3 in all other cases + +;; helper to create +(defun create-accessor (class-name accessor-name param-name) + `(defgeneric ,accessor-name (,class-name) + (:method ((,class-name ,class-name)) + (let ((val (slot-value ,class-name ',param-name))) + (if (typep val 'param-mod-object) + (evaluate val) + val))))) + +(defun get-param-definition (slot) + (list + (sb-mop::slot-definition-name slot) + (car (sb-mop::slot-definition-readers slot)) + (sb-mop::slot-definition-initform slot))) + +(defun get-param-definitions (event-class) + (if (member (find-class 'event) (sb-mop::class-direct-superclasses event-class)) + (mapcar #'get-param-definition (sb-mop::class-direct-slots event-class)) + (mapcan #'get-param-definitions (sb-mop::class-direct-superclasses event-class)))) + +;; a overwrites b, b (or incomplete) is returned ... +(defmethod combine-single-events ((a event) (b event) &key) + (cond ((events-compatible a b) (overwrite-slots a b)) + ;; merge events into a new incomplete event + (t (let ((new-event (make-instance 'incomplete-event))) + (copy-slots-to-class a new-event) + (copy-slots-to-class b new-event) + (overwrite-slots b new-event) + (overwrite-slots a new-event) + )))) + +;; combining events ... a has precedence +(defmethod combine-events (events-a events-b &key (mode 'append) (filter #'all-p)) + (cond ((eq mode 'append) (append events-a events-b)) + ((eq mode 'zip) (let ((filtered-and-combined + (mapcar #'combine-single-events events-a + (remove-if-not filter events-b))) + (rest (remove-if filter events-b))) + (append filtered-and-combined rest))))) + + +;; creepy macro to faciliate defining events +;; defines the event class, the language constructor, and the +;; value accessor function ... +(defmacro define-event (&key + short-name + long-name + (parent-events nil) + (parameters nil) + (direct-parameters nil) + (handler nil)) + (let* ((class-name (intern (format nil "~A" long-name))) + (keyword-parameters (remove-if #'(lambda (x) (member (car x) direct-parameters)) parameters)) + ;; get parameter definitions from parent classes ... + (parent-parameters (mapcan #'(lambda (cl) + (get-param-definitions (find-class cl))) + parent-events)) + (parent-keyword-parameters (remove-if #'(lambda (x) (member (car x) direct-parameters)) + parent-parameters)) + (parameter-names (mapcar #'car parameters)) + (accessor-names (mapcar #'cadr parameters)) + (keyword-parameter-defaults (mapcar #'caddr keyword-parameters)) + (keyword-parameter-names (mapcar #'car keyword-parameters)) + + (parent-parameter-names (mapcar #'car parent-parameters)) + + (parent-keyword-parameter-defaults (mapcar #'caddr parent-keyword-parameters)) + (parent-keyword-parameter-names (mapcar #'car parent-keyword-parameters)) + + + (keywords (mapcar #'(lambda (x) (intern (format nil "~A" x) "KEYWORD")) parameter-names)) + (parent-keywords (mapcar #'(lambda (x) (intern (format nil "~A" x) "KEYWORD")) + parent-parameter-names)) + (keyword-pairs (interleave keywords parameter-names)) + (parent-keyword-pairs (interleave parent-keywords parent-parameter-names)) + (class-name-list (make-list (length parameter-names) :initial-element class-name))) + `(progn + ;; define the base class + (defclass ,class-name ,parent-events ()) + ;; add the parameter slots with accessor + (loop for param in ',parameters + for i from 0 to (length ',parameters) + do (let* ((slot-name (car param)) + (slot-keyword (intern (format nil "~A" slot-name) "KEYWORD")) + (slot-initform (caddr param)) + (accessor-name (cadr param))) + (add-slot-to-class ',class-name + slot-name + :accessors (list accessor-name) + :initargs (list slot-keyword) + :initform slot-initform))) + ;; define the constructor function + (defun ,short-name (,@direct-parameters + &key + ,@(mapcar #'list keyword-parameter-names + keyword-parameter-defaults) + ,@(mapcar #'list parent-keyword-parameter-names + parent-keyword-parameter-defaults) + (tags nil) + (combi-fun #'replace-value)) + (make-instance ',class-name + ,(intern "TAGS" "KEYWORD") tags + ,(intern "COMBI-FUN" "KEYWORD") combi-fun + ,@keyword-pairs + ,@parent-keyword-pairs + )) + ;; oh my ... now this is creepy ... + ;; re-define the getters so that the value is calculated if + ;; it's a modifier object instead of a plain value ... + ,@(mapcar #'create-accessor class-name-list accessor-names parameter-names) + ;; tbd -- directly include handler ... + ))) + + + + + + diff --git a/megra-event-definitions.lisp b/megra-event-definitions.lisp new file mode 100644 index 0000000..3aa5ab3 --- /dev/null +++ b/megra-event-definitions.lisp @@ -0,0 +1,202 @@ +;; EVENT DEFINITIONS ... +;; those "abstract" events provide the building blocks +;; for the events that will later on produce a sound +(define-event + :long-name pitch-event + :short-name pitch + :parent-events (event) + :parameters ((pitch event-pitch 43)) + :direct-parameters (pitch)) + +(define-event + :long-name message-event + :short-name message + :parent-events (event) + :parameters ((msg event-message)) + :direct-parameters (msg)) + +(define-event + :long-name duration-event + :short-name dur + :parent-events (event) + :parameters ((dur event-duration 512)) + :direct-parameters (dur)) + +(define-event + :long-name level-event + :short-name lvl + :parent-events (event) + :parameters ((lvl event-level 0.3)) + :direct-parameters (lvl)) + +(define-event + :long-name instrument-event + :short-name inst + :parent-events (event) + :parameters ((inst event-instrument)) + :direct-parameters (inst)) + +(define-event + :long-name tuned-instrument-event + :short-name tuned-instrument-event + :parent-events (pitch-event level-event instrument-event duration-event)) + +(define-event + :long-name midi-event + :short-name mid + :parent-events (tuned-instrument-event) + :direct-parameters (pitch)) + +;; ready for ambisonics +;; pos is the simple stereo position, +;; azimuth, elevation and distance the ambisonics parameters +(define-event + :long-name spatial-event + :short-name pos + :parent-events (event) + :parameters ((pos event-position 0.0) + (azi event-azimuth 0.0) + (ele event-elevation 0.0) + (dist event-distance 0.0)) + :direct-parameters (pos)) + +;; additional constructor for convenience reasons ... +;; tbd - alias macro +(defun ambi-pos (azi ele &key (dist 0) (tags nil) (combi-fun #'replace-value)) + (make-instance 'spatial-event :pos 0.0 :azi azi :ele ele + :dist dist :tags tags :ambi-p t :combi-fun combi-fun)) + +(define-event + :long-name rate-event + :short-name rate + :parent-events (event) + :parameters ((rate event-rate 1.0)) + :direct-parameters (rate)) + +(define-event + :long-name attack-event + :short-name atk + :parent-events (event) + :parameters ((atk event-attack 5)) + :direct-parameters (atk)) + +(define-event + :long-name release-event + :short-name rel + :parent-events (event) + :parameters ((rel event-release 5)) + :direct-parameters (rel)) + +(define-event + :long-name start-event + :short-name start + :parent-events (event) + :parameters ((start event-start 0.0)) + :direct-parameters (start)) + +(define-event + :long-name reverb-event + :short-name rev + :parent-events (event) + :parameters ((rev event-reverb)) + :direct-parameters (rev)) + +(define-event + :long-name filter-hp-event + :short-name filter-hp + :parent-events (event) + :parameters ((hp-freq event-hp-freq 10) (hp-q event-hp-q 0.4)) + :direct-parameters (hp-freq)) + +(define-event + :long-name filter-lp-event + :short-name filter-lp + :parent-events (event) + :parameters ((lp-freq event-lp-freq 19000) + (lp-q event-lp-q 0.4) + (lp-dist event-lp-dist 0.0)) + :direct-parameters (lp-freq)) + +(define-event + :long-name filter-peak-event + :short-name filter-peak + :parent-events (event) + :parameters ((pf-freq event-fp-freq 1000) + (pf-q event-pf-q 10) + (pf-gain event-pf-gain 0.0)) + :direct-parameters (pf-freq)) + +(define-event + :long-name grain-event + :short-name grain + :parent-events (level-event + duration-event + spatial-event + start-event + rate-event + attack-event + release-event + filter-hp-event + filter-lp-event + filter-peak-event + reverb-event) + :parameters ((sample-folder event-sample-folder) + (sample-file event-sample-file) + (sample-location event-sample-location)) + :direct-parameters (sample-folder sample-file)) + +;; additional method after grain event initialization ... +(defmethod initialize-instance :after ((g grain-event) &key) + (setf (event-sample-location g) + (concatenate 'string *sample-root* + (event-sample-folder g) "/" (event-sample-file g) ".wav"))) + +(define-event + :long-name frequency-range-event + :short-name freq-range + :parent-events (event) + :parameters ((freq-min event-freq-min 410) + (freq-max event-freq-max 420)) + :direct-parameters (freq-min freq-max)) + +(define-event + :long-name gendy-event + :short-name gendy + :parent-events (level-event + duration-event + filter-lp-event + frequency-range-event + attack-event + release-event + reverb-event + spatial-event) + :parameters ((adstr event-amp-distr 1) + (ddstr event-dur-distr 1) + (adstr-par event-amp-distr-param 1) + (ddstr-par event-dur-distr-param 1) + (a-scl event-amp-scale 0.01) + (d-scl event-dur-scale 0.01)) + :direct-parameters (freq-min freq-max)) + +(define-event + :long-name control-event + :short-name ctrl + :parent-events (event) + :parameters ((control-function event-control-function)) + :direct-parameters (control-function)) + +;; the transition between events is just a different type of event, +;; if you ask me ... +(define-event + :long-name transition + :short-name transition + :parent-events (event) + :parameters ((dur transition-duration)) + :direct-parameters (dur)) + + + + + + + diff --git a/megra-events.lisp b/megra-events.lisp deleted file mode 100644 index dfda968..0000000 --- a/megra-events.lisp +++ /dev/null @@ -1,298 +0,0 @@ -;; stateful parameter modifier ... (yes, really ...) -;; every one of those needs an "evaluate" function ... -(defclass param-mod-object () - ((step :accessor pmod-step :initform 0) - (time :accessor pmod-time :initform 0) - (current-value :accessor pmod-current-value :initarg :current-value))) - -;; before each evaluation, set time ... -(defmethod evaluate :before ((p param-mod-object) &key) - (setf (pmod-time p) (incudine:now))) - -;; after each evaluation, increment step counter -(defmethod evaluate :after ((p param-mod-object) &key) - (incf (pmod-step p))) - -;; this one is stateless, not dependent on current value ... -(defclass param-oscillate-between (param-mod-object)) - -(defmethod evaluate ((o param-oscillate-between)) - (let* ((osc-range (- upper lower)) - (degree-increment (/ 360 cycle o)) - (degree (mod (* degree-increment (mod step cycle)) 360)) - (abs-sin (abs (sin (radians degree))))) - (+ lower (* abs-sin osc-range)))) - -(defclass generic-brownian-motion () - (upper-boundary :accessor ubound :initarg :upper-boundary) - (lower-boundary :accessor lbound :initarg :lower-boundary) - (step-size :accessor step-size :initarg :step-size) - (is-bounded :accessor is-bounded :initarg :is-bounded) - (is-wrapped :accessor is-wrapped :initarg :is-wrapped)) - -;; cap or wrap ... -(defmethod cap ((b generic-brownian-motion) value &key) - (cond ((is-bounded b) - (cond ((< value (lbound b)) (lbound b)) - ((> value (ubound b)) (ubound b)) - (t value))) - ((is-wrapped b) - (cond ((< value (lbound b)) (ubound b)) - ((> value (ubound b)) (lbound b)) - (t value))) - (t value))) - -;; this one is stateful ... -(defclass param-brownian-motion (generic-brownian-motion param-mod-object)) - -(defmethod evaluate ((b param-brownian-motion)) - (let* ((new-value (cap b (+ (pmod-current-value b) - (* (nth (random 2) '(-1 1)) (step-size b)))))) - ;; stateful - don't forget to set value ! - (setf (pmod-current-value b) new-value) - ;; return new value - new-value)) - -;; the atomic units of music - event and transition ... -(defclass event () - ((source :accessor event-source) - (tags :accessor event-tags :initarg :tags) - (backends :accessor event-backends :initarg :backends :initform `(,*default-dsp-backend*)) - (value-combine-function :accessor value-combine-function - :initarg :combi-fun :initform #'replace-value))) - -;; the default value combination function -(defun replace-value (b a) a) - -;; will be the accumulator ... -(defclass incomplete-event (event) ()) - -;; those "abstract" events provide the building blocks -;; for the events that will later on produce a sound -(defclass string-event (event) - ((msg :accessor event-message :initarg :msg))) - -(defclass pitch-event (event) - ((pitch :initarg :pitch))) - - -(defun add-slot-to-class (class name &key (initform nil) accessors readers writers - initargs (initfunction (constantly nil))) - (check-type class symbol) - (let ((new-slots (list (list :name name - :readers (union accessors readers) - :writers (union writers - (mapcar #'(lambda (x) - (list 'setf x)) - accessors) - :test #'equal) - :initform initform - :initargs initargs - :initfunction initfunction)))) - (dolist (slot-defn (class-direct-slots (find-class class))) - (push (direct-slot-defn->initarg slot-defn) - new-slots)) - (ensure-class class :direct-slots new-slots))) - -;; macro to faciliate defining events -;; defines the event class, the language constructor, and the -;; value accessor function ... -(defmacro define-event (event-long-name - event-short-name - parent-events - parameters) - (let* ((class-name (intern (format nil "~a-event" event-long-name) 'megra)) - (constructor-name (intern (format nil "~a" event-short-name) 'megra)) - ) - - - - `(progn - (defclass ,class-name ,parent-events) - (loop for param in parameters - do ((let* (()) - (add-slot-to-class ) - - ) - (defgeneric name-access (foo) - (:method ((foo foo)) - (format t "~&Getting name.~%") - (slot-value foo 'name))) - - (defgeneric (setf name-access) (name foo) - (:method (name (foo foo)) - (format t "~&Setting a new name.~%") - (setf (slot-value foo 'name) name)) - - )) - - (defun lvl (lvl &key (tags nil) (combi-fun #'replace-value)) - (make-instance 'level-event :lvl lvl :tags tags :combi-fun combi-fun)) - - - )) - ) - - -(defmethod event-get-pitch ((e event)) - - (if (typep (slot-value e 'pitch) 'function) - (funcall (slot-value e 'pitch) ) - (slot-value e 'pitch) - ) - ) - -(define-event 'duration 'dur '((duration dur) ) ) - -(defclass duration-event (event) - ((dur :accessor event-duration :initarg :dur))) - -(defclass instrument-event (event) - ((inst :accessor event-instrument :initarg :inst))) - -(defclass rate-event (event) - ((rate :accessor event-rate :initarg :rate))) - -(defclass attack-event (event) - ((atk :accessor event-attack :initarg :atk))) - -(defclass release-event (event) - ((rel :accessor event-release :initarg :rel))) - -(defclass start-event (event) - ((start :accessor event-start :initarg :start))) - -(defclass filter-hp-event (event) - ((hp-freq :accessor event-hp-freq :initarg :hp-freq) - (hp-q :accessor event-hp-q :initarg :hp-q))) - -(defclass filter-peak-event (event) - ((pf-freq :accessor event-pf-freq :initarg :pf-freq) - (pf-q :accessor event-pf-q :initarg :pf-q) - (pf-gain :accessor event-pf-gain :initarg :pf-gain))) - -(defclass filter-lp-event (event) - ((lp-freq :accessor event-lp-freq :initarg :lp-freq) - (lp-q :accessor event-lp-q :initarg :lp-q) - (lp-dist :accessor event-lp-dist :initarg :lp-dist))) - -(defclass reverb-event (event) - ((rev :accessor event-reverb :initarg :rev))) - -;; ready for ambisonics -;; pos is the simple stereo position, -;; azimuth, elevation and distance the ambisonics parameters -(defclass spatial-event (event) - ((pos :accessor event-position :initarg :pos) - (azi :accessor event-azimuth :initarg :azi) - (ele :accessor event-elevation :initarg :ele) - (dist :accessor event-distance :initarg :dist) - (ambi-p :accessor event-ambi-p :initarg :ambi-p :initform nil))) - -(defclass tuned-instrument-event (pitch-event instrument-event level-event duration-event) ()) - -(defclass midi-event (tuned-instrument-event) ()) - -(defclass grain-event (level-event duration-event spatial-event start-event rate-event - attack-event release-event filter-hp-event filter-lp-event - filter-peak-event reverb-event) - ((sample-folder :accessor sample-folder :initarg :sample-folder) - (sample-file :accessor sample-file :initarg :sample-file) - (sample-location :accessor sample-location))) - -;;(in-package :megra) -(defclass gendy-event (level-event duration-event filter-lp-event attack-event - release-event reverb-event spatial-event) - ((adstr :accessor event-amp-distr :initarg :adstr) - (ddstr :accessor event-dur-distr :initarg :ddstr) - (adstr-par :accessor event-amp-distr-param :initarg :adstr-par) - (ddstr-par :accessor event-dur-distr-param :initarg :ddstr-par) - (freq-min :accessor event-freq-min :initarg :freq-min) - (freq-max :accessor event-freq-max :initarg :freq-max) - (a-scl :accessor event-amp-scale :initarg :a-scl) - (d-scl :accessor event-dur-scale :initarg :d-scl))) - -(defmethod initialize-instance :after ((g grain-event) &key) - (setf (sample-location g) (concatenate 'string *sample-root* - (sample-folder g) "/" (sample-file g) ".wav"))) - -;; special event that contains a control function to modify things or start/stop things ... -(defclass control-event (event) - ((control-function :accessor control-function :initarg :control-function))) - -;; slots are equal if their name is equal ... period. -(defun slot-eq (a b) - (eq (slot-definition-name a) (slot-definition-name b))) - -(defmethod event-has-slot ((e event) slot &key) - (member slot (class-slots (class-of e)) :test 'slot-eq)) - -(defmethod event-has-slot-by-name ((e event) slot-name &key) - (member slot-name (mapcar #'slot-definition-name (class-slots (class-of e))))) - -;; not quite sure why this works, but it does ... -;; http://stackoverflow.com/questions/17002816/lisp-clos-adding-a-slot-to-the-process-class -(defun direct-slot-defn->initarg (slot-defn) - (list :name (slot-definition-name slot-defn) - :readers (slot-definition-readers slot-defn) - :writers (slot-definition-writers slot-defn) - :initform (slot-definition-initform slot-defn) - :initargs (slot-definition-initargs slot-defn) - :initfunction (slot-definition-initfunction slot-defn))) - - -;; check if event b has all slots that event a has -(defmethod events-compatible ((a event) (b event) &key) - (subsetp (class-slots (class-of a)) (class-slots (class-of b)) :test 'slot-eq)) - -;; the slots of the basic event class should of course not be overwritten ... -;; manual makeshift solution -(defparameter *protected-slots* '(source value-combine-function tags backends)) - -(defmethod overwrite-slots ((a event) (b event) &key) - (loop for slot in (class-slots (class-of a)) - do (when (slot-boundp-using-class (class-of b) b slot) - (unless (member (slot-definition-name slot) *protected-slots*) - (setf (slot-value b (slot-definition-name slot)) - (funcall (value-combine-function a) (slot-value b (slot-definition-name slot)) - (slot-value a (slot-definition-name slot))))))) b) - -(defmethod copy-slots-to-class ((a event) (b event) &key) - (loop for slot in (class-direct-slots (class-of a)) - do (unless (event-has-slot b slot) - (add-slot-to-class (class-name (class-of b)) (slot-definition-name slot) - :readers (slot-definition-readers slot) - :writers (slot-definition-writers slot))))) - -;; a overwrites b, b (or incomplete) is returned ... -(defmethod combine-single-events ((a event) (b event) &key) - (cond ((events-compatible a b) (overwrite-slots a b)) - ;; merge events into a new incomplete event - (t (let ((new-event (make-instance 'incomplete-event))) - (copy-slots-to-class a new-event) - (copy-slots-to-class b new-event) - (overwrite-slots b new-event) - (overwrite-slots a new-event) - )))) - -;; combining events ... a has precedence -(defmethod combine-events (events-a events-b &key (mode 'append) (filter #'all-p)) - (cond ((eq mode 'append) (append events-a events-b)) - ((eq mode 'zip) (let ((filtered-and-combined - (mapcar #'combine-single-events events-a - (remove-if-not filter events-b))) - (rest (remove-if filter events-b))) - (append filtered-and-combined rest))))) - -;; it might seem weird to treat the transition as an event, but it makes lots -;; of things easier, and musically it's sound to treat the space between events -;; as a special type of event ... i think ... -(defclass transition (event) - ((dur :accessor transition-duration :initarg :dur))) - - - - - - - diff --git a/megra-object-handling.lisp b/megra-object-handling.lisp new file mode 100644 index 0000000..d43b8eb --- /dev/null +++ b/megra-object-handling.lisp @@ -0,0 +1,40 @@ +;;(require 'closer-mop) + +;; the slots of the basic event class should of course not be overwritten ... +;; manual makeshift solution +(defparameter *protected-slots* '(source value-combine-function tags backends)) + +;; GENERIC + +;; slots are equal if their name is equal ... period. +(defun slot-eq (a b) + (eq (slot-definition-name a) (slot-definition-name b))) + +;; not quite sure why this works, but it does ... +;; http://stackoverflow.com/questions/17002816/lisp-clos-adding-a-slot-to-the-process-class +(defun direct-slot-defn->initarg (slot-defn) + (list :name (sb-mop::slot-definition-name slot-defn) + :readers (sb-mop::slot-definition-readers slot-defn) + :writers (sb-mop::slot-definition-writers slot-defn) + :initform (sb-mop::slot-definition-initform slot-defn) + :initargs (sb-mop::slot-definition-initargs slot-defn) + :initfunction (sb-mop::slot-definition-initfunction slot-defn))) + +(defun add-slot-to-class (class name &key (initform nil) accessors readers writers + initargs (initfunction (constantly nil))) + (check-type class symbol) + (let ((new-slots (list (list :name name + :readers (union accessors readers) + :writers (union writers + (mapcar #'(lambda (x) + (list 'setf x)) + accessors) + :test #'equal) + :initform initform + :initargs initargs + :initfunction initfunction)))) + (dolist (slot-defn (sb-mop::class-direct-slots (find-class class))) + (push (direct-slot-defn->initarg slot-defn) + new-slots)) + (sb-mop::ensure-class class :direct-slots new-slots))) + diff --git a/megra-package.lisp b/megra-package.lisp index c987bef..3c0e761 100644 --- a/megra-package.lisp +++ b/megra-package.lisp @@ -56,7 +56,9 @@ (defparameter *global-midi-delay* 0.12) ;; load the megra stuff except for dsp ... -(load "megra-events") +(load "megra-object-handling") +(load "megra-event-base") +(load "megra-event-definitions") (load "megra-structures") (load "megra-event-processors") (load "megra-dispatchers") diff --git a/megra-start.lisp b/megra-start.lisp index 095626d..4226e6e 100644 --- a/megra-start.lisp +++ b/megra-start.lisp @@ -1,15 +1,6 @@ (require 'cm) (in-package :cm) - - -(defmacro fade) - - - - - - ;; initialize -- seems like it has to be like this ... (progn (incudine:set-rt-block-size 128)