(define-module (nanolight state)
  #:use-module (oop goops)
  #:export (print-state define-state exec-state!
             merge-states merge-rule-htp merge-rule-ltp
             merge-htp merge-ltp
             int flash pan tilt
             fixture attribute value-func))

(use-modules (nanolight fixture))
(use-modules (srfi srfi-1))


(define-class <state-assignment> (<object>)

  (fixture
    #:init-value #f
    #:init-keyword #:fixture
    #:getter fixture)

  (attribute
    #:init-value #f
    #:init-keyword #:attribute
    #:getter attribute)

  (value-func
    #:init-value #f
    #:init-keyword #:value-func
    #:getter value-func))


(define (state-assignment-string a)
  (string-append
    (fixture-string (fixture a))
    " / "
    (symbol->string (attribute a))
    " ---> "
    (number->string ((value-func a)))))


; Return #t if the two state assignments target the same parameter
; (i.e. in the same fixture)
(define-method (same-attr (a <state-assignment>) (b <state-assignment>))
  (and
    (eq? (fixture a) (fixture b))
    (eq? (attribute a) (attribute b))))


; Convenience functions
(define merge-htp
  (lambda a
    (apply merge-states merge-rule-htp a)))


(define merge-ltp
  (lambda a
    (apply merge-states merge-rule-ltp a)))


; Highest takes precedence: for intensity (only), create a new function
; which returns the highest value from the two inputs
; Otherwise, revert to LTP
(define (merge-rule-htp a b)
  (let (
         (funca (value-func a))
         (funcb (value-func b)))
    (if (eq? (attribute a) 'intensity)
      (lambda () (max (funca) (funcb)))
      funcb)))


; Latest takes precedence: just take whichever one comes last
(define (merge-rule-ltp a b)
  (value-func b))


; Merge states according to rule 'merge-rule'
(define (merge-states merge-rule . list-of-states)
  (fold
    (lambda (assignment-to-add combined-state)
      (let ((assignment-in-state (find
                                   (lambda (a)
                                     (same-attr assignment-to-add a))
                                   combined-state)))
        (cons (if assignment-in-state
                (make <state-assignment>
                  #:fixture (fixture assignment-to-add)
                  #:attribute (attribute assignment-to-add)
                  #:value-func (merge-rule
                                 assignment-in-state
                                 assignment-to-add))
                assignment-to-add)
          (delq assignment-in-state combined-state))))
    '() (apply append list-of-states)))


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


; Execute the state, i.e. apply it to the physical lighting rig
(define (exec-state! state)
  (for-each
    (lambda (a)
      (assign-attr!
        (fixture a)
        (attribute a)
        (value-func a)))
    state))


(define (sort-by-dmx-addr state)
  (stable-sort state (lambda (a b)
                       (or
                         (<
                           (universe (fixture a))
                           (universe (fixture b)))
                         (and
                           (eq?
                             (universe (fixture a))
                             (universe (fixture b)))
                           (<
                             (start-addr (fixture a))
                             (start-addr (fixture b))))))))


(define (print-state st)
  (for-each
    (lambda (a)
      (display (state-assignment-string a))
      (newline))
    (sort-by-dmx-addr st)))


(define-syntax define-state
  (syntax-rules ()

    [(_) #f]

    [(_ n) (define n '())]

    [(_ n st ...) (define n
                    (merge-states merge-rule-htp st ...))]))


; Helper functions

(define (hirestime)
  (let ((a (gettimeofday)))
    (+
      (car a)
      (/
        (cdr a)
        1000000))))

(define pi (* 2 (acos 0)))

(define (square-wave hz)
  (if (> (sin (* 2 pi hz (hirestime))) 0) 100 0))

(define (static-value attr value fix)
  (list (make <state-assignment>
          #:fixture fix
          #:attribute attr
          #:value-func (lambda () value))))


; Useful source functions

(define (int value fix)
  (static-value 'intensity value fix))

(define (pan value fix)
  (static-value 'pan value fix))

(define (tilt value fix)
  (static-value 'tilt value fix))

(define (flash hz fix)
  (list (make <state-assignment>
          #:fixture fix
          #:attribute 'intensity
          #:value-func (lambda ()
                         (square-wave hz)))))