(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>
             start-ola-output patch-fixture patch-many
             fixture-string fixture-address-string
             percent->dmxval msb lsb chan
             get-fixture-start-addr get-fixture-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 (get-fixture-universe fixture-name)
  (get-universe (assq-ref fixtures fixture-name)))

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

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

(define (get-fixture-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
      (get-fixture-attributes fix-name)
      attr-name)
    value-func))


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


(define (fixture-string fix)
  (string-append
    (get-fixture-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* (patch-fixture fixture-name
                        attribute-generator
                        start-addr
                        #:key (universe 1) (friendly-name "Fixture"))
  (let ((new-fixture (make <fixture>
                       #:attributes (attribute-generator)
                       #:uni universe
                       #:sa start-addr
                       #:friendly-name friendly-name)))
    (home-all-attributes new-fixture)
    (set! fixtures (acons fixture-name
                          new-fixture
                          fixtures))))


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

(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 (start-ola-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)))

    (begin-thread
     (let scanout-loop ()

        (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)
        (scanout-loop)))))