;; ctl.scm - (c) rohan drape, 2003-2007

(module ctl scheme/base
(require (only-in srfi/1 third lset-adjoin lset-difference)
	 (prefix-in s: srfi/48)
	 rsc3/rsc3)
(provide (all-defined-out))

(define-structure ctl server index name internal spec depth state recv)

(define (make-ctl* server index)
  (make-ctl server index "none" 0.0 (make-spec* 0.0 1.0 'linear) 1 0 (list)))

(define (ctl-on-edit c)
  (let ((index (ctl-index c))
	(spec (ctl-spec c))
	(value (ctl-value c))
	(state (ctl-state c)))
    (if (ctl-server c)
	(-> (ctl-server c) (/c_set index value))
	#f)
    (for-each (lambda (receiver)
		(receiver index spec value state))
	      (ctl-recv c))))

(define (ctl-on-value-modified c)
  (if (> (ctl-depth c) 1)
      (set-ctl-state! c (round-exact (* (ctl-internal c) (- (ctl-depth c) 1))))
      #f)
  (ctl-on-edit c))

(define (ctl-on-state-modified c)
  (if (= (ctl-depth c) 1)
      (set-ctl-internal! c 0)
      (set-ctl-internal! c (* (ctl-state c) (/ 1 (- (ctl-depth c) 1)))))
  (ctl-on-edit c))

(define (edit-ctl-name c name)
  (set-ctl-name! c name)
  (ctl-on-edit c))

(define (ctl-display-name c)
  (if (= (ctl-depth c) 1)
      (ctl-name c)
      (s:format "~a:~a" (ctl-name c) (ctl-state c))))

(define (edit-ctl-spec c spec)
  (set-ctl-spec! c spec)
  (ctl-on-edit c))

(define (edit-ctl-internal c z)
  (set-ctl-internal! c z)
  (ctl-on-value-modified c))

(define (ctl-value c)
  (spec-map (ctl-spec c) (ctl-internal c)))

(define (edit-ctl-value c z)
  (set-ctl-internal! c (spec-unmap (ctl-spec c) z))
  (ctl-on-value-modified c))

(define (ctl-update c)
  (if (ctl-server c)
      (let ((r (->< (ctl-server c) (/c_get (ctl-index c)))))
	(edit-ctl-value c (third r)))
      #f))

(define (ctl-recv-add c p)
  (set-ctl-recv! c (lset-adjoin equal? (ctl-recv c) p)))

(define (ctl-recv-remove c p)
  (set-ctl-recv! c (lset-difference equal? (ctl-recv c) (list p))))

(define (ctl-recv-clear c)
  (set-ctl-recv! c (list)))

(define (set-ctl-depth* c z)
  (if (< z 1)
      (error "ctl-depth: domain error" c z)
      #f)
  (set-ctl-depth! c (max z 1))
  (set-ctl-state! c (modulo (ctl-state c) (ctl-depth c)))
  (ctl-on-state-modified c))

(define (edit-ctl-state c n)
  (let ((depth (ctl-depth c)))
    (if (or (< n 0) (>= n depth))
	(error "edit-ctl-state: domain error" c depth)
	#f)
    (set-ctl-state! c n)
    (ctl-on-state-modified c)))

(define (ctl-increment c n)
  (edit-ctl-state c (modulo (+ (ctl-state c) n) (ctl-depth c))))

(define (ctl-setup c name spec value depth)
  (begin (set-ctl-name! c name)
	 (set-ctl-internal! c 0)
	 (set-ctl-depth! c depth)
	 (set-ctl-state! c 0)
	 (set-ctl-spec! c (or spec (make-spec* 0.0 1.0 'linear)))
	 (if value
	     (edit-ctl-value c value)
	     (ctl-on-edit c))))

(define (inform . l)
  (for-each display l)
  (newline))

(define (ctl-display c)
  (inform "<Ctl>         ")
  (inform " Index        " (ctl-index c))
  (inform " Name         " (ctl-name c))
  (inform " Display Name " (ctl-display-name c))
  (inform " Internal     " (ctl-internal c))
  (inform " Value        " (ctl-value c))
  (inform " Depth        " (ctl-depth c))
  (inform " State        " (ctl-state c)))

)