From 546cecd5c28517487ad659d336c90a4ac3484cf6 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Sun, 26 Jul 2020 18:41:59 +0200 Subject: Rename project and finally get states right --- guile/starlet/base.scm | 308 ++++++++++++++++++++++++++++++ guile/starlet/fixture-library/generic.scm | 16 ++ 2 files changed, 324 insertions(+) create mode 100644 guile/starlet/base.scm create mode 100644 guile/starlet/fixture-library/generic.scm (limited to 'guile/starlet') diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm new file mode 100644 index 0000000..4e9afd5 --- /dev/null +++ b/guile/starlet/base.scm @@ -0,0 +1,308 @@ +(define-module (starlet base) + #:use-module (oop goops) + #:use-module (ice-9 threads) + #:use-module (ice-9 atomic) + #:use-module (web client) + #:use-module (web http) + #:use-module (web uri) + #:export ( + start-ola-output patch-fixture + set-attr! home-attr! home-all! blackout + make-workspace + percent->dmxval msb lsb chan)) + +(use-modules (srfi srfi-1)) + + +(define-class () + + (name + #:init-value 'unnamed-attribute + #:init-keyword #:name + #:getter get-attr-name) + + (range + #:init-value '() + #:init-keyword #:range + #:getter get-attr-range) + + (translator + #:init-value (lambda (universe start-addr value set-dmx) #f) + #:init-keyword #:translator + #:getter get-attr-translator) + + (type + #:init-value 'continuous + #:init-keyword #:type + #:getter get-attr-type) + + (home-value + #:init-value 0 + #:init-keyword #:home-value + #:getter get-attr-home-value + #:setter set-attr-home-value!)) + + + +(define-class () + + (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!)) + + +;; A "state" is just a thin wrapper around a hash table +;; of (fixture . attribute) --> value +(define-class () + (hash-table + #:init-form (make-hash-table) + #:getter get-state-hash-table)) + + +(define-generic set-in-state!) + +(define-method (set-in-state! (state ) + (fix ) + (attr ) + value) + (hash-set! (get-state-hash-table state) + (cons fix attr) + value)) + + +;; A "workspace" is just a "state" with extra information +;; about how its contents should be sent out on the wire +(define-class () + (priority + #:init-value 0 + #:init-keyword #:priority + #:getter get-workspace-priority + #:setter set-workspace-priority!)) + + +;; List of fixtures +(define patched-fixture-list (make-atomic-box '())) + +;; Basic workspace which holds everything at "home" unless +;; commanded otherwise +(define base-workspace (make + #:priority -100)) + +;; List of workspaces +(define workspace-list (make-atomic-box (list base-workspace))) + + +;; Set a single attribute to home position +(define (home-attr! state fix attr) + (set-in-state! state + fix + attr + (get-attr-home-value attr))) + + +;; Set all attributes of a fixture to home position +(define (home-all! workspace fix) + (for-each (lambda (attr) + (home-attr! workspace fix attr)) + (slot-ref fix 'attributes))) + + +;; Set the intensity of all patched fixtures to zero +(define (blackout workspace) + (for-each (lambda (fix) + (set-attr! workspace fix 'intensity 0)) + (atomic-box-ref patched-fixture-list))) + + +(define (find-attr fix attr-name) + (find (lambda (a) + (eq? (get-attr-name a) + attr-name)) + (slot-ref fix 'attributes))) + + +(define (make-workspace) + (let ((new-workspace (make ))) + (atomic-box-set! workspace-list + (cons new-workspace + (atomic-box-ref workspace-list))) + new-workspace)) + + +;; Set an attribute +(define (set-attr! workspace fix attr-name value) + (let ((attr (find-attr fix attr-name))) + (when attr (set-in-state! workspace fix attr value)))) + + + +;; Patch a new fixture +(define* (patch-fixture class + start-addr + #:key (universe 1) (friendly-name "Fixture")) + (let ((new-fixture (make class + #:sa start-addr + #:uni universe + #:friendly-name friendly-name))) + (home-all! base-workspace new-fixture) + (atomic-box-set! patched-fixture-list + (cons new-fixture + (atomic-box-ref patched-fixture-list))) + new-fixture)) + + + +;; Helper functions for attribute translators +(define (round-dmx a) + (min 255 (max 0 (round a)))) + +(define (percent->dmxval val) + (round-dmx (/ (* 256 val) 100))) + +(define (msb val) + (round-dmx (/ val 256))) + +(define (lsb val) + (round-dmx (logand (round val) #b11111111))) + +(define (chan channel start-addr) + (- (+ channel start-addr) 1)) + + +(define (state-for-each func state) + (hash-for-each (lambda (key value) + (func (car key) + (cdr key) + value)) + (get-state-hash-table state))) + +(define (state-find fix attr state) + (hash-ref (get-state-hash-table state) + (cons fix attr))) + + +;; Add the contents of state "new" to "combined-state" +(define (add-state-to-state merge-rule new combined-state) + (state-for-each (lambda (fix attr value) + (let ((current-value (state-find fix + attr + combined-state))) + (if current-value + (set-in-state! combined-state + fix + attr + (merge-rule current-value value)) + (set-in-state! combined-state + fix + attr + value)))) + new)) + + +(define (merge-rule-ltp a b) b) + +(define (merge-rule-htp a b) + (if (> a b) + a + b)) + + +;; Combine states +(define (merge-states merge-rule list-of-workspaces) + (let ((combined-state (make ))) + (for-each (lambda (workspace) + (add-state-to-state + merge-rule + workspace + combined-state)) + list-of-workspaces) + combined-state)) + + + +;; Scanout +(define (bytevec->string bv) + (string-join + (map + number->string + (u8vector->list bv)) + ",")) + + +(define (send-to-ola ola-uri ola-socket universe) + (http-post + ola-uri + #:port ola-socket + #:keep-alive? #t + #:headers (acons 'content-type + (parse-header 'content-type + "application/x-www-form-urlencoded") + '()) + #:body (string-append "u=" + (number->string (car universe)) + "&d=" + (bytevec->string (cdr universe))))) + +(define (start-ola-output) + (letrec* ((ola-uri (build-uri 'http + #:host "127.0.0.1" + #:port 9090 + #:path "/set_dmx")) + (ola-socket (open-socket-for-uri ola-uri))) + + (begin-thread + (let scanout-loop () + + (let ((universes '())) + + + ;; Helper function called by attribute translators + ;; to set individual DMX values + (define (set-dmx universe addr value) + + ;; Create DMX array for universe if it doesn't exist already + (unless (assq universe universes) + (set! universes (acons universe + (make-u8vector 512 0) + universes))) + + ;; Set the value in the DMX array + (u8vector-set! (assq-ref universes universe) + (- addr 1) ; u8vector-set indexing starts from zero + (round-dmx value))) + + ;; Scan out all attributes of the combined workspace + (state-for-each (lambda (fix attr value) + + ;; Scan out one attribute assignment + (let ((trans (get-attr-translator attr))) + (trans (get-fixture-universe fix) + (get-fixture-addr fix) + value + set-dmx))) + + (merge-states merge-rule-htp + (atomic-box-ref + workspace-list))) + + ;; Send everything to OLA + (for-each (lambda (a) + (send-to-ola ola-uri ola-socket a)) + universes)) + + (yield) + (scanout-loop))))) diff --git a/guile/starlet/fixture-library/generic.scm b/guile/starlet/fixture-library/generic.scm new file mode 100644 index 0000000..e24f0c6 --- /dev/null +++ b/guile/starlet/fixture-library/generic.scm @@ -0,0 +1,16 @@ +(define-module (starlet fixture-library generic) + #:use-module (oop goops) + #:use-module (starlet base) + #:export ()) + +(define-class () + + (attributes + #:init-form + (list + + (make #:name 'intensity + #:range '(0 100) #:type 'continuous #:home-value 0 + #:translator (lambda (universe start-addr value set-dmx) + (set-dmx universe start-addr + (percent->dmxval value))))))) -- cgit v1.2.3