From bdc091b5e0f9264e80a392a75fe88c0f3406beef Mon Sep 17 00:00:00 2001
From: Thomas White <taw@physics.org>
Date: Wed, 17 Jun 2020 22:03:49 +0200
Subject: New implementation of patch-many

---
 guile/nanolight/fixture.scm | 91 ++++++++++++---------------------------------
 1 file changed, 23 insertions(+), 68 deletions(-)

diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm
index ffbfd74..7fdb5c4 100644
--- a/guile/nanolight/fixture.scm
+++ b/guile/nanolight/fixture.scm
@@ -150,6 +150,29 @@
     new-fixture))
 
 
+(define* (patch-many fixture-name-base
+                     attribute-generator
+                     start-addresses
+                     #:key (universe 1) (friendly-name "Fixture"))
+
+  (let again ((i 1)
+              (addr-list start-addresses))
+
+    (patch-fixture (symbol-append fixture-name-base
+                                  (string->symbol
+                                   (number->string i)))
+                   attribute-generator
+                   (car addr-list)
+                   #:universe universe
+                   #:friendly-name (string-append
+                                    friendly-name
+                                    (number->string i)))
+
+    (unless (null? (cdr addr-list))
+      (again (+ i 1)
+             (cdr addr-list)))))
+
+
 (define (round-dmx a)
   (min 255 (max 0 (round a))))
 
@@ -251,71 +274,3 @@
           ((add-fixture) add-fixture)
           (else => (error "Invalid method")))
         (cdr args)))))
-
-
-(define (symbol-append a b)
-  (string->symbol
-   (string-append
-    (symbol->string a)
-    (symbol->string b))))
-
-(define (number->symbol n)
-  (string->symbol
-   (number->string n)))
-
-
-(define-syntax patch-many
-  (lambda (x)
-    (syntax-case x ()
-
-      ;; Base case: count = 0
-      ((_ 0
-          base-label
-          offset
-          base-addr
-          fixture-class
-          universe
-          friendly-name)
-       (and
-        (number? (syntax->datum #'offset))
-        (symbol? (syntax->datum #'base-label)))
-       #'(if #f #f))      ; Return unspecified
-
-      ;; General case: count is a number
-      ((_ count
-          base-label
-          offset
-          base-addr
-          fixture-class
-          universe
-          friendly-name)
-
-       (and
-        (number? (syntax->datum #'count))
-        (number? (syntax->datum #'offset))
-        (symbol? (syntax->datum #'base-label)))
-
-       (let ((make-id (lambda (first second)
-                        (datum->syntax
-                         x
-                         (symbol-append (syntax->datum first)
-                                        (number->symbol
-                                         (syntax->datum second))))))
-             (minus-one (lambda (num)
-                           (- (syntax->datum num) 1)))
-
-             (plus-one (lambda (num)
-                          (+ (syntax->datum num) 1))))
-
-         (with-syntax ((fixture-name (make-id #'base-label #'offset))
-                       (next-count (minus-one #'count))
-                       (next-offset (plus-one #'offset)))
-           #'(begin
-               (define fixture-name 'fixture-name)
-               (patch-many next-count
-                           base-label
-                           next-offset
-                           base-addr
-                           fixture-class
-                           universe
-                           friendly-name))))))))
-- 
cgit v1.2.3