(define-module (nanolight fixture)
  #:use-module (oop goops)
  #:use-module (ice-9 threads)
  #:export (<fixture> <fixture-attribute>
             make-output
             patch-fixture
             fixture-string get-address-string
             percent->dmxval
             get-start-addr get-universe))

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

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

  (address-string
    #:init-value #f
    #:allocation #:virtual
    #:getter get-address-string
    #:slot-ref (lambda (a)
                 (string-append
                   (number->string (slot-ref a 'universe))
                   "."
                   (number->string (slot-ref a 'start-addr))))
    #:slot-set! (lambda (a s) #f)))


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


(define (patch-fixture output attributes universe start-addr friendly-name)
  (let ((new-fixture (make <fixture>
                       #:attributes attributes
                       #:uni universe
                       #:sa start-addr
                       #:friendly-name friendly-name)))
    (output 'add-fixture new-fixture)
    new-fixture))


; FIXME: Clamp to range
(define (percent->dmxval val)
  (/ (* 256 val) 100))


(define (show-state output state)
  (output 'show-state state))

(define (find-attribute fix attr)
  (find (lambda (a)
          (eq? (name a) attr))
    (attributes fix)))


(define (round-dmx a)
  (min 255 (max 0 (round a))))

(define (make-output)

  (let ((fixtures '()))

    (define (run-scanout)

      (let ((universes '()))

        (define (set-dmx universe addr nbytes value)
          ; FIXME: 16 bit values
          (unless (assq universe universes)
            (set! universes (acons
                              universe
                              (make-u8vector 512 0)
                              universes)))
          (u8vector-set!
            (assq-ref universes universe)
            addr (round-dmx value)

                (trans
                  (get-universe (fixture state-assignment))
                  (get-start-addr (fixture state-assignment))
                  ((value-func state-assignment))
                  set-dmx)))


        (for-each execute-state-assignment current-state)

        (display universes)
        (display "\r"))

      (yield)
      (run-scanout))

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

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

    (lambda args
      (apply
        (case (car args)
          ((add-fixture) add-fixture)
          (else => (error "Invalid method")))
        (cdr args)))))