path: root/guile/nanolight/fixture.scm

(define-module (nanolight fixture)
  #:use-module (oop goops)
  #:use-module (ice-9 threads)
  #:use-module (web client)
  #:use-module (web http)
  #:use-module (web uri)
  #:export (<fixture> <fixture-attribute>
             patch-fixture patch-many
             fixture-string fixture-address-string
             percent->dmxval msb lsb chan
             start-addr universe
             assign-attr!))

(use-modules (srfi srfi-1))

(define-class <fixture-attribute> (<object>)

  (name
    #:init-value 'unnamed-attribute
    #:init-keyword #:name
    #:getter name)

  (range
    #:init-value '()
    #:init-keyword #:range
    #:getter range)

  (type
    #:init-value 'continuous
    #:init-keyword #:type
    #:getter type)

  (home-value
    #:init-value 0
    #:init-keyword #:home-value
    #:getter home-value)

  (value-func
    #:init-value (lambda () 0)
    #:init-keyword #:value-func
    #:getter value-func
    #:setter set-value-func!)

  (translator
    #:init-value (lambda (universe start-addr value set-dmx) #f)
    #:init-keyword #:translator
    #:getter translator))


(define-class <fixture> (<object>)

  (attributes
    #:init-value '()
    #:init-keyword #:attributes
    #:getter get-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!))


;; Association list of fixtures
(define fixtures '())


(define (universe fixture-name)
  (get-universe (assq-ref fixtures fixture-name)))

(define (start-addr fixture-name)
  (get-start-addr (assq-ref fixtures fixture-name)))

(define (friendly-name fixture-name)
  (get-friendly-name (assq-ref fixtures fixture-name)))

(define (attributes fixture-name)
  (get-attributes (assq-ref fixtures fixture-name)))


(define (find-attribute-by-name attr-list attr-name)
  (find
    (lambda (a)
      (eq? (name a) attr-name))
    attr-list))


;; Place an attribute of the physical lighting fixture
;; under the control of the given function
(define (assign-attr! fix-name attr-name value-func)
  (set-value-func!
    (find-attribute-by-name
      (attributes fix-name)
      attr-name)
    value-func))


(define (fixture-address-string fix)
  (string-append
    (number->string (universe fix))
    "."
    (number->string (start-addr fix))))


(define (fixture-string fix)
  (string-append
    (friendly-name fix)
    " at "
    (fixture-address-string fix)))


(define (home-attribute attr)
  (let ((attr-home-value (home-value attr)))
    (set-value-func! attr (lambda () attr-home-value))))


(define (home-all-attributes fix)
  (for-each home-attribute
            (get-attributes fix)))


(define output #f)

(define (patch-fixture fixture-name attributes universe start-addr friendly-name)
  (let ((new-fixture (make <fixture>
                       #:attributes (copy-tree attributes)
                       #:uni universe
                       #:sa start-addr
                       #:friendly-name friendly-name)))
    (home-all-attributes new-fixture)
    (unless output
      (set! output (make-output)))
    (output 'add-fixture fixture-name new-fixture)
    new-fixture))


(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 (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 (make-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)))

    (define (run-scanout)
      (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 fixtures
        (for-each (lambda (fix-assoc-entry)

                    ;; Scan out one fixture
                    (let ((fix (cdr fix-assoc-entry)))
                      (for-each (lambda (attr)
                                  (let ((trans (translator attr)))
                                    (trans (get-universe fix)
                                           (get-start-addr fix)
                                           ((value-func attr))
                                           set-dmx)))
                                (get-attributes fix))))

          fixtures)

        ;; Send everything to OLA
        (for-each (lambda (a)
                    (send-to-ola ola-uri
                                 ola-socket
                                 a))
          universes))

      (yield)
      (run-scanout))

    ;; Start sending output
    (make-thread run-scanout)

    ;; Method functions
    (define (add-fixture fixture fixture-name)
      (set! fixtures (acons fixture fixture-name fixtures)))

    (lambda args
      (apply
        (case (car args)
          ((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))))))))