1 files changed, 60 insertions, 49 deletions

diff --git a/guile/starlet/fixture.scm b/guile/starlet/fixture.scm
index 9f58f25..524d78b 100644
--- a/guile/starlet/fixture.scm
+++ b/guile/starlet/fixture.scm
@@ -20,7 +20,10 @@
 ;;
 (define-module (starlet fixture)
   #:use-module (starlet colours)
+  #:use-module (starlet utils)
+  #:use-module (starlet attributes)
   #:use-module (oop goops)
+  #:use-module (ice-9 exceptions)
   #:use-module (srfi srfi-1)
   #:export (<fixture>
             get-fixture-name
@@ -28,23 +31,24 @@
             get-fixture-universe
             get-fixture-attrs
             find-attr
+            fixture-has-attr?
+
             fixture?
             scanout-fixture
 
             attr-continuous
             attr-list
             attr-colour
+            define-fixture
+
             get-attr-type
             get-attr-range
             get-attr-home-val
             continuous-attribute?
             colour-attribute?
-            intensity?
 
-            scale-to-range
-            round-dmx
-            percent->dmxval8
-            percent->dmxval16))
+            next-attr-item
+            prev-attr-item))
 
 
 (define-class <fixture-attribute> (<object>)
@@ -66,7 +70,12 @@
   (home-value
     #:init-value 0
     #:init-keyword #:home-value
-    #:getter attr-home-value))
+    #:getter attr-home-value)
+
+  (comment
+    #:init-value ""
+    #:init-keyword #:comment
+    #:getter attr-comment))
 
 
 (define-class <fixture> (<object>)
@@ -87,23 +96,21 @@
     #: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 comment)
+     (make <fixture-attribute>
+       #:name attr-name
+       #:range attr-range
+       #:type 'continuous
+       #:home-value attr-home-value
+       #:comment comment))
     ((_ attr-name attr-range attr-home-value)
      (make <fixture-attribute>
        #:name attr-name
@@ -119,11 +126,24 @@
        #:name attr-name
        #:range attr-allowed-values
        #:type 'list
-       #:home-value attr-home-value))))
+       #:home-value attr-home-value))
+    ((_ attr-name attr-allowed-values attr-home-value comment)
+     (make <fixture-attribute>
+       #:name attr-name
+       #:range attr-allowed-values
+       #:type 'list
+       #:home-value attr-home-value
+       #:comment comment))))
 
 
 (define-syntax attr-colour
   (syntax-rules ()
+    ((_ attr-name attr-home-value comment)
+     (make <fixture-attribute>
+       #:name attr-name
+       #:type 'colour
+       #:home-value attr-home-value
+       #:comment comment))
     ((_ attr-name attr-home-value)
      (make <fixture-attribute>
        #:name attr-name
@@ -131,6 +151,9 @@
        #:home-value attr-home-value))))
 
 
+(define-generic scanout-fixture)
+
+
 (define (get-fixture-attrs fix)
   (slot-ref fix 'attributes))
 
@@ -139,34 +162,20 @@
   (is-a? f <fixture>))
 
 
-(define-method (find-attr (fix <fixture>) (attr-name <symbol>))
+(define (find-attr fix attr-name)
   (find (lambda (a)
           (eq? (get-attr-name a)
                attr-name))
         (get-fixture-attrs fix)))
 
 
-(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>))
+(define (get-attr-home-val fix attr)
   (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)))
@@ -177,28 +186,30 @@
        (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-syntax define-fixture
+  (syntax-rules (fixture-attributes)
 
-(define (percent->dmxval16 val)
-  (scale-to-range val '(0 100) '(0 65535)))
+    ((_ classname
+        (fixture-attributes attr ...)
+        scanout-code ...)
 
+     (begin
+       (define-class classname (<fixture>)
+         (attributes #:init-form (list attr ...)))
+       (define-method (scanout-fixture (fixture classname))
+         scanout-code ...)))))
 
-(define (round-dmx a)
-  (inexact->exact
-   (min 255 (max 0 (round a)))))
 
+(define fixture-has-attr? find-attr)
 
-(define (scale-to-range val orig-range dest-range)
 
-  (define (range r)
-    (- (cadr r) (car r)))
+(define (next-attr-item attr cval)
+  (next-item-in-list
+    (get-attr-range attr)
+    cval))
 
-  (+ (car dest-range)
-     (* (range dest-range)
-        (/ (- val (car orig-range))
-           (range orig-range)))))
 
+(define (prev-attr-item attr cval)
+  (next-item-in-list
+    (reverse (get-attr-range attr))
+    cval))