Split 'base' module up into 'fixture', 'state' and 'scanout'

1 files changed, 327 insertions, 0 deletions

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))
+