diff options
author | Thomas White <taw@physics.org> | 2020-06-17 22:03:49 +0200 |
---|---|---|
committer | Thomas White <taw@physics.org> | 2020-06-17 22:03:49 +0200 |
commit | bdc091b5e0f9264e80a392a75fe88c0f3406beef (patch) | |
tree | 168e9c676e0ff81f3d730d9ea5e9cd4264ff7a56 | |
parent | 4d8c8cc36e7b37e6a7d5345b74156020f3cc5801 (diff) |
New implementation of patch-many
-rw-r--r-- | guile/nanolight/fixture.scm | 91 |
1 files 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)))))))) |