diff options
Diffstat (limited to 'guile/starlet/state.scm')
| -rw-r--r-- | guile/starlet/state.scm | 262 |
1 files changed, 124 insertions, 138 deletions
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))) |