From ed9dadd2536edd84604801af816a622205a48e72 Mon Sep 17 00:00:00 2001
From: Thomas White <taw@physics.org>
Date: Wed, 27 May 2020 18:19:14 +0200
Subject: Basic fixture structure

---
 guile/nanolight/fixture.scm | 79 ++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 78 insertions(+), 1 deletion(-)

(limited to 'guile/nanolight/fixture.scm')

diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm
index 95bdc13..9bc0552 100644
--- a/guile/nanolight/fixture.scm
+++ b/guile/nanolight/fixture.scm
@@ -1 +1,78 @@
-(define-module (nanolight fixture))
+(define-module (nanolight fixture)
+  #:export (<fixture> <fixture-attribute>
+             patch-fixture
+             fixture-string get-address-string)
+  #:use-module (oop goops))
+
+
+(define-class <fixture-attribute> (<object>)
+
+  (name
+    #:init-value 'unnamed-attribute
+    #:init-keyword #:name
+    #:getter name)
+
+  (offset
+    #:init-value 0
+    #:init-keyword #:offset
+    #:getter offset))
+
+
+(define-class <fixture> (<object>)
+
+  (attributes
+    #:init-value '()
+    #:init-keyword #:attributes)
+
+  (universe
+    #:init-value #f
+    #:init-keyword #:uni
+    #:getter get-universe
+    #:setter set-universe!)
+
+  (start-addr
+    #:init-value #f
+    #:init-keyword #:sa
+    #:getter get-start-addr
+    #:setter set-start-addr!)
+
+  (friendly-name
+    #:init-value "Fixture"
+    #:init-keyword #:friendly-name
+    #:getter get-friendly-name
+    #:setter set-friendly-name!)
+
+  (address-string
+    #:init-value #f
+    #:allocation #:virtual
+    #:getter get-address-string
+    #:slot-ref (lambda (a)
+                 (string-append
+                   (number->string (slot-ref a 'universe))
+                   "."
+                   (number->string (slot-ref a 'start-addr))))
+    #:slot-set! (lambda (a s) #f)))
+
+
+; List of all patched fixtures (for scanout)
+(define fixtures (list))
+
+(define (add-fixture-to-roster fixture)
+  (set! fixtures (cons fixture fixtures)))
+
+
+(define (fixture-string fixture)
+  (string-append
+    (get-friendly-name fixture)
+    " at "
+    (get-address-string fixture)))
+
+
+(define (patch-fixture attributes universe start-addr friendly-name)
+  (let ((new-fixture (make <fixture>
+                       #:attributes attributes
+                       #:uni universe
+                       #:sa start-addr
+                       #:friendly-name friendly-name)))
+    (add-fixture-to-roster new-fixture)
+    new-fixture))
-- 
cgit v1.2.3