diff options
-rw-r--r-- | examples/demo.scm | 4 | ||||
-rw-r--r-- | guile/starlet/base.scm | 741 | ||||
-rw-r--r-- | guile/starlet/effects.scm | 1 | ||||
-rw-r--r-- | guile/starlet/fixture-library/arduino.scm | 2 | ||||
-rw-r--r-- | guile/starlet/fixture-library/generic.scm | 2 | ||||
-rw-r--r-- | guile/starlet/fixture-library/robe.scm | 2 | ||||
-rw-r--r-- | guile/starlet/fixture.scm | 203 | ||||
-rw-r--r-- | guile/starlet/midi-control/button-utils.scm | 2 | ||||
-rw-r--r-- | guile/starlet/midi-control/faders.scm | 8 | ||||
-rw-r--r-- | guile/starlet/playback.scm | 4 | ||||
-rw-r--r-- | guile/starlet/scanout.scm | 258 | ||||
-rw-r--r-- | guile/starlet/state.scm | 327 | ||||
-rw-r--r-- | guile/starlet/utils.scm | 11 |
13 files changed, 813 insertions, 752 deletions
diff --git a/examples/demo.scm b/examples/demo.scm index 648e8b8..c616786 100644 --- a/examples/demo.scm +++ b/examples/demo.scm @@ -26,7 +26,9 @@ ;; Basic setup (use-modules - (starlet base) + (starlet fixture) + (starlet state) + (starlet scanout) (starlet playback) (starlet effects) (starlet colours) diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm deleted file mode 100644 index 3420115..0000000 --- a/guile/starlet/base.scm +++ /dev/null @@ -1,741 +0,0 @@ -;; -;; starlet/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 base) - #:use-module (starlet utils) - #:use-module (starlet colours) - #:use-module (starlet guile-ola) - #:use-module (oop goops) - #:use-module (ice-9 threads) - #:use-module (ice-9 atomic) - #:use-module (ice-9 receive) - #:use-module (ice-9 pretty-print) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:export (<fixture> - patch-fixture! - get-attributes - get-fixture-name - find-attr - fixture? - scanout-fixture - - <fixture-attribute> - attr-continuous - attr-list - attr-colour - get-attr-type - get-attr-range - get-attr-name - get-attr-home-val - intensity? - continuous-attribute? - colour-attribute? - - <starlet-state> - make-empty-state - state-for-each - state-map - clear-state! - print-state - state-source - set-in-state! - state-find - current-state - at - apply-state - show-state - lighting-state - blackout - register-state! - - start-ola-output - scanout-freq - percent->dmxval8 - percent->dmxval16 - hirestime - value->number - - programmer-state - sel - current-value - selection-hook - - scale-to-range)) - - -(define-class <fixture-attribute> (<object>) - (name - #:init-form (error "Attribute name must be specified") - #:init-keyword #:name - #:getter get-attr-name) - - (range - #:init-value '() - #:init-keyword #:range - #:getter get-attr-range) - - (type - #:init-value 'continuous - #:init-keyword #:type - #:getter get-attr-type) - - (home-value - #:init-value 0 - #:init-keyword #:home-value - #:getter attr-home-value)) - - -(define-class <fixture> (<object>) - (name - #:init-form (error "Fixture name must be specified") - #:init-keyword #:name - #:getter get-fixture-name) - - (universe - #:init-value #f - #:init-keyword #:uni - #:getter get-fixture-universe - #:setter set-fixture-universe!) - - (start-addr - #:init-value #f - #:init-keyword #:sa - #: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 (get-attributes f) - (slot-ref f 'attributes)) - - -(define (fixture? f) - (is-a? f <fixture>)) - - -;; A "state" is just a thin wrapper around a hash table -;; of (fixture . attribute) --> value -(define-class <starlet-state> (<object>) - (hash-table - #:init-form (make-hash-table) - #:getter get-state-hash-table) - (name - #:init-value #f - #:init-keyword #:name - #:getter get-state-name - #:setter set-state-name!)) - - -(define (find-colour state fix) - (let ((col (state-find fix 'colour state))) - (if (eq? 'no-value col) - - (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 - "Fixture doesn't have colour attribute") - (make-exception-with-irritants fix))) - home-col)) - - col))) - - -(define-method (set-in-state! (state <starlet-state>) - (fix <fixture>) - (attr <colour-component-id>) - new-val) - (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))))) - - ((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))))) - - ((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)))) - - ((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))))) - - ((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))))) - - ((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))))))) - - -(define-method (set-in-state! (state <starlet-state>) - (fix <fixture>) - (attr <symbol>) - value) - (hash-set! (get-state-hash-table state) - (cons fix attr) - value)) - - -;; List of fixtures and home state (must remain consistent) -(define fixtures (make-atomic-box '())) - -;; List of states being scanned out -(define state-list (make-atomic-box '())) - -;; The state used to build a new scene for recording -(define programmer-state (make <starlet-state>)) - - -(define (make-empty-state) - (make <starlet-state>)) - - -(define-method (find-attr (fix <fixture>) (attr-name <symbol>)) - (find (lambda (a) - (eq? (get-attr-name a) - attr-name)) - (slot-ref fix 'attributes))) - - -(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>)) - (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 (blackout state) - (state-for-each - (lambda (fix attr val) - (when (intensity? attr) - (set-in-state! state fix attr 0.0))) - state)) - - -;; Set a single attribute to home position -(define (home-attr! state fix attr) - (set-in-state! state - fix - attr - (get-attr-home-val fix attr))) - - -(define (copy-state state) - (let ((new-state (make-empty-state))) - (state-for-each (lambda (fix attr val) - (set-in-state! new-state - fix - attr - val)) - state) - new-state)) - - -(define (intensity? a) - (eq? 'intensity a)) - - -(define (continuous-attribute? aobj) - (eq? 'continuous - (get-attr-type aobj))) - - -(define (colour-attribute? aobj) - (eq? 'colour - (get-attr-type aobj))) - - -(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))))) - -;; 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 ...))))) - - -;; Helper functions for scanout functions -(define (round-dmx a) - (inexact->exact - (min 255 (max 0 (round a))))) - -(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 (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 (msb val) - (round-dmx (euclidean-quotient val 256))) - -(define (lsb val) - (round-dmx (euclidean-remainder val 256))) - - -(define (state-for-each func state) - (hash-for-each (lambda (key value) - (func (car key) - (cdr key) - value)) - (get-state-hash-table state))) - - -(define-method (state-find (fix <fixture>) - (attr <symbol>) - (state <starlet-state>)) - (hash-ref (get-state-hash-table 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) - (hash-map->list (lambda (key value) - (func (car key) - (cdr key) - value)) - (get-state-hash-table state))) - - -(define (apply-state state) - "Apply the contents of 'state' to the current state, on top of the \ -pre-existing contents." - (state-for-each at state)) - - -(define (show-state state) - "Clear the current state, and apply the contents of 'state'" - (clear-state! (current-state)) - (state-for-each at state)) - - -;; Coerce something from a state object into a number for scanout -(define (value->number val time) - (if (procedure? val) - (value->number (val time) time) - val)) - - -(define (clear-state! state) - (hash-clear! (get-state-hash-table state))) - - -;; Scanout -(define (bytevec->string bv) - (string-join - (map - number->string - (u8vector->list bv)) - ",")) - - -(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 (hirestime) - (let ((a (gettimeofday))) - (+ (car a) - (/ (cdr a) - 1000000)))) - - -(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 scanout-freq 0) - -(define-generic scanout-fixture) - -(define (scanout-loop ola-client start-time count previous-universes) - - (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)) - - ;; Create DMX array for universe if it doesn't exist already - (unless (assq universe universes) - (set! universes (acons universe - (make-ola-dmx-buffer) - universes))) - - (set-ola-dmx-buffer! (assq-ref universes universe) - (- addr 1) ; OLA indexing starts from zero - (round-dmx value))) - - (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 (hirestime))) - - ;; 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 - (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 ola-thread #f) - -(define (start-ola-output) - (unless ola-thread - (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)))))) - - -(define (state-has-fix-attr fix attr tnow state) - (let ((val (state-find fix attr state))) - (if (eq? 'no-value val) - #f - (not (eq? 'no-value (value->number val tnow)))))) - -(define (first-val fix attr tnow state-list) - (let ((first-state (find (lambda (state) - (state-has-fix-attr fix attr tnow state)) - state-list))) - (if first-state - (state-find fix attr first-state) - 'no-value))) - -(define-method (current-value (fix <fixture>) (attr-name <symbol>) tnow) - (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 tnow))) - (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 tnow (atomic-box-ref state-list)))) - (if (eq? 'no-value val) - (get-attr-home-val fix attr-name) - (value->number val tnow)))) - - ;; Use programmer value, if we have it - (value->number programmer-val tnow)))) - - -(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>) tnow) - (let ((colour (current-value fix 'colour tnow))) - (extract-colour-component colour attr-name))) - - -(define-syntax attr-continuous - (syntax-rules () - ((_ attr-name attr-range attr-home-value) - (make <fixture-attribute> - #:name attr-name - #:range attr-range - #:type 'continuous - #:home-value attr-home-value)))) - - -(define-syntax attr-list - (syntax-rules () - ((_ attr-name attr-allowed-values attr-home-value) - (make <fixture-attribute> - #:name attr-name - #:range attr-allowed-values - #:type 'list - #:home-value attr-home-value)))) - - -(define-syntax attr-colour - (syntax-rules () - ((_ attr-name attr-home-value) - (make <fixture-attribute> - #:name attr-name - #:type 'colour - #:home-value attr-home-value)))) - - -(define current-state (make-parameter programmer-state)) - - -(define-syntax lighting-state - (syntax-rules () - ((_ body ...) - (parameterize ((current-state (make-empty-state))) - body ... - (current-state))))) - - -(define (partition3 pred1 pred2 input) - (receive (output1 others) - (partition pred1 input) - (receive (output2 others) - (partition pred2 others) - (values output1 output2 others)))) - - -(define (set-fixtures fixtures attr-name value) - (for-each (lambda (fix) - (set-in-state! (current-state) - fix - (car attr-name) - (car value))) - 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 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) - -(define (at . args) - (receive (fixtures attr-name value) - (partition3 fixture? symbol? (flatten-sublists args)) - (cond - - ((nil? value) - (error "at: Value not specified")) - - ((or (more-than-one value) - (more-than-one attr-name)) - (error "at: Only one attribute or value name")) - - ((and (nil? fixtures) - (nil? attr-name)) - (if (nil? selection) - 'no-fixtures-selected - (set-fixtures selection '(intensity) value))) - - ((nil? attr-name) - (set-fixtures fixtures '(intensity) value)) - - ((nil? fixtures) - (if (nil? selection) - 'no-fixtures-selected - (set-fixtures selection attr-name value))) - - (else - (set-fixtures fixtures attr-name value))))) - - -(define selection-hook (make-hook 1)) - -(define 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 (print-state a) - (pretty-print (state-source a))) - - -(define (state-source a) - (cons 'lighting-state - (state-map (lambda (fix attr val) - (list 'at - (get-fixture-name fix) - (list 'quote attr) - val)) - a))) diff --git a/guile/starlet/effects.scm b/guile/starlet/effects.scm index 80f0b4e..fcffb3c 100644 --- a/guile/starlet/effects.scm +++ b/guile/starlet/effects.scm @@ -19,7 +19,6 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet effects) - #:use-module (starlet base) #:export (flash sinewave)) diff --git a/guile/starlet/fixture-library/arduino.scm b/guile/starlet/fixture-library/arduino.scm index 6d1a11a..3a008aa 100644 --- a/guile/starlet/fixture-library/arduino.scm +++ b/guile/starlet/fixture-library/arduino.scm @@ -20,7 +20,7 @@ ;; (define-module (starlet fixture-library arduino) #:use-module (oop goops) - #:use-module (starlet base) + #:use-module (starlet fixture) #:use-module (starlet colours) #:export (<arduino-dmx-thing>)) diff --git a/guile/starlet/fixture-library/generic.scm b/guile/starlet/fixture-library/generic.scm index 6bf029f..381759e 100644 --- a/guile/starlet/fixture-library/generic.scm +++ b/guile/starlet/fixture-library/generic.scm @@ -20,7 +20,7 @@ ;; (define-module (starlet fixture-library generic) #:use-module (oop goops) - #:use-module (starlet base) + #:use-module (starlet fixture) #:export (<generic-dimmer> generic-rgb)) diff --git a/guile/starlet/fixture-library/robe.scm b/guile/starlet/fixture-library/robe.scm index 95c88b3..97ac44a 100644 --- a/guile/starlet/fixture-library/robe.scm +++ b/guile/starlet/fixture-library/robe.scm @@ -20,7 +20,7 @@ ;; (define-module (starlet fixture-library robe) #:use-module (oop goops) - #:use-module (starlet base) + #:use-module (starlet fixture) #:use-module (starlet colours) #:export (<robe-dl7s-mode1> <robe-mmxwashbeam-mode1> diff --git a/guile/starlet/fixture.scm b/guile/starlet/fixture.scm new file mode 100644 index 0000000..88e38e5 --- /dev/null +++ b/guile/starlet/fixture.scm @@ -0,0 +1,203 @@ +;; +;; starlet/fixture.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) + #:use-module (starlet colours) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:export (<fixture> + get-fixture-name + get-fixture-addr + get-fixture-universe + find-attr + fixture? + scanout-fixture + + attr-continuous + attr-list + attr-colour + get-attr-type + get-attr-range + get-attr-home-val + continuous-attribute? + colour-attribute? + intensity? + + scale-to-range + round-dmx + percent->dmxval8 + percent->dmxval16)) + + +(define-class <fixture-attribute> (<object>) + (name + #:init-form (error "Attribute name must be specified") + #:init-keyword #:name + #:getter get-attr-name) + + (range + #:init-value '() + #:init-keyword #:range + #:getter get-attr-range) + + (type + #:init-value 'continuous + #:init-keyword #:type + #:getter get-attr-type) + + (home-value + #:init-value 0 + #:init-keyword #:home-value + #:getter attr-home-value)) + + +(define-class <fixture> (<object>) + (name + #:init-form (error "Fixture name must be specified") + #:init-keyword #:name + #:getter get-fixture-name) + + (universe + #:init-value #f + #:init-keyword #:uni + #:getter get-fixture-universe + #:setter set-fixture-universe!) + + (start-addr + #:init-value #f + #:init-keyword #:sa + #: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) + (make <fixture-attribute> + #:name attr-name + #:range attr-range + #:type 'continuous + #:home-value attr-home-value)))) + + +(define-syntax attr-list + (syntax-rules () + ((_ attr-name attr-allowed-values attr-home-value) + (make <fixture-attribute> + #:name attr-name + #:range attr-allowed-values + #:type 'list + #:home-value attr-home-value)))) + + +(define-syntax attr-colour + (syntax-rules () + ((_ attr-name attr-home-value) + (make <fixture-attribute> + #:name attr-name + #:type 'colour + #:home-value attr-home-value)))) + + +(define (get-attributes f) + (slot-ref f 'attributes)) + + +(define (fixture? f) + (is-a? f <fixture>)) + + +(define-method (find-attr (fix <fixture>) (attr-name <symbol>)) + (find (lambda (a) + (eq? (get-attr-name a) + attr-name)) + (slot-ref fix 'attributes))) + + +(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>)) + (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))) + + +(define (colour-attribute? aobj) + (eq? 'colour + (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 (percent->dmxval16 val) + (scale-to-range val '(0 100) '(0 65535))) + + +(define (round-dmx a) + (inexact->exact + (min 255 (max 0 (round a))))) + + +(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))))) + diff --git a/guile/starlet/midi-control/button-utils.scm b/guile/starlet/midi-control/button-utils.scm index 5acd5f6..051935f 100644 --- a/guile/starlet/midi-control/button-utils.scm +++ b/guile/starlet/midi-control/button-utils.scm @@ -20,7 +20,7 @@ ;; (define-module (starlet midi-control button-utils) #:use-module (starlet midi-control base) - #:use-module (starlet base) + #:use-module (starlet state) #:use-module (starlet playback) #:export (make-go-button make-stop-button diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm index 53ea378..cb78339 100644 --- a/guile/starlet/midi-control/faders.scm +++ b/guile/starlet/midi-control/faders.scm @@ -20,11 +20,11 @@ ;; (define-module (starlet midi-control faders) #:use-module (starlet midi-control base) - #:use-module (starlet base) + #:use-module (starlet state) + #:use-module (starlet fixture) #:use-module (starlet colours) + #:use-module (starlet scanout) #:use-module (starlet utils) - #:use-module (ice-9 receive) - #:use-module (srfi srfi-9) #:use-module (srfi srfi-1) #:export (state-on-fader)) @@ -93,12 +93,14 @@ (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* (at-midi-jogwheel fixture-list attr cc-number #:key (led #f)) diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm index 1844853..c09e69b 100644 --- a/guile/starlet/playback.scm +++ b/guile/starlet/playback.scm @@ -26,7 +26,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-43) - #:use-module (starlet base) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet scanout) #:use-module (starlet utils) #:use-module (starlet colours) #:export (make-playback diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm new file mode 100644 index 0000000..3c9562a --- /dev/null +++ b/guile/starlet/scanout.scm @@ -0,0 +1,258 @@ +;; +;; starlet/scanout.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 scanout) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet utils) + #:use-module (starlet colours) + #: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 (start-ola-output + patch-fixture! + scanout-freq + register-state! + current-value)) + + +;; The list of patched fixtures +(define fixtures (make-atomic-box '())) + +;; List of states being scanned out +(define state-list (make-atomic-box '())) + + +;; 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 ...))))) + + +(define (state-has-fix-attr fix attr tnow state) + (let ((val (state-find fix attr state))) + (if (eq? 'no-value val) + #f + (not (eq? 'no-value (value->number val tnow)))))) + + +(define (first-val fix attr tnow state-list) + (let ((first-state (find (lambda (state) + (state-has-fix-attr fix attr tnow state)) + state-list))) + (if first-state + (state-find fix attr first-state) + 'no-value))) + + +(define-method (current-value (fix <fixture>) (attr-name <symbol>) tnow) + (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 tnow))) + (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 tnow (atomic-box-ref state-list)))) + (if (eq? 'no-value val) + (get-attr-home-val fix attr-name) + (value->number val tnow)))) + + ;; Use programmer value, if we have it + (value->number programmer-val tnow)))) + + +(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>) tnow) + (let ((colour (current-value fix 'colour tnow))) + (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* (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 (msb val) + (round-dmx (euclidean-quotient val 256))) + +(define (lsb val) + (round-dmx (euclidean-remainder val 256))) + + +(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 (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 scanout-freq 0) +(define ola-thread #f) + +(define (scanout-loop ola-client start-time count previous-universes) + + (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)) + + ;; Create DMX array for universe if it doesn't exist already + (unless (assq universe universes) + (set! universes (acons universe + (make-ola-dmx-buffer) + universes))) + + (set-ola-dmx-buffer! (assq-ref universes universe) + (- addr 1) ; OLA indexing starts from zero + (round-dmx value))) + + (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 (hirestime))) + + ;; 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 + (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) + (unless ola-thread + (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)))))) + diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm new file mode 100644 index 0000000..e6c3af4 --- /dev/null +++ b/guile/starlet/state.scm @@ -0,0 +1,327 @@ +;; +;; starlet/state.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 state) + #:use-module (starlet fixture) + #:use-module (starlet colours) + #:use-module (starlet utils) + #: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) + #:export (<starlet-state> + make-empty-state + get-state-name + set-state-name! + state-for-each + state-map + clear-state! + print-state + state-source + set-in-state! + state-find + current-state + at + apply-state + show-state + lighting-state + programmer-state + blackout + sel + selection-hook + value->number)) + + +;; A "state" is just a thin wrapper around a hash table +;; of (fixture . attribute) --> value +(define-class <starlet-state> (<object>) + (hash-table + #:init-form (make-hash-table) + #:getter get-state-hash-table) + (name + #:init-value #f + #:init-keyword #:name + #:getter get-state-name + #:setter set-state-name!)) + + +;; The state used to build a new scene for recording +(define programmer-state (make <starlet-state>)) + + +(define (find-colour state fix) + (let ((col (state-find fix 'colour state))) + (if (eq? 'no-value col) + + (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 + "Fixture doesn't have colour attribute") + (make-exception-with-irritants fix))) + home-col)) + + col))) + + +(define-method (set-in-state! (state <starlet-state>) + (fix <fixture>) + (attr <colour-component-id>) + new-val) + (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))))) + + ((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))))) + + ((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)))) + + ((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))))) + + ((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))))) + + ((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))))))) + + +(define-method (set-in-state! (state <starlet-state>) + (fix <fixture>) + (attr <symbol>) + value) + (hash-set! (get-state-hash-table state) + (cons fix attr) + value)) + + +(define (blackout state) + (state-for-each + (lambda (fix attr val) + (when (intensity? attr) + (set-in-state! state fix attr 0.0))) + state)) + + +;; Set a single attribute to home position +(define (home-attr! state fix attr) + (set-in-state! state + fix + attr + (get-attr-home-val fix attr))) + + +(define (copy-state state) + (let ((new-state (make-empty-state))) + (state-for-each (lambda (fix attr val) + (set-in-state! new-state + fix + attr + val)) + state) + new-state)) + + +(define (make-empty-state) + (make <starlet-state>)) + + +(define (state-for-each func state) + (hash-for-each (lambda (key value) + (func (car key) + (cdr key) + value)) + (get-state-hash-table state))) + + +(define-method (state-find (fix <fixture>) + (attr <symbol>) + (state <starlet-state>)) + (hash-ref (get-state-hash-table 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) + (hash-map->list (lambda (key value) + (func (car key) + (cdr key) + value)) + (get-state-hash-table state))) + + +(define (apply-state state) + "Apply the contents of 'state' to the current state, on top of the \ +pre-existing contents." + (state-for-each at state)) + + +(define (show-state state) + "Clear the current state, and apply the contents of 'state'" + (clear-state! (current-state)) + (state-for-each at state)) + + +(define current-state (make-parameter programmer-state)) + + +(define-syntax lighting-state + (syntax-rules () + ((_ body ...) + (parameterize ((current-state (make-empty-state))) + body ... + (current-state))))) + + +(define (print-state a) + (pretty-print (state-source a))) + + +(define (state-source a) + (cons 'lighting-state + (state-map (lambda (fix attr val) + (list 'at + (get-fixture-name fix) + (list 'quote attr) + val)) + a))) + + +;; Coerce something from a state object into a number for scanout +(define (value->number val time) + (if (procedure? val) + (value->number (val time) time) + val)) + + +(define (clear-state! state) + (hash-clear! (get-state-hash-table state))) + + +(define (partition3 pred1 pred2 input) + (receive (output1 others) + (partition pred1 input) + (receive (output2 others) + (partition pred2 others) + (values output1 output2 others)))) + + +(define (set-fixtures fixtures attr-name value) + (for-each (lambda (fix) + (set-in-state! (current-state) + fix + (car attr-name) + (car value))) + 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 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) + +(define (at . args) + (receive (fixtures attr-name value) + (partition3 fixture? symbol? (flatten-sublists args)) + (cond + + ((nil? value) + (error "at: Value not specified")) + + ((or (more-than-one value) + (more-than-one attr-name)) + (error "at: Only one attribute or value name")) + + ((and (nil? fixtures) + (nil? attr-name)) + (if (nil? selection) + 'no-fixtures-selected + (set-fixtures selection '(intensity) value))) + + ((nil? attr-name) + (set-fixtures fixtures '(intensity) value)) + + ((nil? fixtures) + (if (nil? selection) + 'no-fixtures-selected + (set-fixtures selection attr-name value))) + + (else + (set-fixtures fixtures attr-name value))))) + + +(define selection-hook (make-hook 1)) + +(define 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)) + diff --git a/guile/starlet/utils.scm b/guile/starlet/utils.scm index d5eb018..d5441cb 100644 --- a/guile/starlet/utils.scm +++ b/guile/starlet/utils.scm @@ -27,7 +27,8 @@ in-range mean flatten-sublists - more-than-one)) + more-than-one + hirestime)) (define (print-hash-table ht) @@ -85,3 +86,11 @@ (if (nil? a) #f (not (nil? (cdr a))))) + + +(define (hirestime) + (let ((a (gettimeofday))) + (+ (car a) + (/ (cdr a) + 1000000)))) + |