From 7b6e2ff3388c12544fbd0ef3623f2724e40d20b9 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Thu, 15 Jun 2023 22:03:10 +0200 Subject: Get rid of old MIDI control stuff --- guile/starlet/midi-control/base.scm | 303 -------------------- guile/starlet/midi-control/button-utils.scm | 104 ------- guile/starlet/midi-control/faders.scm | 410 ---------------------------- 3 files changed, 817 deletions(-) delete mode 100644 guile/starlet/midi-control/base.scm delete mode 100644 guile/starlet/midi-control/button-utils.scm delete mode 100644 guile/starlet/midi-control/faders.scm diff --git a/guile/starlet/midi-control/base.scm b/guile/starlet/midi-control/base.scm deleted file mode 100644 index 7b28ea7..0000000 --- a/guile/starlet/midi-control/base.scm +++ /dev/null @@ -1,303 +0,0 @@ -;; -;; starlet/midi-control/base.scm -;; -;; Copyright © 2020-2021 Thomas White -;; -;; This file is part of Starlet. -;; -;; Starlet 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 . -;; -(define-module (starlet midi-control base) - #:use-module (oop goops) - #:use-module (ice-9 atomic) - #:use-module (ice-9 threads) - #:use-module (ice-9 exceptions) - #:use-module (ice-9 binary-ports) - #:use-module (srfi srfi-1) - #:export (make-midi-controller - find-midi-device - get-cc-value - ccval->percent - percent->ccval - send-note-on - send-note-off - register-midi-note-callback! - register-midi-cc-callback! - remove-midi-callback! - get-parameter-controller - get-controller-sensitivity - set-parameter-controller! - make-sensitivity-knob)) - - -(define-class () - (cc-values - #:init-form (make-vector 128 #f) - #:getter get-cc-values) - - (channel - #:init-form (error "MIDI channel must be specified for controller") - #:init-keyword #:channel - #:getter get-channel) - - (callbacks - #:init-form (make-atomic-box '()) - #:getter get-callbacks) - - (send-queue - #:init-form (make-atomic-box '()) - #:getter get-send-queue) - - (parameter-controller - #:init-value #f - #:getter get-parameter-controller - #:setter set-parameter-controller!) - - (sensitivity - #:init-value 3 - #:getter get-controller-sensitivity - #:setter set-controller-sensitivity!)) - - -(define-class () - (type - #:init-keyword #:type - #:getter get-type) - - (note-or-cc-number - #:init-keyword #:note-or-cc-number - #:getter get-note-or-cc-number) - - (callback - #:init-keyword #:func - #:getter get-callback-func)) - - -(define (find-cc-callbacks controller cc-number) - (filter (lambda (a) - (and (eq? cc-number (get-note-or-cc-number a)) - (eq? 'cc (get-type a)))) - (atomic-box-ref (get-callbacks controller)))) - - -(define (find-note-callbacks controller note-number) - (filter (lambda (a) - (and (eq? note-number (get-note-or-cc-number a)) - (eq? 'note (get-type a)))) - (atomic-box-ref (get-callbacks controller)))) - - -(define (remove-midi-callback! controller callback) - (when controller - (atomic-box-set! (get-callbacks controller) - (delq callback - (atomic-box-ref (get-callbacks controller)))))) - - -(define (register-midi-callback! controller - type - note-or-cc-number - func) - (let ((new-callback (make - #:type type - #:note-or-cc-number note-or-cc-number - #:func func))) - (let ((callback-list-box (get-callbacks controller))) - (atomic-box-set! callback-list-box - (cons new-callback - (atomic-box-ref callback-list-box)))) - new-callback)) - - -(define* (register-midi-note-callback! - controller - #:key (note-number 1) (func #f) (unique #t)) - (when controller - (when unique - (for-each (lambda (callback) - (remove-midi-callback! controller callback)) - (find-note-callbacks - controller - note-number))) - (register-midi-callback! controller 'note note-number func))) - - -(define* (register-midi-cc-callback! - controller - #:key (cc-number 1) (func #f) (unique #t)) - (when controller - (when unique - (for-each (lambda (callback) - (remove-midi-callback! controller callback)) - (find-cc-callbacks - controller - cc-number))) - (register-midi-callback! controller 'cc cc-number func))) - - -(define enqueue-midi-bytes! - (lambda (controller . bytes) - (let* ((send-queue (get-send-queue controller)) - (old-queue (atomic-box-ref send-queue)) - (new-queue (append old-queue bytes))) - (unless (eq? (atomic-box-compare-and-swap! send-queue - old-queue - new-queue) - old-queue) - (apply enqueue-midi-bytes! (cons controller bytes)))))) - - -(define* (send-note-on controller note) - (when (and controller note) - (enqueue-midi-bytes! controller - (+ #b10010000 (get-channel controller)) - note - 127))) - - -(define* (send-note-off controller note) - (when (and controller note) - (enqueue-midi-bytes! controller - (+ #b10000000 (get-channel controller)) - note - 0))) - - -(define (all-notes-off! controller) - (for-each (lambda (l) - (enqueue-midi-bytes! controller - (+ #b10000000 (get-channel controller)) - l - 0)) - (iota 128))) - - -(define (check-cc-callbacks controller cc-number old-val new-val) - (for-each (lambda (a) ((get-callback-func a) old-val new-val)) - (find-cc-callbacks controller cc-number))) - - -(define (handle-cc-change! controller cc-number value) - (let* ((ccvals (get-cc-values controller)) - (old-value (vector-ref ccvals cc-number))) - (vector-set! ccvals cc-number value) - (check-cc-callbacks controller cc-number old-value value))) - - -(define* (get-cc-value controller cc-number) - (if controller - (vector-ref (get-cc-values controller) cc-number) - #f)) - - -(define (check-note-callbacks controller note-number) - (for-each (lambda (a) ((get-callback-func a))) - (find-note-callbacks controller note-number))) - - -(define (ccval->percent n) - (/ (* n 100) 127)) - - -(define (percent->ccval n) - (inexact->exact (round (/ (* n 127) 100)))) - - -(define (make-midi-controller-real device-name channel) - (let ((controller (make - #:channel channel))) - (let ((midi-port (open-file device-name "r+0b"))) - - ;; Read thread - (begin-thread - (with-exception-handler - (lambda (exn) - (backtrace) - (raise-exception exn)) - (lambda () - (let again () - - (let* ((status-byte (get-u8 midi-port)) - (channel (bit-extract status-byte 0 4)) - (command (bit-extract status-byte 4 8))) - - (case command - - ;; Note on - ((9) (let* ((note (get-u8 midi-port)) - (vel (get-u8 midi-port))) - (check-note-callbacks controller note))) - - ;; Control value - ((11) (let* ((cc-number (get-u8 midi-port)) - (value (get-u8 midi-port))) - (handle-cc-change! controller - cc-number - value)))) - - (yield) - (again)))))) - - ;; Write thread - (begin-thread - (let again () - (let ((bytes-to-send - (atomic-box-swap! - (get-send-queue controller) - '()))) - (for-each (lambda (a) - (put-u8 midi-port a) - (usleep 1)) - bytes-to-send) - (usleep 1000) - (again)))) - - (all-notes-off! controller) - controller))) - - -(define* (make-midi-controller device-name channel) - (with-exception-handler - - (lambda (exn) - (format #t "Couldn't start MIDI ~a\n" - (exception-irritants exn)) - #f) - - (lambda () - (make-midi-controller-real device-name channel)) - - #:unwind? #t)) - - -(define (set-sensitivity controller prev new) - (set-controller-sensitivity! - controller - (min 5 (max 1 (+ (if (= new 127) -1 1) - (get-controller-sensitivity controller)))))) - - -(define (make-sensitivity-knob controller cc-num) - (register-midi-callback! - controller 'cc cc-num - (lambda (prev new) - (set-sensitivity controller prev new)))) - - -(define (find-midi-device) - (find file-exists? - (list "/dev/snd/midiC0D0" - "/dev/snd/midiC1D0" - "/dev/snd/midiC2D0" - "/dev/snd/midiC3D0"))) diff --git a/guile/starlet/midi-control/button-utils.scm b/guile/starlet/midi-control/button-utils.scm deleted file mode 100644 index 0786cab..0000000 --- a/guile/starlet/midi-control/button-utils.scm +++ /dev/null @@ -1,104 +0,0 @@ -;; -;; starlet/midi-control/button-utils.scm -;; -;; Copyright © 2020-2021 Thomas White -;; -;; This file is part of Starlet. -;; -;; Starlet 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 . -;; -(define-module (starlet midi-control button-utils) - #:use-module (starlet midi-control base) - #:use-module (starlet state) - #:use-module (starlet playback) - #:use-module (starlet utils) - #:export (make-go-button - make-stop-button - make-back-button - select-on-button)) - - -(define* (make-go-button controller pb button - #:key - (ready-note #f) - (pause-note #f) - (min-time-between-presses 0.2)) - (let ((time-last-press 0)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () - (let ((time-this-press (hirestime))) - (if (> time-this-press (+ time-last-press min-time-between-presses)) - (go! pb) - (display "Too soon after last press!\n")) - (set! time-last-press time-this-press))))) - - (when (or ready-note pause-note) - (let ((state-change-func - (lambda (new-state) - (cond - ((eq? new-state 'pause) - (send-note-on controller pause-note)) - ((eq? new-state 'ready) - (send-note-on controller ready-note)) - ((eq? new-state 'running) - (send-note-on controller ready-note)) - (else - (send-note-off controller ready-note)))))) - (add-hook! - (state-change-hook pb) - state-change-func) - (state-change-func (playback-state pb))))) - - -(define* (make-stop-button controller pb button - #:key - (ready-note #f)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (stop! pb))) - - (when ready-note - (add-hook! - (state-change-hook pb) - (lambda (new-state) - (if (eq? new-state 'running) - (send-note-on controller ready-note) - (send-note-off controller ready-note)))))) - - -(define* (make-back-button controller pb button - #:key - (ready-note #f)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (back! pb))) - - (when ready-note - (send-note-on controller ready-note))) - - -(define* (select-on-button controller button fixture - #:key - (ready-note #f)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (sel fixture))) - - (when ready-note - (send-note-on controller ready-note))) diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm deleted file mode 100644 index aa8aacf..0000000 --- a/guile/starlet/midi-control/faders.scm +++ /dev/null @@ -1,410 +0,0 @@ -;; -;; starlet/midi-control/faders.scm -;; -;; Copyright © 2020-2021 Thomas White -;; -;; This file is part of Starlet. -;; -;; Starlet 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 . -;; -(define-module (starlet midi-control faders) - #:use-module (starlet midi-control base) - #:use-module (starlet state) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:use-module (starlet engine) - #:use-module (starlet utils) - #:use-module (starlet attributes) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (oop goops) - #:export (set-midi-control-map! - fader - jogwheel - state-on-fader)) - - -(define-class () - (callbacks - #:init-keyword #:callbacks - #:getter get-callbacks - #:setter set-callbacks!) - - (control-map - #:init-keyword #:control-map - #:getter get-control-map)) - - -(define-record-type - (make-fader cc attr-name congruent incongruent) - fader-spec? - (cc fader-cc-number) - (attr-name fader-attr-name) - (congruent fader-congruent-note) - (incongruent fader-incongruent-note)) - - -(define-record-type - (make-jogwheel cc attr-name active-note) - jogwheel-spec? - (cc jogwheel-cc-number) - (attr-name jogwheel-attr-name) - (active-note jogwheel-active-note)) - - -(define* (fader cc - attr-name - #:key - (congruent #f) - (incongruent #f)) - (make-fader cc attr-name congruent incongruent)) - - -(define* (jogwheel cc - attr-name - #:key - (active #f)) - (make-jogwheel cc attr-name active)) - - -(define (name-for-fader-state controller cc-number) - (call-with-output-string - (lambda (port) - (format port "faderstate-~a-cc~a" - controller - cc-number)))) - - -(define* (state-on-fader controller - cc-number - state) - (register-state! - (lighting-state - (state-for-each - (lambda (fix attr val) - (at fix attr - (lambda () - - (let ((cc-val (get-cc-value controller cc-number))) - - ;; Fader position known? - (if cc-val - - (if (intensity? attr) - - ;; Intensity parameters get scaled according to the fader - (* 0.01 val (ccval->percent cc-val)) - - ;; Non-intensity parameters just get set in our new state, - ;; but only if the fader is up! - (if (> cc-val 0) - val - 'no-value)) - - ;; Fader position unknown - 'no-value))))) - - state)) - #:unique-name (name-for-fader-state controller cc-number))) - - -(define (current-values fixture-list attr-name) - (map (lambda (fix) - (current-value fix attr-name)) - fixture-list)) - - -(define (fixtures-with-attr fixture-list attr-name) - (let ((attrs (map (cut find-attr <> attr-name) fixture-list))) - (fold (lambda (fix attr old) - (if attr - (cons (cons fix (car old)) - (cons attr (cdr old))) - old)) - (cons '() '()) - fixture-list attrs))) - - -(define (clamp-to-attr-range attr-obj val) - (let ((r (get-attr-range-maybe-colour attr-obj))) - (max (car r) - (min (cadr r) - val)))) - - -(define (attr-scale controller attr) - (let ((sens-level (get-controller-sensitivity controller))) - (cond - ((= sens-level 1) 0.02) - ((= sens-level 2) 0.1) - ((= sens-level 3) 0.5) - ((= sens-level 4) 1.5) - ((= sens-level 5) 3.0)))) - - -(define* (at-midi-jogwheel controller - fixture-list - attr - cc-number - #:key (led #f)) - - (define (ccval->offset controller a) - (if (eq? a 127) - (- (attr-scale controller attr)) - (attr-scale controller attr))) - - (let ((fixtures (car (fixtures-with-attr fixture-list attr)))) - (unless (null? fixtures) - - (when led - (send-note-on controller led)) - - (let ((old-vals (current-values fixtures attr)) - (offset 0)) - (register-midi-cc-callback! - controller - #:cc-number cc-number - #:func (lambda (prev-cc-val new-cc-value) - (set! offset (+ offset (ccval->offset controller - new-cc-value))) - (for-each (lambda (fix old-val) - (let ((attr-obj (find-attr fix attr))) - (when (and attr-obj - (continuous-attribute? attr-obj)) - (set-in-state! programmer-state - fix - attr - (clamp-to-attr-range - attr-obj - (+ old-val offset)) - controller)))) - fixtures old-vals))))))) - - -(define (get-attr-range-maybe-colour attr-obj) - (if (colour-attribute? attr-obj) - '(0 100) - (get-attr-range attr-obj))) - - -(define (fader-congruent vals attrs) - (mean (map (lambda (val attr) - (scale-to-range val - (get-attr-range-maybe-colour attr) - '(0 127))) - vals attrs))) - - -(define (fader-up-gradients initial-vals - attrs - congruent-val) - (map (lambda (initial-val attr) - (let ((attr-max (cadr (get-attr-range-maybe-colour attr)))) - (if (< congruent-val 127) - (/ (- attr-max initial-val) - (- 127 congruent-val)) - 0))) - initial-vals - attrs)) - - -(define (fader-down-gradients initial-vals - attrs - congruent-val) - (map (lambda (initial-val attr) - (let ((attr-min (car (get-attr-range-maybe-colour attr)))) - (if (> congruent-val 0) - (/ (- initial-val attr-min) - congruent-val) - 0))) - - initial-vals - attrs)) - - -(define (apply-fader cc-offset - attr-name - gradients - initial-vals - fixtures - controller) - (for-each (lambda (fix initial-val gradient) - (when (colour-component-id? attr-name) - (set-in-state! - programmer-state - fix - 'colour - (current-value fix 'colour) - controller)) - (set-in-state! programmer-state - fix - attr-name - (+ initial-val - (* gradient cc-offset)) - controller)) - fixtures - initial-vals - gradients)) - - -(define* (at-midi-fader controller - fixture-list - attr-name - cc-number - #:key - (led-incongruent #f) - (led #f)) - - (let ((fixtures-attrs (fixtures-with-attr fixture-list attr-name))) - (unless (null? (car fixtures-attrs)) - (let* ((fixtures (car fixtures-attrs)) - (attrs (cdr fixtures-attrs)) - (initial-vals (current-values fixtures attr-name)) - (congruent-val (fader-congruent initial-vals attrs)) - (up-gradients (fader-up-gradients initial-vals attrs congruent-val)) - (dn-gradients (fader-down-gradients initial-vals attrs congruent-val)) - (cc-val (get-cc-value controller cc-number)) - (congruent (and cc-val (= cc-val congruent-val)))) - - (if congruent - (send-note-on controller led) - (send-note-on controller led-incongruent)) - - (register-midi-cc-callback! - controller - #:cc-number cc-number - #:func (lambda (prev-cc-val new-cc-value) - - (if congruent - - (cond - ((> new-cc-value congruent-val) - (apply-fader (- new-cc-value congruent-val) - attr-name - up-gradients - initial-vals - fixtures - controller)) - ((<= new-cc-value congruent-val) - (apply-fader (- new-cc-value congruent-val) - attr-name - dn-gradients - initial-vals - fixtures - controller))) - - (when (or (and (not prev-cc-val) - (= new-cc-value congruent-val)) - (and prev-cc-val new-cc-value - (in-range congruent-val - prev-cc-val - new-cc-value))) - (set! congruent #t) - (send-note-on controller led))))))))) - - -(define (midi-control-attr controller control-spec fixture-list) - (cond - - ((jogwheel-spec? control-spec) - (at-midi-jogwheel controller - fixture-list - (jogwheel-attr-name control-spec) - (jogwheel-cc-number control-spec) - #:led (jogwheel-active-note control-spec))) - - ((fader-spec? control-spec) - (at-midi-fader controller - fixture-list - (fader-attr-name control-spec) - (fader-cc-number control-spec) - #:led (fader-congruent-note control-spec) - #:led-incongruent (fader-incongruent-note control-spec))))) - - -(define (led-off controller leds) - (cond - ((list? leds) - (for-each (lambda (note) - (send-note-off controller note)) - leds)) - ((number? leds) - (send-note-off controller leds)))) - - -(define (scrub-parameter-controller! controller parameter-controller) - - ;; Remove all the old callbacks - (for-each (lambda (callback) - (remove-midi-callback! controller callback)) - (get-callbacks parameter-controller)) - - ;; Switch off all the old LEDs - (for-each - (lambda (cs) - (cond - ((jogwheel-spec? cs) - (led-off controller (jogwheel-active-note cs))) - ((fader-spec? cs) - (led-off controller (fader-congruent-note cs)) - (led-off controller (fader-incongruent-note cs))))) - (get-control-map parameter-controller))) - - -(define (update-midi-controls controller fixture-list) - - (scrub-parameter-controller! controller - (get-parameter-controller controller)) - - (set-callbacks! - (get-parameter-controller controller) - (map (lambda (control-spec) - (midi-control-attr controller control-spec fixture-list)) - (get-control-map (get-parameter-controller controller))))) - - -(define (set-midi-control-map! controller . new-control-map) - (when controller - (let ((old-parameter-controller (get-parameter-controller controller))) - - ;; Remove the old parameter controller - (when old-parameter-controller - (scrub-parameter-controller! controller old-parameter-controller)) - - (set-parameter-controller! - controller - (make - #:callbacks '() - #:control-map new-control-map)) - - ;; If this is the first time, add the callbacks - (unless old-parameter-controller - - ;; Selection changed - (add-hook! - selection-hook - (lambda (fixture-list) - (update-midi-controls controller fixture-list))) - - ;; Value changed - (add-update-hook! programmer-state - (lambda (source) - (unless (eq? source controller) - (update-midi-controls controller (get-selection)))))) - - ;; If there is a selection, run the callback now - (let ((current-selection (get-selection))) - (when current-selection - (update-midi-controls controller current-selection)))))) -- cgit v1.2.3