diff options
Diffstat (limited to 'guile')
36 files changed, 2843 insertions, 2224 deletions
diff --git a/guile/starlet/attributes.scm b/guile/starlet/attributes.scm new file mode 100644 index 0000000..e139040 --- /dev/null +++ b/guile/starlet/attributes.scm @@ -0,0 +1,104 @@ +;; +;; starlet/attributes.scm +;; +;; Copyright © 2022-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet attributes) + #:use-module (oop goops) + #:export (<starlet-attribute> + make-attribute + attribute? + intensity? + canonical-name + friendly)) + + +(define-class <starlet-attribute> (<object>) + (canonical-name + #:init-keyword #:name + #:getter canonical-name) + (friendly + #:init-keyword #:friendly + #:getter friendly)) + +(define (make-attribute canonical-name friendly) + (make <starlet-attribute> + #:name canonical-name + #:friendly friendly)) + +(define (attribute? a) + (is-a? a <starlet-attribute>)) + +(define-method (write (attribute <starlet-attribute>) port) + (write + (canonical-name attribute) + port)) + +(define-method (canonical-name whatever) + whatever) + + +(define-syntax define-attribute + (syntax-rules () + ((_ name friendly-name) + (define-public name (make-attribute (quote name) friendly-name))))) + + +;; The standard attribute names +(define-attribute intensity "Intensity (percentage of brightest)") +(define-attribute colour "Colour (colour object)") +(define-attribute colour-temperature "Colour temperature (K)") +(define-attribute strobe "Strobe active (boolean)") +(define-attribute strobe-frequency "Strobe rate (Hz)") +(define-attribute pan "Moving head pan angle (degrees +/- from home)") +(define-attribute tilt "Moving head tilt angle (degrees +/- from home)") +(define-attribute prism "Prism active (boolean)") +(define-attribute prism-rotation-speed "Prism rotation speed (+/- percentage of fastest, clockwise)") +(define-attribute frost "Frost active (percentage of maximum frost)") +(define-attribute hotspot "Hot spot (percentage of maximum peakiness)") +(define-attribute iris "Iris (percentage of maximum tightness (perhaps completely closed)") +(define-attribute zoom "Zoom (percentage of tightest zoom)") +(define-attribute focus "Focus (percentage of nearest focus)") +(define-attribute barndoor-all-rotation "Rotation of all barndoors together (degrees +/- from home)") +(define-attribute barndoor1 "Barndoor 1 position (percentage of fully in position)") +(define-attribute barndoor2 "Barndoor 2 position (percentage of fully in position)") +(define-attribute barndoor3 "Barndoor 3 position (percentage of fully in position)") +(define-attribute barndoor4 "Barndoor 4 position (percentage of fully in position)") +(define-attribute barndoor1-rotation "Barndoor 1 rotation (degrees +/- from home)") +(define-attribute barndoor2-rotation "Barndoor 2 rotation (degrees +/- from home)") +(define-attribute barndoor3-rotation "Barndoor 3 rotation (degrees +/- from home)") +(define-attribute barndoor4-rotation "Barndoor 4 rotation (degrees +/- from home)") +(define-attribute beamtype "Beam type") +(define-attribute colwheel "Colour wheel selection (#f or gel name)") +(define-attribute gobo "Gobo selection (#f or gobo name)") +(define-attribute gobo-shift "Fine position of gobo (percentage of maximum shift)") +(define-attribute animation-wheel "Animation wheel active (boolean)") +(define-attribute animation-wheel-position "Animation wheel position (-100 to 100, 0=central)") +(define-attribute animation-wheel-speed "Animation wheel rotation speed and direction (+/- percentage of fastest, clockwise)") +(define-attribute rotating-gobo "Rotating gobo selection (#f or gobo name)") +(define-attribute rotating-gobo-speed "Gobo rotation speed (+/- percentage of maximum speed, clockwise)") +(define-attribute white-weirdness "Weirdness of white (percentage of maximum weirdness)") + +;; Duplicate names for convenience... +(define-public color colour) +(define-public color-temperature colour-temperature) + + +(define (intensity? a) + (eq? intensity a)) + diff --git a/guile/starlet/clock.scm b/guile/starlet/clock.scm index c139d66..2e6e2ff 100644 --- a/guile/starlet/clock.scm +++ b/guile/starlet/clock.scm @@ -92,8 +92,10 @@ (define (clock-expired? clock) - (> (elapsed-time clock) - (expiration-time clock))) + (and + clock + (> (elapsed-time clock) + (expiration-time clock)))) (define-method (elapsed-time (clock <starlet-clock>)) diff --git a/guile/starlet/colours.scm b/guile/starlet/colours.scm index c7d1de0..2162322 100644 --- a/guile/starlet/colours.scm +++ b/guile/starlet/colours.scm @@ -23,10 +23,11 @@ #:use-module (ice-9 exceptions) #:export (<colour> colour? - make-colour-cmy - make-colour-rgb + cmy + rgb colour-as-cmy colour-as-rgb + colour-as-rgbw cyan magenta @@ -36,13 +37,7 @@ blue interpolate-colour - white - - <colour-component-id> - colour-component-id? - colour-component-id - get-colour-component - extract-colour-component)) + white)) (define-class <colour> (<object>) @@ -74,29 +69,31 @@ (colour-type col) (colour-value col))) +(define (three-sf n) + (/ (round (* (exact->inexact n) 10)) 10)) (define-method (write (col <colour>) port) (let ((cmy (colour-as-cmy col))) - (format port "(make-colour-cmy ~a ~a ~a)" - (cyan cmy) - (magenta cmy) - (yellow cmy)))) + (format port "(cmy ~a ~a ~a)" + (three-sf (cyan cmy)) + (three-sf (magenta cmy)) + (three-sf (yellow cmy))))) -(define (make-colour-cmy c m y) +(define (cmy c m y) (make <colour> #:type 'cmy #:value (list c m y))) -(define (make-colour-rgb r g b) +(define (rgb r g b) (make <colour> #:type 'rgb #:value (list r g b))) (define white - (make-colour-cmy 0 0 0)) + (cmy 0 0 0)) (define (colour-as-rgb col) @@ -117,6 +114,15 @@ (make-exception-with-irritants (colour-type col)))))))) +(define (colour-as-rgbw col) + (let ((rgb (colour-as-rgb col))) + (let ((w (apply min rgb))) + (list (- (red rgb) w) + (- (green rgb) w) + (- (blue rgb) w) + w)))) + + (define (colour-as-cmy col) (let ((val (colour-value col))) (case (colour-type col) @@ -138,7 +144,7 @@ (define (interpolate-cmy a b frac) (let ((cmy1 (colour-as-cmy a)) (cmy2 (colour-as-cmy b))) - (make-colour-cmy + (cmy (+ (cyan cmy1) (* frac (- (cyan cmy2) (cyan cmy1)))) (+ (magenta cmy1) (* frac (- (magenta cmy2) (magenta cmy1)))) (+ (yellow cmy1) (* frac (- (yellow cmy2) (yellow cmy1))))))) @@ -155,40 +161,3 @@ (make-exception-with-message "Unrecognised colour interpolation type") (make-exception-with-irritants interpolation-type)))))) - - -(define-class <colour-component-id> (<object>) - (component - #:init-form (error "Colour component must be specified") - #:init-keyword #:component - #:getter get-colour-component)) - - -(define (colour-component-id? a) - (is-a? a <colour-component-id>)) - - -(define (colour-component-id a) - (make <colour-component-id> - #:component a)) - - -(define (extract-colour-component col component-id) - (cond - ((eq? (get-colour-component component-id) 'cyan) - (cyan (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'magenta) - (magenta (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'yellow) - (yellow (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'red) - (red (colour-as-rgb col))) - ((eq? (get-colour-component component-id) 'green) - (green (colour-as-rgb col))) - ((eq? (get-colour-component component-id) 'blue) - (blue (colour-as-rgb col))) - (else (raise-exception (make-exception - (make-exception-with-message - "Invalid colour component ID") - (make-exception-with-irritants - (get-colour-component component-id))))))) diff --git a/guile/starlet/crossfade.scm b/guile/starlet/crossfade.scm new file mode 100644 index 0000000..65393b7 --- /dev/null +++ b/guile/starlet/crossfade.scm @@ -0,0 +1,261 @@ +;; +;; starlet/crossfade.scm +;; +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet crossfade) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 exceptions) + #:use-module (starlet clock) + #:use-module (starlet cue-part) + #:use-module (starlet colours) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet attributes) + #:export (crossfade)) + + +(define-record-type <fade-times> + (make-fade-times up-time + down-time + attr-time + up-delay + down-delay + attr-delay) + fade-times? + (up-time get-fade-up-time) + (down-time get-fade-down-time) + (attr-time get-fade-attr-time) + (up-delay get-fade-up-delay) + (down-delay get-fade-down-delay) + (attr-delay get-fade-attr-delay)) + + +(define (snap-fade start-val + target-val + clock) + (if (> (elapsed-fraction clock) 0) + target-val + start-val)) + + +(define (colour-fade start-val + end-val + clock) + + (unless (and (colour? start-val) + (colour? end-val)) + (raise-exception (make-exception + (make-exception-with-message + "Non-colour arguments given to colour-fade") + (make-exception-with-irritants + (list start-val end-val))))) + + (interpolate-colour start-val + end-val + (elapsed-fraction clock) + #:interpolation-type 'linear-cmy)) + + +(define (simple-fade start-val + end-val + clock) + + (unless (and (number? start-val) + (number? end-val)) + (raise-exception (make-exception + (make-exception-with-message + "Non-number arguments given to simple-fade") + (make-exception-with-irritants + (list start-val end-val))))) + + (+ start-val + (* (- end-val start-val) + (elapsed-fraction clock)))) + + +(define (replace-noval val replacement) + (if (eq? 'no-value val) replacement val)) + + +(define (make-intensity-fade prev-val + target-val-in + up-clock + down-clock) + (let ((target-val (replace-noval target-val-in 0.0))) + + (cond + + ;; Number to number, fading up + ((and (number? target-val) + (number? prev-val) + (> target-val prev-val)) + (lambda () + (simple-fade prev-val + target-val + up-clock))) + + ;; Number to number, fading down + ((and (number? target-val) + (number? prev-val) + (< target-val prev-val)) + (lambda () + (simple-fade prev-val + target-val + down-clock))) + + ;; Number to number, staying the same + ;; NB We still need a static value so that fade-start-val can "unwrap" it + ((and (number? target-val) + (number? prev-val)) + (lambda () prev-val)) + + ;; Everything else, e.g. number to effect + (else + (lambda () + (max + (simple-fade (value->number prev-val) + 0 + down-clock) + (simple-fade 0 + (value->number target-val) + up-clock))))))) + + +(define (make-list-attr-fade start-val + target-val + clock) + (lambda () + (snap-fade start-val + target-val + clock))) + + +(define (make-general-fade fade-func + start-val + target-val + clock) + + (if (and (not (procedure? target-val)) + (not (eq? target-val 'no-value)) + (not (eq? start-val 'no-value))) + + ;; It makes sense to do a fade + (let ((real-start-val (value->number start-val))) + (lambda () + (fade-func real-start-val + target-val + clock))) + + ;; A fade doesn't make sense, so make do with a snap transition + (lambda () + (snap-fade start-val + target-val + clock)))) + + +(define (fade-start-val pb fix attr) + (let ((val-in-pb (state-find fix attr pb))) + (if (eq? val-in-pb 'no-value) + + ;; Not currently in playback - fade from home value + (get-attr-home-val fix attr) + + ;; Currently in playback - fade from current value + ;; by running the outer crossfade function + (val-in-pb)))) + + +(define (dark? a) + (or (eq? a 'no-value) + (and (number? a) + (< a 1)))) + + +(define (make-fade-for-attribute-type type) + (cond + ((eq? type 'continuous) (cut make-general-fade simple-fade <...>)) + ((eq? type 'list) make-list-attr-fade) + ((eq? type 'colour) (cut make-general-fade colour-fade <...>)) + (else + (raise-exception (make-exception + (make-exception-with-message + "Unrecognised attribute type") + (make-exception-with-irritants type)))))) + + +(define* (crossfade-real incoming-state up-time #:optional (down-time up-time) + #:key + (attr-time (min up-time down-time)) + (up-delay 0) + (down-delay 0) + (attr-delay 0)) + (cue-part + incoming-state + (lambda (incoming-state current-state clock) + (let ((up-clock (make-delayed-clock clock up-delay up-time)) + (down-clock (make-delayed-clock clock down-delay down-time)) + (attribute-clock (make-delayed-clock clock attr-delay attr-time))) + (let ((overlay-state (make-empty-state))) + (state-for-each + (lambda (fixture attr target-val) + + (let ((start-val (fade-start-val current-state fixture attr))) + + (if (intensity? attr) + + ;; Intensity attribute + (set-in-state! overlay-state fixture attr + (make-intensity-fade start-val + target-val + up-clock + down-clock)) + + ;; Non-intensity attribute + (let ((attribute-obj (find-attr fixture attr))) + + (unless attribute-obj + (raise-exception (make-exception + (make-exception-with-message + "Attribute not found") + (make-exception-with-irritants + (list fixture attr))))) + + (let* ((atype (get-attr-type attribute-obj)) + (make-fade-func (make-fade-for-attribute-type atype))) + + (set-in-state! overlay-state fixture attr + (make-fade-func start-val + target-val + attribute-clock))))))) + + incoming-state) + (values overlay-state + (max + (+ up-time up-delay) + (+ down-time down-delay) + (+ attr-time attr-delay)))))))) + + +;; Rearrange the arguments to put the lighting state (last argument) +;; at the beginning. This makes optional arguments in crossfade-real possible. +(define (crossfade . args) + (apply crossfade-real (last args) (drop-right args 1))) diff --git a/guile/starlet/cue-list.scm b/guile/starlet/cue-list.scm new file mode 100644 index 0000000..b029713 --- /dev/null +++ b/guile/starlet/cue-list.scm @@ -0,0 +1,217 @@ +;; +;; starlet/cue-list.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet cue-list) + #:use-module (oop goops) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 atomic) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-43) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet clock) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:use-module (starlet cue-part) + #:use-module (starlet snap-transition) + #:use-module (starlet crossfade) + #:export (cue + cue-list + qnum + get-cue-number + get-cue-parts + get-cue-clock + get-preset-state + cue-number-to-index + cue-index-to-number + current-cue-clock + read-cue-list-file + num-cues) + #:re-export (snap crossfade)) + + +(define-record-type <cue> + (make-cue number + preset-state + track-intensities + cue-parts + cue-clock) + cue? + (number get-cue-number) + (preset-state get-preset-state + set-preset-state!) + (track-intensities track-intensities?) + (cue-parts get-cue-parts) + (cue-clock get-cue-clock)) + + +(define-method (num-cues (l <vector>)) + (vector-length l)) + + +(define (qnum a) + (/ (inexact->exact (* a 1000)) 1000)) + + +(define (cue-index-to-number cue-list cue-index) + (get-cue-number (vector-ref cue-list cue-index))) + + +(define (cue-number-to-index cue-list cue-number) + (vector-index (lambda (a) + (eqv? (get-cue-number a) + cue-number)) + cue-list)) + + +(define (fix-attr-eq fa1 fa2) + (and (eq? (car fa1) (car fa2)) + (eq? (cdr fa1) (cdr fa2)))) + + +(define (fix-attrs-in-state state) + (state-map->list + (lambda (fix attr val) (cons fix attr)) + state)) + + +(define (add-fix-attrs-to-list state old-list) + (lset-union fix-attr-eq + old-list + (fix-attrs-in-state state))) + + + +(define current-cue-clock (make-parameter #f)) + +(define-syntax cue + (syntax-rules (track-intensities) + ((_ number track-intensities body ...) + (parameterize ((current-cue-clock (make-clock #:stopped #t))) + (make-cue (qnum number) + #f ;; preset state, to be filled later + #t ;; DO track intensities + (list body ...) + (current-cue-clock)))) + ((_ number body ...) + (parameterize ((current-cue-clock (make-clock #:stopped #t))) + (make-cue (qnum number) + #f ;; preset state, to be filled later + #f ;; don't track intensities + (list body ...) + (current-cue-clock)))))) + + +(define (track-all-cues! the-cue-list) + (vector-fold + (lambda (idx prev-state the-cue) + (let ((the-tracked-state (lighting-state + (apply-state prev-state) + (unless (track-intensities? the-cue) + (blackout!)) + (apply-state + (get-cue-part-state + (car (get-cue-parts the-cue))))))) + (set-cue-part-state! (car (get-cue-parts the-cue)) + the-tracked-state) + (lighting-state + (apply-state the-tracked-state) + (for-each + (lambda (part) + (apply-state (get-cue-part-state part))) + (cdr (get-cue-parts the-cue)))))) + (make-empty-state) + the-cue-list)) + + +(define (dark? a) + (or (eq? a 'no-value) + (and (number? a) + (< a 1)))) + + +(define (fixture-dark-in-cue? fix the-cue) + (every + (lambda (part) + (dark? (state-find fix intensity (get-cue-part-state part)))) + (get-cue-parts the-cue))) + + +(define-syntax for-each-cue-part + (syntax-rules () + ((_ the-cue (part) body ...) + (for-each + (lambda (part) + body ...) + (get-cue-parts the-cue))))) + + +(define-syntax for-every-attr-in-cue + (syntax-rules () + ((_ the-cue (fix attr val) body ...) + (for-each-cue-part + the-cue (part) + (state-for-each + (lambda (fix attr val) + body ...) + (get-cue-part-state part)))))) + + +(define (preset-all-cues! the-cue-list) + (let loop ((idx 0)) + (let ((the-cue (vector-ref the-cue-list idx)) + (next-cue (vector-ref the-cue-list (1+ idx))) + (preset-state (make-empty-state))) + (for-every-attr-in-cue + next-cue (fix attr val) + (unless (intensity? attr) + (when (fixture-dark-in-cue? fix the-cue) + (set-in-state! preset-state fix attr val)))) + (set-preset-state! the-cue preset-state)) + (if (< (+ 2 idx) (vector-length the-cue-list)) + (loop (1+ idx)) + (set-preset-state! + (vector-ref the-cue-list (1+ idx)) + (make-empty-state))))) + + +(define-syntax cue-list + (syntax-rules () + ((_ body ...) + (let ((the-cue-list + (list->vector + (remove unspecified? + (list + (cue 0 (snap blackout)) + body ...))))) + (track-all-cues! the-cue-list) + (preset-all-cues! the-cue-list) + the-cue-list)))) + + +(define (read-cue-list-file filename) + (call-with-input-file + filename + (lambda (port) + (eval (read port) (interaction-environment))))) diff --git a/guile/starlet/cue-part.scm b/guile/starlet/cue-part.scm new file mode 100644 index 0000000..e98e422 --- /dev/null +++ b/guile/starlet/cue-part.scm @@ -0,0 +1,35 @@ +;; +;; starlet/cue-part +;; +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet cue-part) + #:use-module (srfi srfi-9) + #:export (cue-part + <cue-part> + get-cue-part-state + get-cue-part-transition + set-cue-part-state!)) + + +(define-record-type <cue-part> + (cue-part state transition) + cue-part? + (state get-cue-part-state + set-cue-part-state!) + (transition get-cue-part-transition)) diff --git a/guile/starlet/effects.scm b/guile/starlet/effects.scm index c14f5a0..0a23dee 100644 --- a/guile/starlet/effects.scm +++ b/guile/starlet/effects.scm @@ -20,8 +20,11 @@ ;; (define-module (starlet effects) #:use-module (starlet clock) + #:use-module (starlet state) + #:use-module (starlet attributes) #:export (flash - sinewave)) + sinewave + flash-chase)) (define pi (* 2 (acos 0))) @@ -45,3 +48,25 @@ (+ range-min (* (/ (- range-max range-min) 2) (+ 1 (sin (* 2 pi hz (elapsed-time clock))))))))) + + +(define (hump t on-time) + (cond + ((< t 0.0) 0.0) + ((> t on-time) 0.0) + (else (* 100 (sin (* pi (/ t on-time))))))) + + +(define* (flash-chase group + #:key (repeat-time 2) (offset-time 0.3) (on-time 0.5)) + (let ((clock (make-clock))) + (for-each + (lambda (fix idx) + (at fix intensity + (lambda () + (hump (- (euclidean-remainder (elapsed-time clock) + repeat-time) + (* idx offset-time)) + on-time)))) + group + (iota (length group))))) diff --git a/guile/starlet/engine.scm b/guile/starlet/engine.scm new file mode 100644 index 0000000..fcd63a5 --- /dev/null +++ b/guile/starlet/engine.scm @@ -0,0 +1,227 @@ +;; +;; starlet/engine.scm +;; +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet engine) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:use-module (oop goops) + #:use-module (ice-9 threads) + #:use-module (ice-9 atomic) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-1) + #:export (patch-fixture! + patch-many! + engine-freq + total-num-attrs + register-state! + current-value + current-value-state + patched-fixture-names + patched-fixtures)) + + +;; The list of patched fixtures +(define fixtures (make-atomic-box '())) + +;; List of states being scanned out +(define state-list (make-atomic-box '())) + +;; Association list of names to states +(define state-names (make-atomic-box '())) + +;; Current values (literal, not functions) of active attributes +(define current-values (make-atomic-box (make-empty-state))) + + +(define (patched-fixture-names) + (map get-fixture-name (atomic-box-ref fixtures))) + + +(define (current-value-state) + (atomic-box-ref current-values)) + + +(define (patched-fixtures) + (atomic-box-ref fixtures)) + + +(define (total-num-attrs) + (fold (lambda (fix prev) + (+ prev (length (get-fixture-attrs fix)))) + 0 + (atomic-box-ref fixtures))) + + +(define (get-state-name st) + (assq-ref (atomic-box-ref state-names) + st)) + + +(define (set-state-name! st name) + (atomic-box-set! state-names + (assq-set! (atomic-box-ref state-names) + st + name))) + + +;; Patch a new fixture +(define* (patch-real name + class + start-addr + #:key (universe 0)) + (let ((new-fixture (make class + #:name name + #:sa start-addr + #:uni universe))) + (atomic-box-set! fixtures (cons new-fixture + (atomic-box-ref fixtures))) + new-fixture)) + + +(define-syntax patch-fixture! + (syntax-rules () + ((_ name stuff ...) + (define name (patch-real (quote name) stuff ...))))) + + +;; Patch several new fixtures +(define* (patch-many-real name + class + start-addrs + #:key (universe 0)) + (map (lambda (start-addr n) + (patch-real `(list-ref ,name ,n) + class + start-addr + #:universe universe)) + start-addrs + (iota (length start-addrs)))) + + +(define-syntax patch-many! + (syntax-rules () + ((_ name stuff ...) + (define name (patch-many-real (quote name) stuff ...))))) + + +(define (current-value fix attr-name) + (let ((v (state-find fix attr-name (current-value-state)))) + (if (eq? v 'no-value) + (get-attr-home-val fix attr-name) + v))) + + +(define (append-or-replace-named-state orig-list name new-state) + (let ((new-list (map (lambda (st) + (if (eq? (get-state-name st) name) + (begin + new-state) + st)) + orig-list))) + + ;; If there is no state with this name in the list, + ;; the replacement above will have no effect. + ;; Check again and add in the normal way if so. + (if (find (lambda (st) (eq? (get-state-name st) + name)) + new-list) + new-list + (append orig-list (list new-state))))) + + +(define* (register-state! new-state + #:key (unique-name #f)) + (if unique-name + (begin (set-state-name! new-state unique-name) + (atomic-box-set! state-list + (append-or-replace-named-state (atomic-box-ref state-list) + unique-name + new-state))) + (atomic-box-set! state-list + (append (atomic-box-ref state-list) + (list new-state))))) + + +(define engine-thread #f) +(define engine-freq 0) + + +(define (htp-attr? attr) + (eq? attr intensity)) + + +(define (engine-loop start-time count) + + ;; Combine all the active attributes and send it out + (atomic-box-swap! current-values + (combine-states + (let ((states (atomic-box-ref state-list))) + (for-each update-state! states) + (fold + (lambda (incoming-state combined-state) + (state-for-each + (lambda (fix attr val) + (let ((incoming-val (value->number val)) + (current-val (state-find fix attr combined-state))) + (unless (eq? incoming-val 'no-value) + (if (eq? current-val 'no-value) + (set-in-state! combined-state fix attr incoming-val) + (set-in-state! combined-state fix attr + (if (htp-attr? attr) + (max incoming-val current-val) + incoming-val)))))) + incoming-state) + combined-state) + (make-empty-state) + states)) + programmer-state)) + + (usleep 20000) + + ;; Update output rate every 1000 cycles + (if (eq? count 100) + (begin + (set! engine-freq + (exact->inexact (/ 100 + (- (hirestime) start-time)))) + (engine-loop (hirestime) 0)) + (engine-loop start-time (+ count 1)))) + + +(define (start-engine) + (if engine-thread + (format #t "Engine thread is already running\n") + (let ((start-time (hirestime))) + (set! engine-thread + (begin-thread + (with-exception-handler + (lambda (exn) + (display "Error in engine thread:\n") + (set! engine-thread #f) + (backtrace) + (raise-exception exn)) + (lambda () + (engine-loop start-time 0)) + #:unwind? #f)))))) + + +(start-engine) diff --git a/guile/starlet/fixture-library/adj/mega-tripar-profile.scm b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm new file mode 100644 index 0000000..4815fa9 --- /dev/null +++ b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm @@ -0,0 +1,63 @@ +;; +;; starlet/fixture-library/adj/mega-tripar-profile.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.me.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library adj mega-tripar-profile) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<adj-mega-tripar-profile-3ch> + <adj-mega-tripar-profile-4ch>)) + + +;; 3 channel mode (RGB direct control) + +(define-fixture + + <adj-mega-tripar-profile-3ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((intensity (/ (get-attr intensity) 100)) + (rgb (colour-as-rgb (get-attr colour)))) + (set-chan8 1 (percent->dmxval8 (* intensity (car rgb)))) + (set-chan8 2 (percent->dmxval8 (* intensity (cadr rgb)))) + (set-chan8 3 (percent->dmxval8 (* intensity (caddr rgb)))))) + + +;; 4 channel mode (RGB + separate intensity) + +(define-fixture + + <adj-mega-tripar-profile-4ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((rgb (colour-as-rgb (get-attr colour)))) + (set-chan8 1 (percent->dmxval8 (get-attr intensity))) + (set-chan8 2 (percent->dmxval8 (car rgb))) + (set-chan8 3 (percent->dmxval8 (cadr rgb))) + (set-chan8 4 (percent->dmxval8 (caddr rgb))))) + diff --git a/guile/starlet/fixture-library/chauvet/mav2.scm b/guile/starlet/fixture-library/chauvet/mav2.scm new file mode 100644 index 0000000..5fae168 --- /dev/null +++ b/guile/starlet/fixture-library/chauvet/mav2.scm @@ -0,0 +1,50 @@ +;; +;; starlet/fixture-library/chauvet.scm +;; +;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library chauvet mav2) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<chauvet-mav2-32ch>)) + + +(define-fixture + + <chauvet-mav2-32ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-continuous cyan '(0 100) 0) + (attr-continuous magenta '(0 100) 0) + (attr-continuous yellow '(0 100) 0)) + + (set-chan-16bit 1 (get-attr pan) 540) + (set-chan-16bit 3 (get-attr tilt) 270) + (set-chan-16bit 6 (get-attr intensity) 100) + + (set-chan 10 (percent->dmxval (get-attr cyan))) + (set-chan 11 (percent->dmxval (get-attr magenta))) + (set-chan 12 (percent->dmxval (get-attr yellow))) + + (set-chan 8 255)) diff --git a/guile/starlet/fixture-library/chauvet/mav2/32chan.scm b/guile/starlet/fixture-library/chauvet/mav2/32chan.scm deleted file mode 100644 index 5868587..0000000 --- a/guile/starlet/fixture-library/chauvet/mav2/32chan.scm +++ /dev/null @@ -1,49 +0,0 @@ -;; -;; starlet/fixture-library/chauvet.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(define-module (starlet fixture-library chauvet) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:export (<chauvet-mav2-32ch>)) - - -(define-class <chauvet-mav2-32ch> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-continuous 'cyan '(0 100) 0) - (attr-continuous 'magenta '(0 100) 0) - (attr-continuous 'yellow '(0 100) 0)))) - - -(define-method (scanout-fixture (fixture <chauvet-mav2-32ch>) - get-attr set-chan set-chan-16bit) - - (set-chan-16bit 1 (get-attr 'pan) 540) - (set-chan-16bit 3 (get-attr 'tilt) 270) - (set-chan-16bit 6 (get-attr 'intensity) 100) - - (set-chan 10 (percent->dmxval (get-attr 'cyan))) - (set-chan 11 (percent->dmxval (get-attr 'magenta))) - (set-chan 12 (percent->dmxval (get-attr 'yellow))) - - (set-chan 8 255)) diff --git a/guile/starlet/fixture-library/generic/any-rgb.scm b/guile/starlet/fixture-library/generic/any-rgb.scm deleted file mode 100644 index 1fc3fe2..0000000 --- a/guile/starlet/fixture-library/generic/any-rgb.scm +++ /dev/null @@ -1,62 +0,0 @@ -;; -;; starlet/fixture-library/generic/any-rgb.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(define-module (starlet fixture-library generic any-rgb) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:export (make-any-rgb)) - - -(define (chan->attr chan) - (attr-continuous chan '(0 100) 0)) - - -(define (make-any-rgb chans) - - (let ((new-class (make-class - (list <fixture>) - (list (cons 'attributes - (list #:init-thunk - (lambda () - (map chan->attr chans))))) - #:name 'generic-rgb))) - - (add-method! - scanout-fixture - (method ((fix new-class) get-attr set-chan8 set-chan16) - (for-each - - (lambda (chan offset) - - (cond - - ((eq? chan '0) - (set-chan8 offset 0)) - - ((eq? chan 'FL) - (set-chan8 offset 255)) - - (else (set-chan8 offset - (percent->dmxval8 - (get-attr chan)))))) - - chans (iota (length chans) 1)))) - - new-class)) diff --git a/guile/starlet/fixture-library/generic/dimmer.scm b/guile/starlet/fixture-library/generic/dimmer.scm index 65e6d99..6b25c15 100644 --- a/guile/starlet/fixture-library/generic/dimmer.scm +++ b/guile/starlet/fixture-library/generic/dimmer.scm @@ -1,7 +1,7 @@ ;; ;; starlet/fixture-library/generic/dimmer.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -19,20 +19,18 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library generic dimmer) - #:use-module (oop goops) + #:use-module (starlet scanout) #:use-module (starlet fixture) + #:use-module (starlet utils) + #:use-module (starlet attributes) #:export (<generic-dimmer>)) +(define-fixture -(define-class <generic-dimmer> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0)))) + <generic-dimmer> + (fixture-attributes + (attr-continuous intensity '(0 100) 0)) -(define-method (scanout-fixture (fixture <generic-dimmer>) - get-attr set-chan8 set-chan16) - - ;; Set DMX value for intensity - (set-chan8 1 (percent->dmxval8 (get-attr 'intensity)))) + (set-chan8 1 (percent->dmxval8 (get-attr intensity)))) diff --git a/guile/starlet/fixture-library/generic/rgb.scm b/guile/starlet/fixture-library/generic/rgb.scm index 6fa281d..a47b48d 100644 --- a/guile/starlet/fixture-library/generic/rgb.scm +++ b/guile/starlet/fixture-library/generic/rgb.scm @@ -1,7 +1,7 @@ ;; ;; starlet/fixture-library/generic/rgb.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -19,25 +19,52 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library generic rgb) - #:use-module (oop goops) + #:use-module (starlet scanout) #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) #:use-module (starlet colours) - #:export (<generic-rgb>)) + #:export (<generic-rgb> + <generic-rgbw>)) -(define-class <generic-rgb> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-colour 'colour white)))) +(define (colour-as-rgbw-weirdness col weirdness) + (let ((rgb (colour-as-rgb col))) + (let ((w (* (- 1 weirdness) (apply min rgb)))) + (list (- (red rgb) w) + (- (green rgb) w) + (- (blue rgb) w) + w)))) -(define-method (scanout-fixture (fixture <generic-rgb>) - get-attr set-chan8 set-chan16) +(define-fixture - (let ((intensity (get-attr 'intensity)) - (rgb (colour-as-rgb (get-attr 'colour)))) + <generic-rgb> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((intensity (get-attr intensity)) + (rgb (colour-as-rgb (get-attr colour)))) (set-chan8 1 (percent->dmxval8 (* intensity 0.01 (car rgb)))) (set-chan8 2 (percent->dmxval8 (* intensity 0.01 (cadr rgb)))) (set-chan8 3 (percent->dmxval8 (* intensity 0.01 (caddr rgb)))))) + +(define-fixture + + <generic-rgbw> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white) + (attr-continuous white-weirdness '(0 100) 0)) + + (let ((intensity (get-attr intensity)) + (rgbw (colour-as-rgbw-weirdness (get-attr colour) + (/ (get-attr white-weirdness) 100)))) + (set-chan8 1 (percent->dmxval8 (* 0.01 intensity (car rgbw)))) + (set-chan8 2 (percent->dmxval8 (* 0.01 intensity (cadr rgbw)))) + (set-chan8 3 (percent->dmxval8 (* 0.01 intensity (caddr rgbw)))) + (set-chan8 4 (percent->dmxval8 (* 0.01 intensity (cadddr rgbw)))))) diff --git a/guile/starlet/fixture-library/lightmaxx/led-cob.scm b/guile/starlet/fixture-library/lightmaxx/led-cob.scm new file mode 100644 index 0000000..5ce5879 --- /dev/null +++ b/guile/starlet/fixture-library/lightmaxx/led-cob.scm @@ -0,0 +1,45 @@ +;; +;; starlet/fixture-library/lightmaxx-led-cob.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library lightmaxx led-cob) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet colours) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:export (<lightmaxx-ledcob-5ch>)) + +(define-fixture + + <lightmaxx-ledcob-5ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((intensity (get-attr intensity)) + (rgb (colour-as-rgb (get-attr colour)))) + (set-chan8 1 (percent->dmxval8 (car rgb))) + (set-chan8 2 (percent->dmxval8 (cadr rgb))) + (set-chan8 3 (percent->dmxval8 (caddr rgb))) + (set-chan8 4 (percent->dmxval8 intensity)) + (set-chan8 5 0))) + diff --git a/guile/starlet/fixture-library/robe/dl7s.scm b/guile/starlet/fixture-library/robe/dl7s.scm new file mode 100644 index 0000000..0f9b10d --- /dev/null +++ b/guile/starlet/fixture-library/robe/dl7s.scm @@ -0,0 +1,241 @@ +;; +;; starlet/fixture-library/robe/dl7s/mode1.scm +;; +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library robe dl7s) + #:use-module (oop goops) + #:use-module (starlet fixture) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:use-module (starlet colours) + #:use-module (starlet scanout) + #:export (<robe-dl7s-mode1>)) + + +(define virtual-colour-wheel + '((#f 0) + (lee4-medium-bastard-amber 2) + (lee10-medium-yellow 4) + (lee19-fire 6) + (lee26-bright-red 8) + (lee58-lavender 10) + (lee68-sky-blue 12) + (lee71-tokyo-blue 14) + (lee79-just-blue 16) + (lee88-lime-green 18) + (lee90-dark-yellow-green 20) + (lee100-spring-yellow 22) + (lee101-yellow 24) + (lee102-light-amber 26) + (lee103-straw 28) + (lee104-deep-amber 30) + (lee105-orange 32) + (lee106-primary-red 34) + (lee111-dark-pink 36) + (lee115-peacock-blue 38) + (lee116-medium-blue-green 40) + (lee117-steel-blue 42) + (lee118-light-blue 44) + (lee119-dark-blue 46) + (lee120-deep-blue 48) + (lee121-lee-green 50) + (lee128-bright-pink 52) + (lee131-marine-blue 54) + (lee132-medium-blue 56) + (lee134-golden-amber 58) + (lee135-deep-golden-amber 60) + (lee136-pale-lavender 62) + (lee137-special-lavender 64) + (lee138-pale-green 66) + (lee139-primary-green 68) + (lee141-bright-blue 70) + (lee147-apricot 72) + (lee148-bright-rose 74) + (lee152-pale-gold 76) + (lee154-pale-rose 78) + (lee157-pink 80) + (lee158-deep-orange 82) + (lee162-bastard-amber 84) + (lee164-flame-red 86) + (lee165-daylight-blue 88) + (lee169-lilac-tint 90) + (lee170-deep-lavender 92) + (lee172-lagoon-blue 94) + (lee179-chrome-orange 96) + (lee180-dark-lavender 98) + (lee181-congo-blue 100) + (lee197-alice-blue 102) + (lee201-full-ct-blue 104) + (lee202-half-ct-blue 106) + (lee203-quarter-ct-blue 108) + (lee204-full-ct-orange 110) + (lee205-half-ct-orange 112) + (lee206-quarter-ct-orange 114) + (lee247-lee-minus-green 116) + (lee247-half-minus-green 118) + (lee281-threequarter-ct-blue 120) + (lee285-threequarter-ct-orange 122) + (lee352-glacier-blue 124) + (lee353-lighter-blue 126) + (lee715-cabana-blue 128) + (lee778-millennium-gold 130) + (lee793-vanity-fair 132) + (deep-red 193) + (deep-blue 195) + (orange 197) + (green 199) + (magenta 201) + (congo-blue 203) + (pink 205) + (lavender 207) + (laser-green 209) + (ctb 211) + (minus-green 213) + (minus-half-green 215))) + +(define static-gobo-wheel + '((#f 0) + (water 7) + (rugged-isles 14) + (quadrangle-screen 21) + (whirl 28) + (breakup 36) + (blur-breakup 43) + (knitting 50) + (grit 57))) + +(define rotating-gobo-wheel + '((#f 0) + (rose 7) + (water-line 11) + (tree-trunk 15) + (high-window 20) + (grid 24) + (clouds 29))) + + +;; FIXME: Gobo shaking (both wheels) +;; FIXME: Rainbow effect on colour wheel (???) +;; FIXME: Fine control iris, zoom +(define-fixture + + <robe-dl7s-mode1> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-list strobe '(#f on random) #f) + (attr-continuous strobe-frequency '(0 25) 25 "Frequencies not calibrated") + (attr-list prism '(#t #f) #f) + (attr-colour colour white) + (attr-list colwheel (map car virtual-colour-wheel) #f "Has priority over 'colour' attribute") + (attr-continuous colour-temperature '(2700 8000) 3200) + (attr-list animation-wheel '(#t #f) #f) + (attr-continuous animation-wheel-position '(-100 100) 0) + (attr-continuous animation-wheel-speed '(-100 100) 0) + (attr-list gobo (map car static-gobo-wheel) #f) + (attr-continuous gobo-shift '(0 100) 0) + (attr-list rotating-gobo (map car rotating-gobo-wheel) #f) + (attr-continuous rotating-gobo-speed '(-100 100) 0) + (attr-continuous prism-rotation-speed '(-100 100) 0) + (attr-continuous frost '(0 100) 0) + (attr-continuous zoom '(0 100) 50) + (attr-continuous iris '(0 100) 0) + (attr-continuous barndoor-all-rotation '(-45 45) 0) + (attr-continuous barndoor1 '(0 100) 0) + (attr-continuous barndoor2 '(0 100) 0) + (attr-continuous barndoor3 '(0 100) 0) + (attr-continuous barndoor4 '(0 100) 0) + (attr-continuous barndoor1-rotation '(-25 25) 0) + (attr-continuous barndoor2-rotation '(-25 25) 0) + (attr-continuous barndoor3-rotation '(-25 25) 0) + (attr-continuous barndoor4-rotation '(-25 25) 0) + (attr-continuous focus '(0 100) 50)) + + (set-chan16 1 (scale-to-range (get-attr pan) '(0 540) '(0 65535))) + (set-chan16 3 (scale-to-range (get-attr tilt) '(0 270) '(0 65535))) + + (set-chan8 5 0) ;; Pan/tilt speed/time: maximum speed + (set-chan8 6 0) ;; Power/special function: default + (set-chan8 7 0) ;; Colour mode: default + + (set-chan8 8 (lookup (get-attr colwheel) virtual-colour-wheel)) + + (let ((cmy (colour-as-cmy (get-attr colour)))) + (set-chan16 9 (percent->dmxval16 (cyan cmy))) + (set-chan16 11 (percent->dmxval16 (magenta cmy))) + (set-chan16 13 (percent->dmxval16 (yellow cmy)))) + + (set-chan8 15 + (scale-and-clamp-to-range (get-attr colour-temperature) + '(8000 2700) '(0 255))) + + (set-chan8 16 0) ;; Green correction: uncorrected white + (set-chan8 17 0) ;; Colour mix control: virtual colour wheel has priority + (set-chan8 18 0) ;; Rotating gobo selection speed: maximum + (set-chan8 19 0) ;; Everything time: off (???) + + (let ((ani-active (get-attr animation-wheel))) + (set-chan8 20 (if ani-active + (scale-to-range (get-attr animation-wheel-position) + '(-100 100) '(19 127)) + 0)) ;; 73 = stop + (set-chan8 21 (scale-to-range (get-attr animation-wheel-speed) + '(100 -100) '(1 255)))) ;; 128 = stop + (set-chan8 22 0) ;; Animation wheel macro: no function + + (set-chan8 23 (lookup (get-attr gobo) static-gobo-wheel)) + (set-chan8 24 (percent->dmxval8 (get-attr gobo-shift))) + + (set-chan8 25 (lookup (get-attr rotating-gobo) rotating-gobo-wheel)) + (set-chan8 26 (scale-to-range (get-attr rotating-gobo-speed) + '(-100 100) '(1 255))) ;; 128 = stop + (set-chan8 27 0) ;; Rotating gobo fine adjustment (default) + + (set-chan8 28 (if (get-attr prism) 50 0)) + (set-chan8 29 (scale-to-range (get-attr prism-rotation-speed) + '(100 -100) '(1 255))) ;; 128 = stop, <128=forwards + (set-chan8 30 (scale-to-range (get-attr frost) '(0 100) '(0 180))) + (set-chan8 31 (scale-to-range (get-attr iris) '(0 100) '(0 180))) + (set-chan16 33 (percent->dmxval16 (get-attr zoom))) + (set-chan16 35 (percent->dmxval16 (get-attr focus))) + + (set-chan8 38 (scale-to-range (get-attr barndoor-all-rotation) '(-45 45) '(0 255))) + (set-chan8 39 (percent->dmxval8 (get-attr barndoor1))) + (set-chan8 40 (scale-to-range (get-attr barndoor1-rotation) '(-25 25) '(0 255))) + (set-chan8 41 (percent->dmxval8 (get-attr barndoor2))) + (set-chan8 42 (scale-to-range (get-attr barndoor2-rotation) '(-25 25) '(0 255))) + (set-chan8 43 (percent->dmxval8 (get-attr barndoor3))) + (set-chan8 44 (scale-to-range (get-attr barndoor3-rotation) '(-25 25) '(0 255))) + (set-chan8 45 (percent->dmxval8 (get-attr barndoor4))) + (set-chan8 46 (scale-to-range (get-attr barndoor4-rotation) '(-25 25) '(0 255))) + (set-chan8 47 0) ;; Framing shutter macro: no function + (set-chan8 48 128) ;; Framing shutter macro speed: default + + (let ((strb (get-attr strobe))) + (set-chan8 49 + (cond + ((not strb) 32) + ((eq? strb 'on) + (scale-to-range (get-attr strobe-frequency) '(1 25) '(64 95))) + ((eq? strb 'random) + (scale-to-range (get-attr strobe-frequency) '(1 25) '(192 223)))))) + + (set-chan16 50 (percent->dmxval16 (get-attr intensity)))) diff --git a/guile/starlet/fixture-library/robe/dl7s/mode1.scm b/guile/starlet/fixture-library/robe/dl7s/mode1.scm deleted file mode 100644 index e9d5a9a..0000000 --- a/guile/starlet/fixture-library/robe/dl7s/mode1.scm +++ /dev/null @@ -1,65 +0,0 @@ -;; -;; starlet/fixture-library/robe/dl7s/mode1.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(define-module (starlet fixture-library robe dl7s mode1) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:export (<robe-dl7s-mode1>)) - - -(define-class <robe-dl7s-mode1> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-list 'strobe '(#t #f) #f) - (attr-list 'prism '(#t #f) #f) - (attr-list 'tungsten-watts-emulation '(750 1000 1200 2000 2500 #f) #f) - (attr-colour 'colour white) - (attr-continuous 'colour-temperature-correction '(2700 8000) 8000) - (attr-continuous 'green-correction '(-100 100) 0)))) - - -(define-method (scanout-fixture (fixture <robe-dl7s-mode1>) - get-attr set-chan8 set-chan16) - - (set-chan16 50 (percent->dmxval16 (get-attr 'intensity))) - - (set-chan16 1 (scale-to-range (get-attr 'pan) '(0 540) '(0 65535))) - (set-chan16 3 (scale-to-range (get-attr 'tilt) (0 270) '(0 65535))) - - (set-chan8 49 (if (get-attr 'strobe) 95 32)) - - (set-chan8 28 (if (get-attr 'prism) 50 0)) - - (set-chan8 7 (assv-ref '((750 . 82) - (1000 . 88) - (1200 . 92) - (2000 . 97) - (2500 . 102) - (#f . 107)) - (get-attr 'tungsten-watts-emulation))) - - (let ((cmy (colour-as-cmy (get-attr 'colour)))) - (set-chan8 9 (percent->dmxval8 (car cmy))) - (set-chan8 11 (percent->dmxval8 (cadr cmy))) - (set-chan8 13 (percent->dmxval8 (caddr cmy))))) diff --git a/guile/starlet/fixture-library/robe/mmxspot.scm b/guile/starlet/fixture-library/robe/mmxspot.scm new file mode 100644 index 0000000..1f37299 --- /dev/null +++ b/guile/starlet/fixture-library/robe/mmxspot.scm @@ -0,0 +1,87 @@ +;; +;; starlet/fixture-library/robe/mmxspot/mode1.scm +;; +;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library robe mmxspot) + #:use-module (oop goops) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet colours) + #:export (<robe-mmxspot-mode1>)) + + +(define-fixture + + <robe-mmxspot-mode1> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-list colwheel '(#f red blue orange green amber uv) #f) + (attr-list prism '(#t #f) #f) + (attr-list strobe '(off on random zap) off) + (attr-continuous strobe-frequency '(0 100) 50) + (attr-colour colour white) + (attr-continuous iris '(0 100) 0) + (attr-continuous zoom '(0 100) 0) + (attr-continuous focus '(0 100) 0) + (attr-continuous hotspot '(0 100) 0) + (attr-continuous frost '(0 100) 0) + (attr-continuous cto '(3200 6900) 6900)) + + (set-chan16 37 (percent->dmxval16 (get-attr intensity))) + + (set-chan16 1 (scale-to-range (get-attr pan) '(0 540) '(0 65535))) + + (set-chan16 3 (scale-to-range (get-attr tilt) '(0 270) '(0 65535))) + + (set-chan16 28 (scale-to-range (get-attr iris) '(0 100) '(0 45567))) + (set-chan16 30 (percent->dmxval16 (get-attr zoom))) + (set-chan16 32 (percent->dmxval16 (get-attr focus))) + + (set-chan8 36 + (let ((strb (get-attr strobe)) + (spd (get-attr strobe-speed))) + (cond + ;; FIXME: Check the frequencies + ((eq? strb 'on) (scale-to-range spd '(0 100) '(64 95))) + ((eq? strb 'random) (scale-to-range spd '(0 100) '(192 223))) + ((eq? strb 'zap) (scale-to-range spd '(0 100) '(160 191))) + (else 255)))) + + (set-chan8 25 (if (get-attr prism) 20 0)) + + (set-chan8 7 (assv-ref '((#f . 0) + (red . 18) + (blue . 37) + (orange . 55) + (green . 73) + (amber . 91) + (uv . 110)) + (get-attr colwheel))) + + (let ((cmy (colour-as-cmy (get-attr colour)))) + (set-chan8 9 (percent->dmxval8 (car cmy))) + (set-chan8 10 (percent->dmxval8 (cadr cmy))) + (set-chan8 11 (percent->dmxval8 (caddr cmy)))) + + (set-chan8 35 (percent->dmxval8 (get-attr hotspot))) + (set-chan8 12 (scale-to-range (get-attr cto) '(3200 6900) '(0 255))) + (set-chan8 27 (scale-to-range (get-attr frost) '(0 100) '(0 179)))) diff --git a/guile/starlet/fixture-library/robe/mmxspot/mode1.scm b/guile/starlet/fixture-library/robe/mmxspot/mode1.scm deleted file mode 100644 index 9fedde4..0000000 --- a/guile/starlet/fixture-library/robe/mmxspot/mode1.scm +++ /dev/null @@ -1,87 +0,0 @@ -;; -;; starlet/fixture-library/robe/mmxspot/mode1.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(define-module (starlet fixture-library robe mmxspot mode1) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:export (<robe-mmxspot-mode1>)) - - -(define-class <robe-mmxspot-mode1> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-list 'colwheel '(#f red blue orange green amber uv) #f) - (attr-list 'prism '(#t #f) #f) - (attr-list 'strobe '(#f #t random zap) #f) - (attr-continuous 'strobe-speed '(0 100) 50) - (attr-colour 'colour white) - (attr-continuous 'iris '(0 100) 0) - (attr-continuous 'zoom '(0 100) 0) - (attr-continuous 'focus '(0 100) 0) - (attr-continuous 'hotspot '(0 100) 0) - (attr-continuous 'frost '(0 100) 0) - (attr-continuous 'cto '(3200 6900) 6900)))) - - -(define-method (scanout-fixture (fixture <robe-mmxspot-mode1>) - get-attr set-chan8 set-chan16) - - (set-chan16 37 (percent->dmxval16 (get-attr 'intensity))) - - (set-chan16 1 (scale-to-range (get-attr 'pan) '(0 540) '(0 65535))) - - (set-chan16 3 (scale-to-range (get-attr 'tilt) '(0 270) '(0 65535))) - - (set-chan16 28 (scale-to-range (get-attr 'iris) '(0 100) '(0 45567))) - (set-chan16 30 (percent->dmxval16 (get-attr 'zoom))) - (set-chan16 32 (percent->dmxval16 (get-attr 'focus))) - - (set-chan8 36 - (let ((strb (get-attr 'strobe)) - (spd (get-attr 'strobe-speed))) - (cond - ((eq? strb #t) (scale-to-range spd '(0 100) '(64 95))) - ((eq? strb 'random) (scale-to-range spd '(0 100) '(192 223))) - ((eq? strb 'zap) (scale-to-range spd '(0 100) '(160 191))) - (else 255)))) - - (set-chan8 25 (if (get-attr 'prism) 20 0)) - - (set-chan8 7 (assv-ref '((#f . 0) - (red . 18) - (blue . 37) - (orange . 55) - (green . 73) - (amber . 91) - (uv . 110)) - (get-attr 'colwheel))) - - (let ((cmy (colour-as-cmy (get-attr 'colour)))) - (set-chan8 9 (percent->dmxval8 (car cmy))) - (set-chan8 10 (percent->dmxval8 (cadr cmy))) - (set-chan8 11 (percent->dmxval8 (caddr cmy)))) - - (set-chan8 35 (percent->dmxval8 (get-attr 'hotspot))) - (set-chan8 12 (scale-to-range (get-attr 'cto) '(3200 6900) '(0 255))) - (set-chan8 27 (scale-to-range (get-attr 'frost) '(0 100) '(0 179)))) diff --git a/guile/starlet/fixture-library/robe/mmxwashbeam.scm b/guile/starlet/fixture-library/robe/mmxwashbeam.scm new file mode 100644 index 0000000..a41c80d --- /dev/null +++ b/guile/starlet/fixture-library/robe/mmxwashbeam.scm @@ -0,0 +1,94 @@ +;; +;; starlet/fixture-library/robe/mmxwashbeam.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library robe mmxwashbeam) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<robe-mmxwashbeam-mode1>)) + + +(define-fixture + + <robe-mmxwashbeam-mode1> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-list strobe '(#t #f) #f) + (attr-list colwheel '(#f red blue orange green amber uv) #f) + (attr-list gobo '(#f iris gobo1 gobo2 gobo3 gobo4 gobo5 gobo6) #f) + (attr-list beamtype '(beam beamwash beamwashext) 'beam) + (attr-colour colour white) + (attr-continuous zoom '(0 100) 0) + (attr-continuous focus '(0 100) 0) + (attr-continuous barndoor-rot '(0 180) 90) + (attr-continuous barndoor1 '(0 180) 0) + (attr-continuous barndoor2 '(0 100) 0) + (attr-continuous barndoor3 '(0 100) 0) + (attr-continuous barndoor4 '(0 100) 0)) + + (set-chan16 33 (percent->dmxval16 (get-attr intensity))) + + (set-chan16 1 (scale-to-range (get-attr pan) '(0 540) '(0 65535))) + (set-chan16 3 (scale-to-range (get-attr tilt) '(0 270) '(0 65535))) + + (set-chan8 32 (if (get-attr strobe) 70 255)) + + (set-chan16 19 (percent->dmxval16 (get-attr zoom))) + (set-chan16 21 (percent->dmxval16 (get-attr focus))) + + ;;(set-chan 24 (number->dmxval (get-attr barndoor-rot) '(0 180))) + (set-chan8 25 (percent->dmxval8 (get-attr barndoor1))) + (set-chan8 26 (percent->dmxval8 (get-attr barndoor2))) + (set-chan8 27 (percent->dmxval8 (get-attr barndoor3))) + (set-chan8 28 (percent->dmxval8 (get-attr barndoor4))) + + (set-chan8 7 (assv-ref '((#f . 0) + (red . 18) + (blue . 37) + (orange . 55) + (green . 73) + (amber . 91) + (uv . 110)) + (get-attr colwheel))) + + (set-chan8 15 (assv-ref '((#f . 0) + (iris . 5) + (gobo1 . 10) + (gobo2 . 14) + (gobo3 . 18) + (gobo4 . 22) + (gobo5 . 26) + (gobo6 . 30)) + (get-attr gobo))) + + (set-chan8 18 (assv-ref '((beam . 0) + (beamwash . 35) + (beamwashext . 45)) + (get-attr beamtype))) + + (let ((cmy (colour-as-cmy (get-attr colour)))) + (set-chan8 9 (percent->dmxval8 (car cmy))) + (set-chan8 10 (percent->dmxval8 (cadr cmy))) + (set-chan8 11 (percent->dmxval8 (caddr cmy))))) diff --git a/guile/starlet/fixture-library/robe/mmxwashbeam/mode1.scm b/guile/starlet/fixture-library/robe/mmxwashbeam/mode1.scm deleted file mode 100644 index b412a24..0000000 --- a/guile/starlet/fixture-library/robe/mmxwashbeam/mode1.scm +++ /dev/null @@ -1,94 +0,0 @@ -;; -;; starlet/fixture-library/robe/mmxwashbeam/mode1.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(define-module (starlet fixture-library robe mmxwashbeam mode1) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:export (<robe-mmxwashbeam-mode1>)) - - -(define-class <robe-mmxwashbeam-mode1> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-list 'strobe '(#t #f) #f) - (attr-list 'colwheel '(#f red blue orange green amber uv) #f) - (attr-list 'gobo '(#f iris gobo1 gobo2 gobo3 gobo4 gobo5 gobo6) #f) - (attr-list 'beamtype '(beam beamwash beamwashext) 'beam) - (attr-colour 'colour white) - (attr-continuous 'zoom '(0 100) 0) - (attr-continuous 'focus '(0 100) 0) - (attr-continuous 'barndoor-rot '(0 180) 90) - (attr-continuous 'barndoor1 '(0 180) 0) - (attr-continuous 'barndoor2 '(0 100) 0) - (attr-continuous 'barndoor3 '(0 100) 0) - (attr-continuous 'barndoor4 '(0 100) 0)))) - - -(define-method (scanout-fixture (fixture <robe-mmxwashbeam-mode1>) - get-attr set-chan8 set-chan16) - - (set-chan16 33 (percent->dmxval16 (get-attr 'intensity))) - - (set-chan16 1 (scale-to-range (get-attr 'pan) '(0 540) '(0 65535))) - (set-chan16 3 (scale-to-range (get-attr 'tilt) '(0 270) '(0 65535))) - - (set-chan8 32 (if (get-attr 'strobe) 70 255)) - - (set-chan16 19 (percent->dmxval16 (get-attr 'zoom))) - (set-chan16 21 (percent->dmxval16 (get-attr 'focus))) - - ;;(set-chan 24 (number->dmxval (get-attr 'barndoor-rot) '(0 180))) - (set-chan8 25 (percent->dmxval8 (get-attr 'barndoor1))) - (set-chan8 26 (percent->dmxval8 (get-attr 'barndoor2))) - (set-chan8 27 (percent->dmxval8 (get-attr 'barndoor3))) - (set-chan8 28 (percent->dmxval8 (get-attr 'barndoor4))) - - (set-chan8 7 (assv-ref '((#f . 0) - (red . 18) - (blue . 37) - (orange . 55) - (green . 73) - (amber . 91) - (uv . 110)) - (get-attr 'colwheel))) - - (set-chan8 15 (assv-ref '((#f . 0) - (iris . 5) - (gobo1 . 10) - (gobo2 . 14) - (gobo3 . 18) - (gobo4 . 22) - (gobo5 . 26) - (gobo6 . 30)) - (get-attr 'gobo))) - - (set-chan8 18 (assv-ref '((beam . 0) - (beamwash . 35) - (beamwashext . 45)) - (get-attr 'beamtype))) - - (let ((cmy (colour-as-cmy (get-attr 'colour)))) - (set-chan8 9 (percent->dmxval8 (car cmy))) - (set-chan8 10 (percent->dmxval8 (cadr cmy))) - (set-chan8 11 (percent->dmxval8 (caddr cmy))))) diff --git a/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm new file mode 100644 index 0000000..b3320b2 --- /dev/null +++ b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm @@ -0,0 +1,51 @@ +;; +;; starlet/fixture-library/stairville/octagon-theater-cw-ww.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.me.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library stairville octagon-theater-cw-ww) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:export (<stairville-octagon-theater-cw-ww>)) + +(define-fixture + + <stairville-octagon-theater-cw-ww> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous colour-temperature '(2800 6400) 3200) + (attr-list strobe '(#f #t) #f) + ;; FIXME: Strobe frequency is not stated in manual. + ;; I've assumed that "slow" means 1 Hz, "fast" 25 Hz + (attr-continuous strobe-frequency '(1 25) 1)) + + (let ((coltemp (get-attr colour-temperature))) + (set-chan8 1 (scale-and-clamp-to-range coltemp '(2800 6400) '(0 255))) + (set-chan8 2 (scale-and-clamp-to-range coltemp '(2800 6400) '(255 0)))) + (if (get-attr strobe) + (set-chan8 3 (scale-and-clamp-to-range + (get-attr strobe-frequency) + '(1 25) + '(16 255))) + (set-chan8 3 0)) + (set-chan8 3 0) ;; Strobe + (set-chan8 4 0) ;; Mode (0-15 = direct control) + (set-chan8 5 (percent->dmxval8 (get-attr intensity)))) diff --git a/guile/starlet/fixture-library/stairville/z120m.scm b/guile/starlet/fixture-library/stairville/z120m.scm new file mode 100644 index 0000000..00fb476 --- /dev/null +++ b/guile/starlet/fixture-library/stairville/z120m.scm @@ -0,0 +1,69 @@ +;; +;; starlet/fixture-library/stairville/z120m.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet fixture-library stairville z120m) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<stairville-z120m-6ch>)) + + +(define (colour-as-rgbw-weirdness col weirdness) + (let ((rgb (colour-as-rgb col))) + (let ((w (* (- 1 weirdness) (apply min rgb)))) + (list (- (red rgb) w) + (- (green rgb) w) + (- (blue rgb) w) + w)))) + + +(define-fixture + + <stairville-z120m-6ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white) + (attr-continuous strobe-frequency '(1 25) 1) + (attr-list strobe '(off on random) 'off) + (attr-continuous white-weirdness '(0 100) 0)) + + (let ((intensity (get-attr intensity)) + (rgbw (colour-as-rgbw-weirdness (get-attr colour) + (/ (get-attr white-weirdness) 100)))) + (set-chan8 1 (percent->dmxval8 intensity)) + (set-chan8 3 (percent->dmxval8 (car rgbw))) + (set-chan8 4 (percent->dmxval8 (cadr rgbw))) + (set-chan8 5 (percent->dmxval8 (caddr rgbw))) + (set-chan8 6 (percent->dmxval8 (cadddr rgbw)))) + (cond + ((eq? (get-attr strobe) 'on) + (set-chan8 2 (scale-and-clamp-to-range + (get-attr 'strobe-frequency) + '(1 25) + '(106 165)))) + ((eq? (get-attr strobe) 'random) + (set-chan8 2 (scale-and-clamp-to-range + (get-attr strobe-frequency) + '(1 25) + '(181 240)))) + (else (set-chan8 2 255)))) diff --git a/guile/starlet/fixture-library/tadm/led-bar.scm b/guile/starlet/fixture-library/tadm/led-bar.scm index a04ed5e..45c4e34 100644 --- a/guile/starlet/fixture-library/tadm/led-bar.scm +++ b/guile/starlet/fixture-library/tadm/led-bar.scm @@ -1,7 +1,7 @@ ;; ;; starlet/fixture-library/tadm/led-bar.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -19,24 +19,24 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library tadm led-bar) - #:use-module (oop goops) + #:use-module (starlet scanout) #:use-module (starlet fixture) + #:use-module (starlet attributes) #:use-module (starlet colours) + #:use-module (starlet utils) + #:use-module (starlet attributes) #:export (<tadm-led-bar>)) +(define-fixture -(define-class <tadm-led-bar> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-colour 'colour white)))) + <tadm-led-bar> + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) -(define-method (scanout-fixture (fixture <tadm-led-bar>) - get-attr set-chan8 set-chan16) - - (let ((intensity (get-attr 'intensity)) - (rgb (colour-as-rgb (get-attr 'colour)))) + (let ((intensity (get-attr intensity)) + (rgb (colour-as-rgb (get-attr colour)))) (set-chan8 1 17) (set-chan8 2 (percent->dmxval8 intensity)) (set-chan8 3 0) diff --git a/guile/starlet/fixture-library/tadm/led-foh.scm b/guile/starlet/fixture-library/tadm/led-foh.scm deleted file mode 100644 index 18ad15f..0000000 --- a/guile/starlet/fixture-library/tadm/led-foh.scm +++ /dev/null @@ -1,46 +0,0 @@ -;; -;; starlet/fixture-library/tadm/led-foh.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(define-module (starlet fixture-library tadm led-foh) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:export (<tadm-led-foh>)) - - -(define-class <tadm-led-foh> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-colour 'colour white)))) - - -(define-method (scanout-fixture (fixture <tadm-led-foh>) - get-attr set-chan8 set-chan16) - - (let ((intensity (get-attr 'intensity)) - (rgb (colour-as-rgb (get-attr 'colour)))) - (set-chan8 1 (percent->dmxval8 intensity)) - (set-chan8 2 255) - (set-chan8 3 (percent->dmxval8 (car rgb))) - (set-chan8 4 (percent->dmxval8 (cadr rgb))) - (set-chan8 5 (percent->dmxval8 (caddr rgb))) - (set-chan8 6 0))) - diff --git a/guile/starlet/fixture.scm b/guile/starlet/fixture.scm index 9f58f25..524d78b 100644 --- a/guile/starlet/fixture.scm +++ b/guile/starlet/fixture.scm @@ -20,7 +20,10 @@ ;; (define-module (starlet fixture) #:use-module (starlet colours) + #:use-module (starlet utils) + #:use-module (starlet attributes) #:use-module (oop goops) + #:use-module (ice-9 exceptions) #:use-module (srfi srfi-1) #:export (<fixture> get-fixture-name @@ -28,23 +31,24 @@ get-fixture-universe get-fixture-attrs find-attr + fixture-has-attr? + fixture? scanout-fixture attr-continuous attr-list attr-colour + define-fixture + get-attr-type get-attr-range get-attr-home-val continuous-attribute? colour-attribute? - intensity? - scale-to-range - round-dmx - percent->dmxval8 - percent->dmxval16)) + next-attr-item + prev-attr-item)) (define-class <fixture-attribute> (<object>) @@ -66,7 +70,12 @@ (home-value #:init-value 0 #:init-keyword #:home-value - #:getter attr-home-value)) + #:getter attr-home-value) + + (comment + #:init-value "" + #:init-keyword #:comment + #:getter attr-comment)) (define-class <fixture> (<object>) @@ -87,23 +96,21 @@ #:getter get-fixture-addr #:setter set-fixture-addr!) - (friendly-name - #:init-value "Fixture" - #:init-keyword #:friendly-name - #:getter get-fixture-friendly-name - #:setter set-fixture-friendly-name!) - (scanout-func #:init-value (lambda (universe start-addr value set-dmx) #f) #:init-keyword #:scanout-func #:getter get-scanout-func)) -(define-generic scanout-fixture) - - (define-syntax attr-continuous (syntax-rules () + ((_ attr-name attr-range attr-home-value comment) + (make <fixture-attribute> + #:name attr-name + #:range attr-range + #:type 'continuous + #:home-value attr-home-value + #:comment comment)) ((_ attr-name attr-range attr-home-value) (make <fixture-attribute> #:name attr-name @@ -119,11 +126,24 @@ #:name attr-name #:range attr-allowed-values #:type 'list - #:home-value attr-home-value)))) + #:home-value attr-home-value)) + ((_ attr-name attr-allowed-values attr-home-value comment) + (make <fixture-attribute> + #:name attr-name + #:range attr-allowed-values + #:type 'list + #:home-value attr-home-value + #:comment comment)))) (define-syntax attr-colour (syntax-rules () + ((_ attr-name attr-home-value comment) + (make <fixture-attribute> + #:name attr-name + #:type 'colour + #:home-value attr-home-value + #:comment comment)) ((_ attr-name attr-home-value) (make <fixture-attribute> #:name attr-name @@ -131,6 +151,9 @@ #:home-value attr-home-value)))) +(define-generic scanout-fixture) + + (define (get-fixture-attrs fix) (slot-ref fix 'attributes)) @@ -139,34 +162,20 @@ (is-a? f <fixture>)) -(define-method (find-attr (fix <fixture>) (attr-name <symbol>)) +(define (find-attr fix attr-name) (find (lambda (a) (eq? (get-attr-name a) attr-name)) (get-fixture-attrs fix))) -(define-method (find-attr (fix <fixture>) (attr-name <colour-component-id>)) - (find-attr fix 'colour)) - - -(define-method (get-attr-home-val (fix <fixture>) (attr <symbol>)) +(define (get-attr-home-val fix attr) (let ((attr-obj (find-attr fix attr))) (if attr-obj (attr-home-value attr-obj) 'fixture-does-not-have-attribute))) -(define-method (get-attr-home-val (fix <fixture>) (attr <colour-component-id>)) - (extract-colour-component - (get-attr-home-val fix 'colour) - attr)) - - -(define (intensity? a) - (eq? 'intensity a)) - - (define (continuous-attribute? aobj) (eq? 'continuous (get-attr-type aobj))) @@ -177,28 +186,30 @@ (get-attr-type aobj))) -;; Helper functions for fixture scanout routines -(define (percent->dmxval8 val) - (round-dmx - (scale-to-range val '(0 100) '(0 255)))) - +(define-syntax define-fixture + (syntax-rules (fixture-attributes) -(define (percent->dmxval16 val) - (scale-to-range val '(0 100) '(0 65535))) + ((_ classname + (fixture-attributes attr ...) + scanout-code ...) + (begin + (define-class classname (<fixture>) + (attributes #:init-form (list attr ...))) + (define-method (scanout-fixture (fixture classname)) + scanout-code ...))))) -(define (round-dmx a) - (inexact->exact - (min 255 (max 0 (round a))))) +(define fixture-has-attr? find-attr) -(define (scale-to-range val orig-range dest-range) - (define (range r) - (- (cadr r) (car r))) +(define (next-attr-item attr cval) + (next-item-in-list + (get-attr-range attr) + cval)) - (+ (car dest-range) - (* (range dest-range) - (/ (- val (car orig-range)) - (range orig-range))))) +(define (prev-attr-item attr cval) + (next-item-in-list + (reverse (get-attr-range attr)) + cval)) diff --git a/guile/starlet/midi-control/base.scm b/guile/starlet/midi-control/base.scm deleted file mode 100644 index bed1a1f..0000000 --- a/guile/starlet/midi-control/base.scm +++ /dev/null @@ -1,294 +0,0 @@ -;; -;; starlet/midi-control/base.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(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 - 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 <midi-control-surface> (<object>) - (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 <midi-callback> (<object>) - (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 <midi-callback> - #: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 <midi-control-surface> - #: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)))) diff --git a/guile/starlet/midi-control/button-utils.scm b/guile/starlet/midi-control/button-utils.scm deleted file mode 100644 index 8462e3e..0000000 --- a/guile/starlet/midi-control/button-utils.scm +++ /dev/null @@ -1,93 +0,0 @@ -;; -;; starlet/midi-control/button-utils.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(define-module (starlet midi-control button-utils) - #:use-module (starlet midi-control base) - #:use-module (starlet state) - #:use-module (starlet playback) - #: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)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (go! pb))) - - (when (or ready-note pause-note) - (add-hook! - (state-change-hook pb) - (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))))))) - - -(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 e5f9cd4..0000000 --- a/guile/starlet/midi-control/faders.scm +++ /dev/null @@ -1,361 +0,0 @@ -;; -;; starlet/midi-control/faders.scm -;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> -;; -;; 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 <http://www.gnu.org/licenses/>. -;; -(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 scanout) - #:use-module (starlet utils) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (oop goops) - #:export (set-midi-control-map! - state-on-fader)) - - -(define-class <parameter-controller> (<object>) - (callbacks - #:init-keyword #:callbacks - #:getter get-callbacks - #:setter set-callbacks!) - - (control-map - #:init-keyword #:control-map - #:getter get-control-map)) - - -(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) - (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 - - ((eq? 'jogwheel (cadr control-spec)) - (at-midi-jogwheel controller - fixture-list - (car control-spec) - (caddr control-spec) - #:led (cadddr control-spec))) - - ((eq? 'fader (cadr control-spec)) - (at-midi-fader controller - fixture-list - (car control-spec) - (caddr control-spec) - #:led (car (cadddr control-spec)) - #:led-incongruent (cadr (cadddr 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 (control-spec) - (led-off controller (cadddr control-spec))) - (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 <parameter-controller> - #: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 (fix attr value 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)))))) diff --git a/guile/starlet/open-sound-control/utils.scm b/guile/starlet/open-sound-control/utils.scm new file mode 100644 index 0000000..567c2b3 --- /dev/null +++ b/guile/starlet/open-sound-control/utils.scm @@ -0,0 +1,467 @@ +;; +;; starlet/open-sound-control/utils.scm +;; +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet open-sound-control utils) + #:use-module (starlet attributes) + #:use-module (starlet playback) + #:use-module (starlet selection) + #:use-module (starlet fixture) + #:use-module (starlet engine) + #:use-module (starlet state) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:use-module (open-sound-control client) + #:use-module (open-sound-control server-thread) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 receive) + #:export (osc-playback-controls + osc-select-button + osc-parameter-encoder + osc-smart-potentiometer + osc-cmy-potentiometer + osc-state-fader + send-selection-updates-to)) + + +(define* (osc-playback-controls pb server addr go-button stop-button back-button + #:key (min-time-between-presses 0.2)) + + (let ((time-last-press 0)) + (add-osc-method + server + (string-append go-button "/press") + "" + (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))))) + + (add-osc-method server (string-append stop-button "/press") "" (lambda () (stop! pb))) + (add-osc-method server (string-append back-button "/press") "" (lambda () (back! pb))) + + ;; LEDs + (osc-send addr (string-append back-button "/set-led") 'green) + + (add-and-run-hook! + (state-change-hook pb) + (lambda (new-state) + + (if (eq? new-state 'running) + (osc-send addr (string-append stop-button "/set-led") 'green) + (osc-send addr (string-append stop-button "/set-led") 'off)) + + (cond + ((eq? new-state 'pause) + (osc-send addr (string-append go-button "/set-led") 'orange)) + ((eq? new-state 'ready) + (osc-send addr (string-append go-button "/set-led") 'green)) + ((eq? new-state 'running) + (osc-send addr (string-append go-button "/set-led") 'green)) + (else + (osc-send addr (string-append go-button "/set-led") 'off)))) + + (playback-state pb))) + + +(define (osc-select-button fix server addr button) + + (add-osc-method + server + (string-append button "/press") + "" + (lambda () + (toggle-sel fix))) + + (add-and-run-hook! + selection-hook + (lambda (sel) + (if (selected? fix) + (osc-send addr (string-append button "/set-led") 'orange) + (osc-send addr (string-append button "/set-led") 'red))) + (get-selection))) + + +(define (encoder-inc attr-id n) + (for-each + (lambda (fix) + (let ((attr (find-attr fix attr-id)) + (cval (current-value fix attr-id))) + (cond + ((eq? 'continuous (get-attr-type attr)) + (at fix attr-id (+ cval n))) + ((eq? 'list (get-attr-type attr)) + (if (> n 0) + (at fix attr-id (next-attr-item attr cval)) + (at fix attr-id (prev-attr-item attr cval))))))) + (get-selection))) + + +(define (osc-parameter-encoder attr server addr encoder) + + (add-osc-method server (string-append encoder "/inc") "" + (lambda () (encoder-inc attr 3))) + + (add-osc-method server (string-append encoder "/dec") "" + (lambda () (encoder-inc attr -3))) + + (add-osc-method server (string-append encoder "/inc-fine") "" + (lambda () (encoder-inc attr 1))) + + (add-osc-method server (string-append encoder "/dec-fine") "" + (lambda () (encoder-inc attr -1))) + + (add-and-run-hook! + selection-hook + (lambda (sel) + (if (any + (lambda (fix) + (fixture-has-attr? fix attr)) + (get-selection)) + (osc-send addr (string-append encoder "/set-led") 'green) + (osc-send addr (string-append encoder "/set-led") 'off))) + (get-selection))) + + +(define (ccval->percent n) + (/ (* n 100) 127)) + + +(define (osc-state-fader server addr fader state) + (let ((fader-val 0)) + (register-state! + (lighting-state + (state-for-each + (lambda (fix attr val) + (at fix attr + (lambda () + + (if (intensity? attr) + + ;; Intensity parameters get scaled according to the fader + (* 0.01 val (ccval->percent fader-val)) + + ;; Non-intensity parameters just get set in our new state, + ;; but only if the fader is up! + (if (> fader-val 0) + val + 'no-value))))) + state))) + + (osc-send addr (string-append fader "/enable")) + (osc-send addr (string-append fader "/set-pickup") 0) + (add-osc-method server (string-append fader "/value-change") "i" + (lambda (v) (set! fader-val v))))) + + +(define (send-selection-updates-to addr) + (add-hook! + selection-hook + (lambda (sel) + (osc-send + addr + "/starlet/selection/update" + (get-selection-as-string))))) + + +(define (fader-up-gradients initial-vals + max-vals + congruent-val) + (map (lambda (initial-val attr-max) + (if (< congruent-val 127) + (/ (- attr-max initial-val) + (- 127 congruent-val)) + 0)) + initial-vals + max-vals)) + + +(define (fader-down-gradients initial-vals + min-vals + congruent-val) + (map (lambda (initial-val attr-min) + (if (> congruent-val 0) + (/ (- initial-val attr-min) + congruent-val) + 0)) + initial-vals + min-vals)) + + +(define (fixtures-with-attr fixture-list attr-name) + (let ((fix-attrs + (map (lambda (fix) + (let ((attr (find-attr fix attr-name))) + (if attr + (cons fix attr) + (cons #f #f)))) + fixture-list))) + (values + (filter (lambda (x) x) (map car fix-attrs)) + (filter (lambda (x) x) (map cdr fix-attrs))))) + + +(define (current-values fixture-list attr-name) + (map (lambda (fix) + (current-value fix attr-name)) + fixture-list)) + + +(define-record-type <smart-potentiometer> + (smart-pot-record addr + pot-method + initial-vals + min-vals + max-vals + congruent-val + up-gradients + dn-gradients) + smart-pot? + (addr get-target-addr) + (pot-method get-method) + (initial-vals get-initial-vals set-initial-vals) + (min-vals get-min-vals set-min-vals) + (max-vals get-max-vals set-max-vals) + (congruent-val get-congruent-val set-congruent-val) + (up-gradients get-up-gradients set-up-gradients) + (dn-gradients get-dn-gradients set-dn-gradients)) + + +(define (make-smart-potentiometer server addr pot-method callback) + + (let ((sp (smart-pot-record addr pot-method '() '() '() 0 '() '()))) + + (add-osc-method + server + (string-append pot-method "/value-change") + "i" + (lambda (new-cc-value) + (callback + (map + (lambda (initial-val gradient) + (+ initial-val + (* gradient + (- new-cc-value (get-congruent-val sp))))) + (get-initial-vals sp) + (if (> new-cc-value (get-congruent-val sp)) + (get-up-gradients sp) + (get-dn-gradients sp)))))) + + sp)) + + +(define (reset-gradients sp) + (unless (nil? (get-initial-vals sp)) + (set-congruent-val sp + (mean + (map + (lambda (val min-val max-val) + (scale-to-range val (list min-val max-val) '(0 127))) + (get-initial-vals sp) + (get-min-vals sp) + (get-max-vals sp)))) + (set-up-gradients sp + (fader-up-gradients + (get-initial-vals sp) + (get-max-vals sp) + (get-congruent-val sp))) + (set-dn-gradients sp + (fader-up-gradients + (get-initial-vals sp) + (get-min-vals sp) + (get-congruent-val sp))) + (osc-send + (get-target-addr sp) + (string-append (get-method sp) "/set-pickup") + (get-congruent-val sp)))) + + +(define (osc-smart-potentiometer attr-name + server + addr + potentiometer) + + (let ((fixtures '())) + + ;; First, create a smart potentiometer object and tell it to + ;; set the attribute values in the programmer state + (let ((smart-pot + (make-smart-potentiometer + server + addr + potentiometer + (lambda (new-vals) + (for-each + (lambda (fix new-val) + (set-in-state! programmer-state + fix + attr-name + new-val + potentiometer)) + fixtures new-vals))))) + + ;; Next, set up a selection hook callback to update the list of + ;; fixtures we are controlling + (add-and-run-hook! + selection-hook + (lambda (selection) + (receive + (new-fixtures attrs) + (fixtures-with-attr selection attr-name) + (if (nil? new-fixtures) + (osc-send addr (string-append potentiometer "/disable")) + (begin + (set! fixtures new-fixtures) + (let ((ranges (map get-attr-range attrs))) + (set-min-vals smart-pot (map first ranges)) + (set-max-vals smart-pot (map second ranges))) + (set-initial-vals smart-pot (current-values fixtures attr-name)) + (reset-gradients smart-pot) + (osc-send addr (string-append potentiometer "/enable")))))) + (get-selection)) + + ;; Finally, arrange for the smart potentiometer object to be notified + ;; if the values change externally + (add-update-hook! + programmer-state + (lambda (source) + (unless (eq? source potentiometer) + (set-initial-vals smart-pot (current-values fixtures attr-name)) + (reset-gradients smart-pot))))))) + + +(define (osc-cmy-potentiometer attr-name server addr c-pot-method m-pot-method y-pot-method) + + (let ((fixtures '()) + (colours '())) + + (let ((c-pot + (make-smart-potentiometer + server + addr + c-pot-method + (lambda (new-vals) + (set! colours + (map + (lambda (old-colour new-c) + (cmy new-c + (magenta old-colour) + (yellow old-colour))) + (map colour-as-cmy colours) new-vals)) + (for-each + (lambda (fix colour) + (set-in-state! programmer-state + fix + attr-name + colour + c-pot-method)) + fixtures colours)))) + + (m-pot + (make-smart-potentiometer + server + addr + m-pot-method + (lambda (new-vals) + (set! colours + (map + (lambda (old-colour new-m) + (cmy (cyan old-colour) + new-m + (yellow old-colour))) + (map colour-as-cmy colours) new-vals)) + (for-each + (lambda (fix colour) + (set-in-state! programmer-state + fix + attr-name + colour + m-pot-method)) + fixtures colours)))) + + (y-pot + (make-smart-potentiometer + server + addr + y-pot-method + (lambda (new-vals) + (set! colours + (map + (lambda (old-colour new-y) + (cmy (cyan old-colour) + (magenta old-colour) + new-y)) + (map colour-as-cmy colours) new-vals)) + (for-each + (lambda (fix colour) + (set-in-state! programmer-state + fix + attr-name + colour + y-pot-method)) + fixtures colours))))) + + (add-and-run-hook! + selection-hook + (lambda (selection) + (receive + (new-fixtures attrs) + (fixtures-with-attr selection attr-name) + (if (nil? new-fixtures) + (begin + (osc-send addr (string-append c-pot-method "/disable")) + (osc-send addr (string-append m-pot-method "/disable")) + (osc-send addr (string-append y-pot-method "/disable"))) + (begin + (set! fixtures new-fixtures) + (set-min-vals c-pot (map (lambda (x) 0) fixtures)) + (set-min-vals m-pot (map (lambda (x) 0) fixtures)) + (set-min-vals y-pot (map (lambda (x) 0) fixtures)) + (set-max-vals c-pot (map (lambda (x) 100) fixtures)) + (set-max-vals m-pot (map (lambda (x) 100) fixtures)) + (set-max-vals y-pot (map (lambda (x) 100) fixtures)) + (set! colours (current-values fixtures attr-name)) + (set-initial-vals c-pot (map cyan (map colour-as-cmy colours))) + (set-initial-vals m-pot (map magenta (map colour-as-cmy colours))) + (set-initial-vals y-pot (map yellow (map colour-as-cmy colours))) + (reset-gradients c-pot) + (reset-gradients m-pot) + (reset-gradients y-pot) + (osc-send addr (string-append c-pot-method "/enable")) + (osc-send addr (string-append m-pot-method "/enable")) + (osc-send addr (string-append y-pot-method "/enable")))))) + (get-selection)) + + (add-update-hook! + programmer-state + (lambda (source) + (unless (or (eq? source c-pot-method) + (eq? source m-pot-method) + (eq? source y-pot-method)) + (set! colours (current-values fixtures attr-name)) + (set-initial-vals c-pot (map cyan (map colour-as-cmy colours))) + (set-initial-vals m-pot (map magenta (map colour-as-cmy colours))) + (set-initial-vals y-pot (map yellow (map colour-as-cmy colours))) + (reset-gradients c-pot) + (reset-gradients m-pot) + (reset-gradients y-pot))))))) diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm index 10a5848..423abd2 100644 --- a/guile/starlet/playback.scm +++ b/guile/starlet/playback.scm @@ -30,13 +30,14 @@ #:use-module (srfi srfi-43) #:use-module (starlet fixture) #:use-module (starlet state) - #:use-module (starlet scanout) + #:use-module (starlet engine) #:use-module (starlet utils) #:use-module (starlet clock) + #:use-module (starlet cue-list) + #:use-module (starlet cue-part) #:use-module (starlet colours) + #:use-module (starlet attributes) #:export (make-playback - cue - cue-part cut-to-cue-number! get-playback-cue-number run-cue-number! @@ -44,12 +45,10 @@ cut! stop! back! - cue-list reload-cue-list! reassert-current-cue! - print-playback state-change-hook - current-cue-clock)) + playback-state)) ;; A "playback" is a state which knows how to run cues @@ -65,6 +64,10 @@ #:getter get-playback-cue-list-file #:setter set-playback-cue-list-file!) + (recovery-file + #:init-keyword #:recovery-file + #:getter get-playback-recovery-file) + (next-cue-index #:init-value 0 #:getter get-next-cue-index @@ -89,54 +92,6 @@ #:getter state-change-hook)) -(define-record-type <cue-part> - (make-cue-part attr-list - fade-times) - cue-part? - (attr-list get-cue-part-attr-list) - (fade-times get-cue-part-fade-times)) - - -(define-record-type <fade-times> - (make-fade-times up-time - down-time - attr-time - up-delay - down-delay - attr-delay) - fade-times? - (up-time get-fade-up-time) - (down-time get-fade-down-time) - (attr-time get-fade-attr-time) - (up-delay get-fade-up-delay) - (down-delay get-fade-down-delay) - (attr-delay get-fade-attr-delay)) - - -(define-record-type <cue> - (make-cue number - state - tracked-state - preset-state - fade-times - preset-time - track-intensities - cue-parts - cue-clock) - cue? - (number get-cue-number) - (state get-cue-state) - (tracked-state get-tracked-state - set-tracked-state!) - (preset-state get-preset-state - set-preset-state!) - (fade-times get-cue-fade-times) - (preset-time get-cue-preset-time) - (track-intensities track-intensities) - (cue-parts get-cue-parts) - (cue-clock get-cue-clock)) - - (define (get-playback-cue-number pb) (let ((cue-idx (get-next-cue-index pb))) (if cue-idx @@ -144,16 +99,6 @@ (max 0 (- cue-idx 1))) #f))) -(define (qnum a) - (/ (inexact->exact (* a 1000)) 1000)) - - -(define (read-cue-list-file filename) - (call-with-input-file - filename - (lambda (port) - (eval (read port) (interaction-environment))))) - (define (reload-cue-list! pb) (let ((filename (get-playback-cue-list-file pb))) @@ -177,29 +122,52 @@ 'playback-without-cue-list-file))) +(define (read-recovery-file! pb) + (with-exception-handler + (lambda (exn) + (display "Failed to read recovery file - going to cue zero\n") + (cut-to-cue-index! pb 0)) + (lambda () + (call-with-input-file + (get-playback-recovery-file pb) + (lambda (port) + (let ((val (read port))) + (if (number? val) + (cut-to-cue-number! pb val) + (cut-to-cue-index! pb 0)))))) + #:unwind? #t)) + + +(define (write-recovery-file! pb the-cue-number) + (with-exception-handler + (lambda (exn) + (display "Failed to write recovery file (just FYI)\n") + (display exn)) + (lambda () + (call-with-output-file + (get-playback-recovery-file pb) + (lambda (port) + (write (qnum the-cue-number) port)))) + #:unwind? #t)) + + (define* (make-playback #:key (cue-list-file #f) - (cue-list #f)) + (cue-list #f) + (recovery-file #f)) (let ((new-playback (make <starlet-playback> #:cue-list (if cue-list-file (read-cue-list-file cue-list-file) cue-list) - #:cue-list-file cue-list-file))) + #:cue-list-file cue-list-file + #:recovery-file recovery-file))) (register-state! new-playback) + (if recovery-file + (read-recovery-file! new-playback) + (cut-to-cue-index! new-playback 0)) new-playback)) -(define (cue-index-to-number cue-list cue-index) - (get-cue-number (vector-ref cue-list cue-index))) - - -(define (cue-number-to-index cue-list cue-number) - (vector-index (lambda (a) - (eqv? (get-cue-number a) - cue-number)) - cue-list)) - - (define (set-playback-state! pb state) (atomic-box-set! (state-box pb) state) (run-hook (state-change-hook pb) state)) @@ -212,19 +180,24 @@ (set-running-cue! pb #f) (set-playback-state! pb 'ready) - ;; Set the actual state - (state-for-each - (lambda (fix attr val) - (set-in-state! pb fix attr (lambda () val))) - (get-tracked-state (vector-ref (get-playback-cue-list pb) - cue-index))) + (let ((the-cue (vector-ref (get-playback-cue-list pb) + cue-index))) + ;; Set the actual state + (for-each + (lambda (part) + (state-for-each + (lambda (fix attr val) + (set-in-state! pb fix attr (lambda () val))) + (get-cue-part-state part))) + (get-cue-parts the-cue)) - ;; Set the preset state on top - (state-for-each - (lambda (fix attr val) - (set-in-state! pb fix attr (lambda () val))) - (get-preset-state (vector-ref (get-playback-cue-list pb) - cue-index)))) + ;; Set the preset state on top + (state-for-each + (lambda (fix attr val) + (set-in-state! pb fix attr (lambda () val))) + (get-preset-state the-cue)) + + (write-recovery-file! pb (get-cue-number the-cue)))) (define (cut-to-cue-number! pb cue-number) @@ -285,7 +258,12 @@ (define (cut! pb) - (cut-to-cue-index! pb (get-next-cue-index pb))) + (let ((nci (get-next-cue-index pb))) + (if nci + (if (< nci (vector-length (get-playback-cue-list pb))) + (cut-to-cue-index! pb (get-next-cue-index pb)) + 'no-more-cues-in-list) + 'next-cue-unspecified))) (define (stop! pb) @@ -306,456 +284,113 @@ 'next-cue-unspecified)) -(define (snap-fade start-val - target-val - clock) - (if (> (elapsed-fraction clock) 0) - target-val - start-val)) - - -(define (colour-fade start-val - end-val - clock) - - (unless (and (colour? start-val) - (colour? end-val)) - (raise-exception (make-exception - (make-exception-with-message - "Non-colour arguments given to colour-fade") - (make-exception-with-irritants - (list start-val end-val))))) - - (interpolate-colour start-val - end-val - (elapsed-fraction clock) - #:interpolation-type 'linear-cmy)) - - -(define (simple-fade start-val - end-val - clock) - - (unless (and (number? start-val) - (number? end-val)) - (raise-exception (make-exception - (make-exception-with-message - "Non-number arguments given to simple-fade") - (make-exception-with-irritants - (list start-val end-val))))) - - (+ start-val - (* (- end-val start-val) - (elapsed-fraction clock)))) - - -(define (replace-noval val replacement) - (if (eq? 'no-value val) replacement val)) - - -(define (make-intensity-fade prev-val - target-val-in - up-clock - down-clock) - (let ((target-val (replace-noval target-val-in 0.0))) - - (cond - - ;; Number to number, fading up - ((and (number? target-val) - (number? prev-val) - (> target-val prev-val)) - (lambda () - (simple-fade prev-val - target-val - up-clock))) - - ;; Number to number, fading down - ((and (number? target-val) - (number? prev-val) - (< target-val prev-val)) - (lambda () - (simple-fade prev-val - target-val - down-clock))) - - ;; Number to number, staying the same - ;; NB We still need a static value so that fade-start-val can "unwrap" it - ((and (number? target-val) - (number? prev-val)) - (lambda () prev-val)) - - ;; Everything else, e.g. number to effect - (else - (lambda () - (max - (simple-fade (value->number prev-val) - 0 - down-clock) - (simple-fade 0 - (value->number target-val) - up-clock))))))) - - -(define (make-list-attr-fade start-val - target-val - clock) - (lambda () - (snap-fade start-val - target-val - clock))) - - -(define (make-general-fade fade-func - start-val - target-val - clock) - - (if (and (not (procedure? target-val)) - (not (eq? target-val 'no-value)) - (not (eq? start-val 'no-value))) - - ;; It makes sense to do a fade - (let ((real-start-val (value->number start-val))) - (lambda () - (fade-func real-start-val - target-val - clock))) - - ;; A fade doesn't make sense, so make do with a snap transition - (lambda () - (snap-fade start-val - target-val - clock)))) - - -(define (match-fix-attr attr-el fix attr) - (cond - - ((fixture? attr-el) - (eq? attr-el fix)) - - ((and (pair? attr-el) - (fixture? (car attr-el)) - (symbol? (cdr attr-el))) - (and (eq? (car attr-el) fix) - (eq? (cdr attr-el) attr))) - - ((list? attr-el) - (and (memq fix attr-el) - (memq attr attr-el))) - - (else #f))) - - -(define (in-cue-part? cue-part fix attr) - (find (lambda (p) (match-fix-attr p fix attr)) - (get-cue-part-attr-list cue-part))) - - -(define (cue-part-fade-times the-cue fix attr) - - (let ((the-cue-part - (find (lambda (p) (in-cue-part? p fix attr)) - (get-cue-parts the-cue)))) - - (if (cue-part? the-cue-part) - (get-cue-part-fade-times the-cue-part) - (get-cue-fade-times the-cue)))) - - -(define (fade-start-val pb fix attr) - (let ((val-in-pb (state-find fix attr pb))) - (if (eq? val-in-pb 'no-value) - - ;; Not currently in playback - fade from home value - (get-attr-home-val fix attr) - - ;; Currently in playback - fade from current value - ;; by running the outer crossfade function - (val-in-pb)))) - - -(define (dark? a) - (or (eq? a 'no-value) - (and (number? a) - (< a 1)))) - - -(define (longest-fade-time fade-times) - (max - (+ (get-fade-down-time fade-times) - (get-fade-down-delay fade-times)) - (+ (get-fade-up-time fade-times) - (get-fade-up-delay fade-times)) - (+ (get-fade-attr-time fade-times) - (get-fade-attr-delay fade-times)))) - - -;; Work out how long it will take before we can forget about this cue -(define (cue-total-time the-cue) - (let ((fade-times (cons (get-cue-fade-times the-cue) - (map get-cue-part-fade-times - (get-cue-parts the-cue))))) - (fold max - 0 - (map longest-fade-time fade-times)))) - - -(define (fix-attr-eq fa1 fa2) - (and (eq? (car fa1) (car fa2)) - (eq? (cdr fa1) (cdr fa2)))) - - -(define (fix-attrs-in-state state) - (state-map (lambda (fix attr val) (cons fix attr)) - state)) - - -(define (add-fix-attrs-to-list state old-list) - (lset-union fix-attr-eq - old-list - (fix-attrs-in-state state))) - - -(define (fix-attrs-involved . states) - (fold add-fix-attrs-to-list '() states)) - - -(define (make-fade-for-attribute-type type) - (cond - ((eq? type 'continuous) (cut make-general-fade simple-fade <...>)) - ((eq? type 'list) make-list-attr-fade) - ((eq? type 'colour) (cut make-general-fade colour-fade <...>)) - (else - (raise-exception (make-exception - (make-exception-with-message - "Unrecognised attribute type") - (make-exception-with-irritants type)))))) +(define (blank-everything state) + (state-map + (lambda (fix attr val) + (if (intensity? attr) + 0.0 + 'no-value)) + state)) (define (run-cue-index! pb cue-index) (let* ((the-cue (vector-ref (get-playback-cue-list pb) cue-index)) - (this-cue-state (get-tracked-state the-cue)) (overlay-state (make-empty-state)) - (cue-clock (get-cue-clock the-cue))) - + (cue-clock (get-cue-clock the-cue)) + (fade-time 0)) + + ;; Start by fading the previous contents of the playback down, using the + ;; "main" transition effect + (receive + (overlay-part transition-time) + ((get-cue-part-transition + (car (get-cue-parts the-cue))) + (blank-everything pb) + pb + cue-clock) + (atomically-overlay-state! + overlay-state + overlay-part) + (set! fade-time transition-time)) + + ;; Stack all the cue parts on top (for-each - (lambda (fix-attr) - - (let* ((fix (car fix-attr)) - (attr (cdr fix-attr)) - (fade-times (cue-part-fade-times the-cue fix attr)) - - ;; The values for fading - (start-val (fade-start-val pb fix attr)) - (target-val (state-find fix attr this-cue-state)) - ;; The clocks for things in this cue part - (up-clock (make-delayed-clock cue-clock - (get-fade-up-delay fade-times) - (get-fade-up-time fade-times))) - - (down-clock (make-delayed-clock cue-clock - (get-fade-down-delay fade-times) - (get-fade-down-time fade-times))) - - (attribute-clock (make-delayed-clock cue-clock - (get-fade-attr-delay fade-times) - (get-fade-attr-time fade-times)))) - - (if (intensity? attr) - - ;; Intensity attribute - (set-in-state! overlay-state fix attr - (make-intensity-fade start-val - target-val - up-clock - down-clock)) - - ;; Non-intensity attribute - (let ((attribute-obj (find-attr fix attr))) - - (unless attribute-obj - (raise-exception (make-exception - (make-exception-with-message - "Attribute not found") - (make-exception-with-irritants - (list fix attr))))) - - (let* ((atype (get-attr-type attribute-obj)) - (make-fade-func (make-fade-for-attribute-type atype))) - - (set-in-state! overlay-state fix attr - (make-fade-func start-val - target-val - attribute-clock))))))) - - (fix-attrs-involved pb this-cue-state)) - + (lambda (part) + (receive + (overlay-part transition-time) + ((get-cue-part-transition part) + (get-cue-part-state part) + pb + cue-clock) + (atomically-overlay-state! + overlay-state + overlay-part) + (set! fade-time (max fade-time transition-time)))) + (get-cue-parts the-cue)) + + (set-clock-expiration-time! cue-clock fade-time) (atomically-overlay-state! pb overlay-state) (set-pb-cue-clock! pb cue-clock) (set-running-cue! pb the-cue) (reset-clock! cue-clock) (start-clock! cue-clock) - (set-playback-state! pb 'running))) + (set-playback-state! pb 'running) + (write-recovery-file! pb (get-cue-number the-cue)))) -(define (print-playback pb) - (format #t "Playback ~a:\n" pb) - ;;(format #t " Cue list ~a\n" (get-playback-cue-list pb)) - (if (get-next-cue-index pb) - (if (< (get-next-cue-index pb) - (vector-length (get-playback-cue-list pb))) - (let ((the-cue (vector-ref (get-playback-cue-list pb) - (get-next-cue-index pb)))) - (format #t " Next cue index ~a (~a)\n" - (get-next-cue-index pb) - the-cue)) - (format #t " End of cue list.\n")) - (format #t " Next cue index is unspecified.\n")) - *unspecified*) - - -;;; ******************** Cue lists ******************** - -(define-syntax cue-part - (syntax-rules () - ((_ (fixtures ...) params ...) - (make-cue-part-obj (list fixtures ...) - params ...)))) - - -(define* (make-cue-part-obj attr-list - #:key - (up-time 5) - (down-time 5) - (attr-time 0) - (up-delay 0) - (down-delay 0) - (attr-delay 0)) - (make-cue-part attr-list - (make-fade-times - up-time - down-time - attr-time - up-delay - down-delay - attr-delay))) - - -(define cue-proc - (lambda (number state . rest) - (receive (cue-parts rest-minus-cue-parts) - (partition cue-part? rest) - (let-keywords rest-minus-cue-parts #f - ((up-time 5) - (down-time 5) - (attr-time 0) - (up-delay 0) - (down-delay 0) - (attr-delay 0) - (preset-time 1) - (track-intensities #f)) - - (let ((the-cue (make-cue (qnum number) - state - #f ;; tracked state - #f ;; preset state - (make-fade-times - up-time - down-time - attr-time - up-delay - down-delay - attr-delay) - preset-time - track-intensities - cue-parts - (current-cue-clock)))) - - (set-clock-expiration-time! (current-cue-clock) - (cue-total-time the-cue)) - the-cue))))) - - -(define current-cue-clock (make-parameter #f)) - -(define-syntax cue - (syntax-rules () - ((_ body ...) - (parameterize ((current-cue-clock (make-clock #:stopped #t))) - (cue-proc body ...))))) - - -(define (track-all-cues! the-cue-list) - (vector-fold - (lambda (idx prev-state the-cue) - (let ((the-tracked-state (lighting-state - (apply-state prev-state) - (unless (track-intensities the-cue) - (blackout!)) - (apply-state (get-cue-state the-cue))))) - (set-tracked-state! the-cue the-tracked-state) - the-tracked-state)) - (make-empty-state) - the-cue-list)) - - -(define (fixture-dark-in-state? fix state) - (dark? (state-find fix 'intensity state))) - - -(define (preset-all-cues! the-cue-list) - (vector-fold-right - (lambda (idx next-state the-cue) - (let ((preset-state (make-empty-state))) - - (state-for-each - (lambda (fix attr val) - (unless (intensity? attr) - (when (fixture-dark-in-state? fix (get-tracked-state the-cue)) - (set-in-state! preset-state fix attr val)))) - next-state) - - (set-preset-state! the-cue preset-state)) +(define-method (num-cues (pb <starlet-playback>)) + (num-cues (get-playback-cue-list pb))) - ;; Pass the raw state from this cue to the previous one - (get-cue-state the-cue)) - (make-empty-state) - the-cue-list)) +(define (start-fixture-preset! pb) + (let ((st (get-preset-state (get-running-cue pb)))) + (state-for-each + (lambda (fix attr val) + (set-in-state! pb fix attr (lambda () val))) + st))) (define-method (update-state! (pb <starlet-playback>)) - (when (and (get-pb-cue-clock pb) - (clock-expired? (get-pb-cue-clock pb)) - (eq? 'running (atomic-box-ref (state-box pb)))) - (when (eq? 'running (atomic-box-compare-and-swap! (state-box pb) - 'running - 'ready)) - (run-hook (state-change-hook pb) 'ready) - (let ((st (get-preset-state (get-running-cue pb)))) - (state-for-each - (lambda (fix attr val) - (set-in-state! pb fix attr (lambda () val))) - st)) - (set-running-cue! pb #f)))) - - -(define-syntax cue-list - (syntax-rules () - ((_ body ...) - (let ((the-cue-list (vector (cue 0 - (make-empty-state) - #:up-time 0 - #:down-time 0 - #:attr-time 0 - #:preset-time 0) - body ...))) - (track-all-cues! the-cue-list) - (preset-all-cues! the-cue-list) - the-cue-list)))) + (when + (and (clock-expired? (get-pb-cue-clock pb)) + (eq? 'running (atomic-box-compare-and-swap! (state-box pb) + 'running + 'ready))) + (run-hook (state-change-hook pb) 'ready) + (start-fixture-preset! pb) + (set-running-cue! pb #f))) + + +(define (next-cue-number pb) + (let ((next-cue-index (get-next-cue-index pb)) + (the-cue-list (get-playback-cue-list pb))) + (if (< next-cue-index (vector-length the-cue-list)) + (exact->inexact + (cue-index-to-number + the-cue-list + next-cue-index)) + 'no-more-cues-in-list))) + + +(define (playback-state pb) + (atomic-box-ref (state-box pb))) + + +(define-method (write (pb <starlet-playback>) port) + (let ((cur-cue (get-playback-cue-number pb))) + (format port + "#<<starlet-playback> state: ~a current-cue: ~a next-cue: ~a>" + (playback-state pb) + (if cur-cue + (exact->inexact cur-cue) + 'current-cue-unspecified) + (if cur-cue + (next-cue-number pb) + 'next-cue-unspecified)))) (define (reassert-current-cue! pb) - (cut-to-cue-number! pb (get-playback-cue-number pb))) + (let ((cur-cue (get-playback-cue-number pb))) + (if cur-cue + (cut-to-cue-number! pb cur-cue) + 'current-cue-unspecified))) diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm index 4b7a2e1..69f3e9c 100644 --- a/guile/starlet/scanout.scm +++ b/guile/starlet/scanout.scm @@ -1,7 +1,7 @@ ;; ;; starlet/scanout.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -19,294 +19,140 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet scanout) + #:use-module (starlet engine) #:use-module (starlet fixture) #:use-module (starlet state) #:use-module (starlet utils) - #:use-module (starlet colours) + #:use-module (starlet attributes) #:use-module (starlet guile-ola) - #:use-module (oop goops) #:use-module (ice-9 threads) #:use-module (ice-9 atomic) #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:export (patch-fixture! - patch-many! - scanout-freq - total-num-attrs - register-state! - current-value - patched-fixture-names)) + #:export (scanout-freq + get-attr + set-chan8 + set-chan16)) -;; The list of patched fixtures -(define fixtures (make-atomic-box '())) - -;; List of states being scanned out -(define state-list (make-atomic-box '())) - -;; Association list of names to states -(define state-names (make-atomic-box '())) - - -(define (patched-fixture-names) - (map get-fixture-name (atomic-box-ref fixtures))) - - -(define (total-num-attrs) - (fold (lambda (fix prev) - (+ prev (length (get-fixture-attrs fix)))) - 0 - (atomic-box-ref fixtures))) - - -(define (get-state-name st) - (assq-ref (atomic-box-ref state-names) - st)) - - -(define (set-state-name! st name) - (atomic-box-set! state-names - (assq-set! (atomic-box-ref state-names) - st - name))) - - -;; Patch a new fixture -(define* (patch-real name - class - start-addr - #:key (universe 0) (friendly-name "Fixture")) - (let ((new-fixture (make class - #:name name - #:sa start-addr - #:uni universe - #:friendly-name friendly-name))) - (atomic-box-set! fixtures (cons new-fixture - (atomic-box-ref fixtures))) - new-fixture)) - - -(define-syntax patch-fixture! - (syntax-rules () - ((_ name stuff ...) - (define name (patch-real (quote name) stuff ...))))) - - -;; Patch several new fixtures -(define* (patch-many-real name - class - start-addrs - #:key (universe 0) (friendly-name "Fixture")) - (map (lambda (start-addr n) - (patch-real `(list-ref ,name ,n) - class - start-addr - #:universe universe - #:friendly-name friendly-name)) - start-addrs - (iota (length start-addrs)))) - - -(define-syntax patch-many! - (syntax-rules () - ((_ name stuff ...) - (define name (patch-many-real (quote name) stuff ...))))) - - -(define (state-has-fix-attr fix attr state) - (let ((val (state-find fix attr state))) - (if (eq? 'no-value val) - #f - (not (eq? 'no-value (value->number val)))))) - - -(define (first-val fix attr state-list) - (let ((first-state (find (lambda (state) - (state-has-fix-attr fix attr state)) - state-list))) - (if first-state - (state-find fix attr first-state) - 'no-value))) - - -(define-method (current-value (fix <fixture>) (attr-name <symbol>)) - (let ((programmer-val (state-find fix attr-name programmer-state))) - (if (eq? 'no-value programmer-val) - - ;; Look in the states - (if (intensity? attr-name) - - ;; HTP for intensity - (fold (lambda (state prev) - (let ((val (state-find fix attr-name state))) - (if (eq? 'no-value val) - prev - (let ((real-val (value->number val))) - (if (eq? 'no-value real-val) - prev - (max real-val prev)))))) - 0.0 - (atomic-box-ref state-list)) - - ;; Priority order for everything else - (let ((val (first-val fix attr-name (atomic-box-ref state-list)))) - (if (eq? 'no-value val) - (get-attr-home-val fix attr-name) - (value->number val)))) - - ;; Use programmer value, if we have it - (value->number programmer-val)))) - - -(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>)) - (let ((colour (current-value fix 'colour))) - (extract-colour-component colour attr-name))) - - -(define (append-or-replace-named-state orig-list name new-state) - (let ((new-list (map (lambda (st) - (if (eq? (get-state-name st) name) - (begin - new-state) - st)) - orig-list))) - - ;; If there is no state with this name in the list, - ;; the replacement above will have no effect. - ;; Check again and add in the normal way if so. - (if (find (lambda (st) (eq? (get-state-name st) - name)) - new-list) - new-list - (append orig-list (list new-state))))) +(define scanout-thread #f) +(define scanout-freq 0) +(define current-scanout-fixture (make-parameter #f)) +(define current-scanout-universe (make-parameter #f)) +(define current-scanout-addr (make-parameter #f)) +(define current-scanout-state (make-parameter (make-empty-state))) -(define* (register-state! new-state - #:key (unique-name #f)) - (if unique-name - (begin (set-state-name! new-state unique-name) - (atomic-box-set! state-list - (append-or-replace-named-state (atomic-box-ref state-list) - unique-name - new-state))) - (atomic-box-set! state-list - (append (atomic-box-ref state-list) - (list new-state))))) +(define (get-attr attr-name) + (let ((v (state-find (current-scanout-fixture) + attr-name + (current-scanout-state)))) + (if (eq? v 'no-value) + (get-attr-home-val (current-scanout-fixture) attr-name) + v))) -(define (msb val) - (round-dmx (euclidean-quotient val 256))) -(define (lsb val) - (round-dmx (euclidean-remainder val 256))) +(define (set-dmx universe addr value) + (ensure-number value (list universe addr value)) + ;; Create DMX array for universe if it doesn't exist already + (set-ola-dmx-buffer! universe + (- addr 1) ; OLA indexing starts from zero + (round-dmx value))) -(define (send-to-ola ola-client universe-buffer-pair) - (let ((uni (car universe-buffer-pair)) - (buf (cdr universe-buffer-pair))) - (send-streaming-dmx-data! ola-client uni buf))) +(define (set-chan8 relative-channel-number value) + (ensure-number + value + (list (current-scanout-fixture) + relative-channel-number + value)) + (set-dmx + (current-scanout-universe) + (+ (current-scanout-addr) + relative-channel-number + -1) + value)) -(define (ensure-number value irritating) - (unless (number? value) - (raise-exception (make-exception - (make-exception-with-message "Value is not a number") - (make-exception-with-irritants irritating))))) +(define (set-chan16 relative-channel-number value) + (ensure-number + value + (list (current-scanout-fixture) + relative-channel-number + value)) + (set-chan8 relative-channel-number (msb value)) + (set-chan8 (+ relative-channel-number 1) (lsb value))) -(define scanout-freq 0) -(define ola-thread #f) -(define (scanout-loop ola-client start-time count previous-universes) +(define (scanout-loop ola-client start-time previous-universes count) (let ((universes '())) - ;; Helper function for scanout functions to set individual DMX values - (define (set-dmx universe addr value) - (ensure-number value (list universe addr value)) + (parameterize + ((current-scanout-state (current-value-state))) + (for-each + (lambda (fix) - ;; Create DMX array for universe if it doesn't exist already - (unless (assq universe universes) - (set! universes (acons universe - (make-ola-dmx-buffer) - universes))) + ;; Ensure the DMX array exists for this fixture's universe + (unless (assq (get-fixture-universe fix) universes) + (set! universes (acons (get-fixture-universe fix) + (make-ola-dmx-buffer) + universes))) - (set-ola-dmx-buffer! (assq-ref universes universe) - (- addr 1) ; OLA indexing starts from zero - (round-dmx value))) + (parameterize + ((current-scanout-fixture fix) + (current-scanout-universe (assq-ref + universes + (get-fixture-universe fix))) + (current-scanout-addr (get-fixture-addr fix))) + (scanout-fixture fix))) - (for-each update-state! (atomic-box-ref state-list)) + (patched-fixtures))) (for-each - (lambda (fix) - - (let ((univ (get-fixture-universe fix)) - (addr (get-fixture-addr fix))) - - ;; Helper function to get a value for this - ;; fixture in the current state - (define (get-attr attr-name) - (current-value fix attr-name)) - - ;; Helper function to set 8-bit DMX value - (define (set-chan relative-channel-number value) - (ensure-number value (list fix relative-channel-number value)) - (set-dmx univ (+ addr relative-channel-number -1) value)) - - ;; Helper function to set 16-bit DMX value - (define (set-chan-16bit relative-channel-number value) - (ensure-number value (list fix relative-channel-number value)) - (set-chan relative-channel-number (msb value)) - (set-chan (+ relative-channel-number 1) (lsb value))) - - (scanout-fixture fix get-attr set-chan set-chan-16bit))) - - (atomic-box-ref fixtures)) - - ;; Send everything to OLA - (for-each (lambda (uni-buf-pair) - (let ((uni (car uni-buf-pair)) - (buf (cdr uni-buf-pair))) - (let ((prev-buf (assv-ref previous-universes uni))) - - ;; Do not send exactly the same data every time, - ;; but do send an update once every 100 loops, just to - ;; make sure OLA does not forget about us. - (unless (and prev-buf - (ola-dmx-buffers-equal? buf prev-buf) - (not (= count 0))) - (send-streaming-dmx-data! ola-client uni buf))))) - universes) - - (usleep 10000) - - ;; Update scanout rate every 1000 cycles + (lambda (uni-buf-pair) + (let ((uni (car uni-buf-pair)) + (buf (cdr uni-buf-pair))) + (let ((prev-buf (assv-ref previous-universes uni))) + + ;; Do not send exactly the same data every time, + ;; but do send an update once every 100 loops, just to + ;; make sure OLA does not forget about us. + (unless (and prev-buf + (ola-dmx-buffers-equal? buf prev-buf) + (not (= count 0))) + (send-streaming-dmx-data! ola-client uni buf))))) + universes) + + (usleep 20000) + + ;; Update output rate every 1000 cycles (if (eq? count 100) - (begin - (set! scanout-freq - (exact->inexact (/ 100 - (- (hirestime) start-time)))) - (scanout-loop ola-client (hirestime) 0 universes)) - (scanout-loop ola-client start-time (+ count 1) universes)))) - - -(define (start-ola-output) - (if ola-thread - (format #t "OLA output already running\n") - (let* ((ola-client (make-ola-streaming-client)) - (start-time (hirestime))) - - (set! ola-thread - (begin-thread - (with-exception-handler - (lambda (exn) - (display "Error in OLA output thread:\n") - (set! ola-thread #f) - (backtrace) - (raise-exception exn)) - (lambda () - (scanout-loop ola-client start-time 0 '())) - #:unwind? #f)))))) - - -(start-ola-output) + (begin + (set! scanout-freq + (exact->inexact (/ 100 + (- (hirestime) start-time)))) + (scanout-loop ola-client (hirestime) universes 0)) + (scanout-loop ola-client start-time universes (+ count 1))))) + + +(define (start-scanout) + (if scanout-thread + (format #t "Scanout thread is already running\n") + (let ((start-time (hirestime)) + (ola-client (make-ola-streaming-client))) + (set! scanout-thread + (begin-thread + (with-exception-handler + (lambda (exn) + (display "Error in scanout thread:\n") + (set! scanout-thread #f) + (backtrace) + (raise-exception exn)) + (lambda () + (scanout-loop ola-client start-time '() 0)) + #:unwind? #f)))))) + + +(start-scanout) diff --git a/guile/starlet/selection.scm b/guile/starlet/selection.scm new file mode 100644 index 0000000..2798fc1 --- /dev/null +++ b/guile/starlet/selection.scm @@ -0,0 +1,97 @@ +;; +;; starlet/selection.scm +;; +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet selection) + #:use-module (starlet utils) + #:use-module (starlet fixture) + #:use-module (srfi srfi-1) + #:export (sel + add-sel + toggle-sel + desel + selection-hook + get-selection + get-selection-as-string + selected?)) + + +(define selection-hook (make-hook 1)) + +(define selection '()) + + +(define (get-selection) + selection) + + +(define (dotted-fixture-name s) + (with-output-to-string + (lambda () + (format #t "~a.~a" (second s) (third s))))) + + +(define (get-selection-as-string) + (cat-with-spaces + (map + (lambda (s) + (let ((name (get-fixture-name s))) + (if (symbol? name) + (symbol->string name) + (dotted-fixture-name name)))) + selection))) + + +(define (sel . fixture-list) + (if (nil? fixture-list) + (set! selection '()) + (if (not (car fixture-list)) + (set! selection '()) + (set! selection (flatten-sublists fixture-list)))) + (run-hook selection-hook selection)) + + +(define (toggle-sel . fixture-list) + (if (selected? fixture-list) + (desel fixture-list) + (add-sel fixture-list))) + + +(define (add-sel . fixture-list) + (set! selection + (append selection + (filter (lambda (fix) + (not (selected? fix))) + (flatten-sublists fixture-list)))) + (run-hook selection-hook selection)) + + +(define (selected? . fixture-list) + (every (lambda (fix) + (memq fix selection)) + (flatten-sublists fixture-list))) + + +(define (desel . fixture-list) + (let ((remove-us (flatten-sublists fixture-list))) + (set! selection + (filter (lambda (fix) + (not (memq fix remove-us))) + selection))) + (run-hook selection-hook selection)) diff --git a/guile/starlet/snap-transition.scm b/guile/starlet/snap-transition.scm new file mode 100644 index 0000000..46993cd --- /dev/null +++ b/guile/starlet/snap-transition.scm @@ -0,0 +1,51 @@ +;; +;; starlet/snap-transition.scm +;; +;; Copyright © 2021-2023 Thomas White <taw@bitwiz.org.uk> +;; +;; 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 <http://www.gnu.org/licenses/>. +;; +(define-module (starlet snap-transition) + #:use-module (starlet cue-part) + #:use-module (starlet state) + #:use-module (starlet attributes) + #:export (snap)) + + +(define (blank-everything in-state) + (let ((out-state (make-empty-state))) + (state-for-each + (lambda (fix attr val) + (if (intensity? attr) + (set-in-state! out-state fix attr (lambda () 0.0)) + (set-in-state! out-state fix attr (lambda () 'no-value)))) + in-state) + out-state)) + + +(define (snap to-state) + (cue-part + to-state + (lambda (incoming-state current-state clock) + (let ((overlay-state (blank-everything current-state))) + (state-for-each + (lambda (fix attr val) + (set-in-state! overlay-state + fix + attr + (lambda () val))) + incoming-state) + (values overlay-state 0))))) diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm index 6abd3c1..588e887 100644 --- a/guile/starlet/state.scm +++ b/guile/starlet/state.scm @@ -1,7 +1,7 @@ ;; ;; starlet/state.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -20,18 +20,22 @@ ;; (define-module (starlet state) #:use-module (starlet fixture) - #:use-module (starlet colours) #:use-module (starlet utils) + #:use-module (starlet attributes) + #:use-module (starlet selection) #:use-module (oop goops) #:use-module (ice-9 pretty-print) #:use-module (ice-9 atomic) #:use-module (ice-9 receive) #:use-module (ice-9 exceptions) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:export (<starlet-state> make-empty-state + lighting-state? get-state-name state-for-each + state-map->list state-map copy-state clear-state! @@ -42,22 +46,26 @@ current-state at apply-state + combine-states show-state lighting-state programmer-state + ps home-fixture! + blackout blackout! - sel - selection-hook - get-selection value->number atomically-overlay-state! update-state! - add-update-hook!)) + add-update-hook! + state-empty? + remove-fixtures-from-state! + remove-fixture-from-state! + remove-selection-from-programmer!)) ;; A "state" is an atomically-updating container for an immutable -;; hash table mapping (fixture-object . attribute-symbol) pairs to values +;; hash table mapping (fixture-object . attribute-name-object) pairs to values ;; which can be numbers, symbols, colours, boolean values and more ;; depending on the type of attribute. Values can also be ;; functions which provide the value. @@ -66,12 +74,17 @@ #:init-form (make-atomic-box (make-hash-table)) #:getter get-ht-box) (update-hook - #:init-form (make-hook 4) + #:init-form (make-hook 1) #:getter get-update-hook)) +(define (lighting-state? a) + (is-a? a <starlet-state>)) + + ;; The state used to build a new scene for recording (define programmer-state (make <starlet-state>)) +(define ps programmer-state) (define (add-update-hook! state proc) @@ -80,10 +93,10 @@ (define (find-colour state fix) - (let ((col (state-find fix 'colour state))) + (let ((col (state-find fix colour state))) (if (eq? 'no-value col) - (let ((home-col (get-attr-home-val fix 'colour))) + (let ((home-col (get-attr-home-val fix colour))) (if (eq? 'fixture-does-not-have-attribute home-col) (raise-exception (make-exception (make-exception-with-message @@ -101,66 +114,7 @@ (define-method (set-in-state! (state <starlet-state>) (fix <fixture>) - (attr <colour-component-id>) - new-val - source) - (let ((current-colour (find-colour state fix)) - (colour-component (get-colour-component attr))) - - (cond - - ((eq? colour-component 'cyan) - (let ((orig-colour (colour-as-cmy current-colour))) - (set-in-state! state fix 'colour - (make-colour-cmy new-val - (magenta orig-colour) - (yellow orig-colour)) - source))) - - ((eq? colour-component 'magenta) - (let ((orig-colour (colour-as-cmy current-colour))) - (set-in-state! state fix 'colour - (make-colour-cmy (cyan orig-colour) - new-val - (yellow orig-colour)) - source))) - - ((eq? colour-component 'yellow) - (let ((orig-colour (colour-as-cmy current-colour))) - (set-in-state! state fix 'colour - (make-colour-cmy (cyan orig-colour) - (magenta orig-colour) - new-val) - source))) - - ((eq? colour-component 'red) - (let ((orig-colour (colour-as-rgb current-colour))) - (set-in-state! state fix 'colour - (make-colour-rgb new-val - (green orig-colour) - (blue orig-colour)) - source))) - - ((eq? colour-component 'green) - (let ((orig-colour (colour-as-rgb current-colour))) - (set-in-state! state fix 'colour - (make-colour-rgb (red orig-colour) - new-val - (blue orig-colour)) - source))) - - ((eq? colour-component 'blue) - (let ((orig-colour (colour-as-rgb current-colour))) - (set-in-state! state fix 'colour - (make-colour-rgb (red orig-colour) - (green orig-colour) - new-val) - source)))))) - - -(define-method (set-in-state! (state <starlet-state>) - (fix <fixture>) - (attr <symbol>) + (attr <starlet-attribute>) value source) (let* ((old-ht (atomic-box-ref (get-ht-box state))) @@ -175,27 +129,16 @@ old-ht) (set-in-state! state fix attr)) ;; Try again - (run-hook (get-update-hook state) - fix - attr - value - source))) + (run-hook (get-update-hook state) source))) (define-method (set-in-state! (state <starlet-state>) (fix <fixture>) - (attr <symbol>) + (attr <starlet-attribute>) value) (set-in-state! state fix attr value #f)) -(define-method (set-in-state! (state <starlet-state>) - (fix <fixture>) - (attr <colour-component-id>) - new-val) - (set-in-state! state fix attr new-val #f)) - - ;; Set any intensity attributes in the current state to zero (define (blackout!) (let ((state (current-state))) @@ -228,6 +171,10 @@ (make <starlet-state>)) +(define blackout + (make-empty-state)) + + (define (state-for-each func state) (hash-for-each (lambda (key value) (func (car key) @@ -236,24 +183,13 @@ (atomic-box-ref (get-ht-box state)))) -(define-method (state-find (fix <fixture>) - (attr <symbol>) - (state <starlet-state>)) +(define (state-find fix attr state) (hash-ref (atomic-box-ref (get-ht-box state)) (cons fix attr) 'no-value)) -(define-method (state-find (fix <fixture>) - (attr <colour-component-id>) - (state <starlet-state>)) - (let ((col (state-find fix 'colour state))) - (if (eq? 'no-value col) - 'no-value - (extract-colour-component col attr)))) - - -(define (state-map func state) +(define (state-map->list func state) (hash-map->list (lambda (key value) (func (car key) (cdr key) @@ -261,6 +197,21 @@ (atomic-box-ref (get-ht-box state)))) +(define (state-map func state) + (let ((out-state (make-empty-state))) + (hash-for-each + (lambda (key value) + (set-in-state! + out-state + (car key) + (cdr key) + (func (car key) + (cdr key) + value))) + (atomic-box-ref (get-ht-box state))) + out-state)) + + (define (apply-state state) "Apply the contents of 'state' to the current state, on top of the \ pre-existing contents." @@ -301,9 +252,20 @@ pre-existing contents." (current-state))))) +(define (combine-states a b) + (lighting-state + (apply-state a) + (apply-state b))) + + (define (print-state a) (pretty-print (state-source a))) +(define-method (write (st <starlet-state>) port) + (write + (state-source st) + port)) + (define (clamp-to-attr-range fix attr val) (if (number? val) @@ -316,14 +278,21 @@ pre-existing contents." val)) +(define (quote-if-symbol a) + (if (symbol? a) + (list 'quote a) + a)) + + (define (state-source a) (cons 'lighting-state - (state-map (lambda (fix attr val) - (list 'at - (get-fixture-name fix) - (list 'quote attr) - (clamp-to-attr-range fix attr val))) - a))) + (state-map->list (lambda (fix attr val) + (list 'at + (get-fixture-name fix) + (canonical-name attr) + (quote-if-symbol + (clamp-to-attr-range fix attr val)))) + a))) ;; Coerce something from a state object into a number for scanout @@ -343,8 +312,7 @@ pre-existing contents." old-ht) (clear-state! state))) ;; Try again - (run-hook (get-update-hook state) - '() #f #f #f)) + (run-hook (get-update-hook state) #f)) (define (partition3 pred1 pred2 input) @@ -355,69 +323,87 @@ pre-existing contents." (values output1 output2 others)))) -(define (set-fixtures fixtures attr-name value) - (for-each (lambda (fix) - (set-in-state! (current-state) - fix - (car attr-name) - (clamp-to-attr-range fix - (car attr-name) - (car value)))) - fixtures)) +(define (set-fixtures fixtures attribute value) + (for-each + (lambda (fix) + (if (fixture-has-attr? fix attribute) + (set-in-state! (current-state) + fix + attribute + (clamp-to-attr-range fix attribute value)) + (error "Fixture does not have attribute" + (get-fixture-name fix) + (canonical-name attribute)))) + fixtures)) ;; (at <fixtures/groups> [<attribute>] <level> [<attribute> <level>...]) ;; (at fix1 100) <-- Set intensity of single fixture -;; (at fix1 'intensity 100) <-- Explicit attribute name +;; (at fix1 intensity 100) <-- Explicit attribute name ;; (at fix1 fix2 100) <-- Multiple fixtures -;; (at fix1 fix2 'pan 36) <-- Multiple fixtures + explicit attribute -;; (at group1 fix1 'intensity 100) <-- Groups can be used instead of fixtures -;; (at fix1 100 'pan 36) <-- Set multiple attributes -;; NB Can't set multiple fixtures and attributes: (at fix1 'pan 35 fix2 'tilt 22) +;; (at fix1 fix2 pan 36) <-- Multiple fixtures + explicit attribute +;; (at group1 fix1 intensity 100) <-- Groups can be used instead of fixtures +;; (at fix1 100 pan 36) <-- Set multiple attributes +;; NB Can't set multiple fixtures and attributes: (at fix1 pan 35 fix2 tilt 22) (define (at . args) - (receive (fixtures attr-name value) - (partition3 fixture? symbol? (flatten-sublists args)) + (let ((selection (get-selection))) + (receive (fixtures attribute value) + (partition3 fixture? attribute? (flatten-sublists args)) (cond ((nil? value) (error "at: Value not specified")) ((or (more-than-one value) - (more-than-one attr-name)) + (more-than-one attribute)) (error "at: Only one attribute or value name")) ((and (nil? fixtures) - (nil? attr-name)) + (nil? attribute)) (if (nil? selection) 'no-fixtures-selected - (set-fixtures selection '(intensity) value))) + (set-fixtures selection intensity (car value)))) - ((nil? attr-name) - (set-fixtures fixtures '(intensity) value)) + ((nil? attribute) + (set-fixtures fixtures intensity (car value))) ((nil? fixtures) (if (nil? selection) 'no-fixtures-selected - (set-fixtures selection attr-name value))) + (set-fixtures selection (car attribute) (car value)))) (else - (set-fixtures fixtures attr-name value))))) + (set-fixtures fixtures (car attribute) (car value))))))) -(define selection-hook (make-hook 1)) +(define (state-empty? st) + (hash-table-empty? + (atomic-box-ref + (get-ht-box st)))) -(define selection '()) -(define (get-selection) - selection) +(define (remove-fixtures-from-state! st fixture-list) + (let ((new-ht (make-hash-table)) + (old-ht (atomic-box-ref (get-ht-box st)))) + (state-for-each + (lambda (fix attr val) + (unless (memq fix fixture-list) + (hash-set! new-ht (cons fix attr) val))) + st) + (if (eq? old-ht (atomic-box-compare-and-swap! + (get-ht-box st) + old-ht + new-ht)) + (run-hook (get-update-hook st) #f) + (remove-fixtures-from-state! st fixture-list)))) + +(define (remove-fixture-from-state! st fix) + (remove-fixtures-from-state! st (list fix))) -(define (sel . fixture-list) - (if (nil? fixture-list) - (set! selection '()) - (if (not (car fixture-list)) - (set! selection '()) - (set! selection (flatten-sublists fixture-list)))) - (run-hook selection-hook selection)) +(define (remove-selection-from-programmer!) + (remove-fixtures-from-state! + programmer-state + (get-selection))) diff --git a/guile/starlet/utils.scm b/guile/starlet/utils.scm index 16e3364..1506553 100644 --- a/guile/starlet/utils.scm +++ b/guile/starlet/utils.scm @@ -20,13 +20,30 @@ ;; (define-module (starlet utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 control) #:export (print-hash-table copy-hash-table in-range mean flatten-sublists more-than-one - hirestime)) + hirestime + lsb + msb + ensure-number + round-dmx + scale-to-range + scale-and-clamp-to-range + percent->dmxval8 + percent->dmxval16 + comment + hash-table-empty? + lookup + add-and-run-hook! + cat-with-spaces + next-item-in-list)) (define (print-hash-table ht) @@ -60,15 +77,12 @@ (define (flatten-sublists l) - - (define (listify a) - (if (list? a) - a - (list a))) - - (fold (lambda (a prev) - (append prev (listify a))) - '() l)) + (fold + (lambda (el prev) + (if (list? el) + (append (flatten-sublists el) prev) + (cons el prev))) + '() l)) (define (more-than-one a) @@ -83,3 +97,101 @@ (/ (cdr a) 1000000)))) + +(define (msb val) + (round-dmx (euclidean-quotient val 256))) + +(define (lsb val) + (round-dmx (euclidean-remainder val 256))) + + +(define (round-dmx a) + (inexact->exact + (min 255 (max 0 (round a))))) + + +(define (ensure-number value irritating) + (unless (number? value) + (raise-exception (make-exception + (make-exception-with-message "Value is not a number") + (make-exception-with-irritants irritating))))) + + +(define (percent->dmxval8 val) + (round-dmx + (scale-to-range val '(0 100) '(0 255)))) + + +(define (percent->dmxval16 val) + (scale-to-range val '(0 100) '(0 65535))) + + +(define (scale-to-range val orig-range dest-range) + + (define (range r) + (- (cadr r) (car r))) + + (+ (car dest-range) + (* (range dest-range) + (/ (- val (car orig-range)) + (range orig-range))))) + + +(define (clamp-to-range val val1 val2) + (let ((minval (min val1 val2)) + (maxval (max val1 val2))) + (max minval + (min val maxval)))) + + +;; Like scale-to-range, but result is clamped within dest-range +(define (scale-and-clamp-to-range val orig-range dest-range) + (clamp-to-range + (scale-to-range val orig-range dest-range) + (car dest-range) + (cadr dest-range))) + + +(define-syntax comment + (syntax-rules () + ((_ body ...) + #f))) + + +(define (hash-table-empty? ht) + (let/ec + return + (hash-for-each-handle + (lambda (key) + (return #f)) + ht) + #t)) + + +(define (lookup key dictionary) + (cond + ((nil? dictionary) + #f) + ((eq? key (caar dictionary)) + (cadr (car dictionary))) + (else + (lookup key (cdr dictionary))))) + + +(define (add-and-run-hook! hook proc . initial-args) + (add-hook! hook proc) + (apply proc initial-args)) + + +(define (cat-with-spaces lst) + (reduce + (lambda (b a) + (string-append a " " b)) + "" lst)) + + +(define (next-item-in-list the-list cval) + (let ((sl (memq cval the-list))) + (if (nil? (cdr sl)) + (first the-list) + (second sl)))) |