#!/usr/local/bin/mred -r

(load-extension "/usr/local/lib/plt/collects/fluxus-0.14/compiled/native/i386-linux/3m/fluxus-osc.so")

(require fluxus-osc)
(require (only (lib "1.ss" "srfi") make-list))

(osc-destination "osc.udp://127.0.0.1:4001")

(define patch-file "/home/dave/flotsam/daisy/daisy-patches1.scm")

(define sample-list (list (list 5 "/home/dave/noiz/pattern-cascade/electro_d/electro_d_snare01.wav")
                          (list 1 "/home/dave/noiz/pattern-cascade/electro_d/electro_d_clap.wav")
                          (list 2 "/home/dave/noiz/pattern-cascade/electro_d/electro_d_kick01.wav")
                          (list 3 "/home/dave/noiz/pattern-cascade/electro_d/electro_d_ophat.wav")
                          (list 4 "/home/dave/noiz/pattern-cascade/electro_d/electro_d_clhat01.wav")))

(define moog '("sub" (("typea" 8) ("freqa" 8) ("slidea" 10) ("typeb" 8) ("freqb" 8) ("slideb" 1) ("attacka" 5) 
                       ("decaya" 5) ("sustaina" 1) ("releasea" 5) ("volumea" 1) ("attackb" 5) ("decayb" 5)
                           ("sustainb" 1) ("releaseb" 5) ("volumeb" 1) ("attackf" 5) ("decayf" 5) ("sustainf" 1)
                           ("releasef" 5) ("volumef" 1) ("ftype" 5) ("cutoff" 1) ("resonance" 0.5) ("ring" 3)
                           ("lfodepth" 2) ("lfofreq" 10) ("crushfreq" 1) ("crushbits" 10) ("distort" 2) 
                           ("delayfb" 1) ("delay" 10) ("poly" 10) ("pan" 1) ("mainvolume" 5))))

(define fm '("fm" (("type" 8) ("freq" 8) ("slide" 1) ("modtype" 8) ("modfreq" 8) ("modslide" 1) ("fbattack" 5) 
                        ("fbdecay" 5) ("fbsustain" 1) ("fbrelease" 5) ("fbvolume" 1) ("modattack" 5) ("moddecay" 5)
                        ("modsustain" 1) ("modrelease" 5) ("modvolume" 5) ("attack" 5) ("decay" 5) ("sustain" 1)
                        ("release" 1) ("volume" 1) ("crushfreq" 1) ("crushbits" 10) ("distort" 2) ("delayfb" 1) 
                        ("delay" 10) ("poly" 10) ("pan" 1) ("mainvolume" 5))))

(define add '("add" (("type" 8) ("attack" 5) ("decay" 5) ("sustain" 1) ("release" 1) ("volume" 1)                          
                           ("harm0" 1)("harm1" 1) ("harm2" 1)("harm3" 1)("harm4" 1)("harm5" 1)("harm6" 1)
                           ("harm7" 1)("harm8" 1) ("crushfreq" 1) ("crushbits" 10) ("distort" 2) ("delayfb" 1) 
                           ("delay" 10) ("poly" 10) ("pan" 1) ("mainvolume" 5))))

(define sample '("sample" (("attack" 5) ("decay" 5) ("sustain" 1) ("release" 1) ("volume" 1) 
                              ("sampleid" 10)("reverse" 1)("percmode" 1) ("percfreq" 8)
                              ("crushfreq" 1) ("crushbits" 10) ("distort" 2) ("delayfb" 1) ("delay" 10) 
                              ("poly" 10) ("pan" 1) ("mainvolume" 5))))

(define current-instr 0)
(define num-instruments 7)
(define panels (make-vector num-instruments 0))
(define widgets '())
(define patches '())
(define instr-start 1)

(define (set-patch name value patch out)
  (if (string=? name (car patch))
      (set! out (append out (list name value)))
      (set! out (append out (list (car patch) (cadr patch)))))
  (if (null? (cddr patch))
      out
      (set-patch name value (cddr patch) out)))

(define (in-patch name patch)
  (if (string=? name (car patch))
      #t
      (if (null? (cddr patch))
          #f
          (in-patch name (cddr patch)))))

(define (value-patch name patch)
  (cond ((null? patch) 0)
        (else
         (if (string=? name (car patch))
             (cadr patch)
             (value-patch name (cddr patch))))))

(define (update-patch name value patch)
  (if (and (not (null? patch)) (in-patch name patch))
      (set-patch name value patch '())
      (append patch (list name value))))

(define (update-patches name value pnum patches)
  (map
   (lambda (patch)
     (set! pnum (- pnum 1))
     (cond ((zero? (+ pnum 1))            
            (list (car patch) (update-patch name value (cadr patch))))
           (else
            patch)))
   patches))
   

(define (resend-patch patch id)
  (display (+ id 1))(display " ")(display (car patch))(display " ")(display (cadr patch))(newline)
  (osc-send "/modify" "isf" (list (+ id instr-start) (car patch) (cadr patch)))
  (sleep 0.1)
  (if (null? (cddr patch))
      0
      (resend-patch (cddr patch) id)))

(define (randomise-patch patch id)
  (display (+ id 1))(display " ")(display (car patch))(display " ")(display (cadr patch))(newline)
  (osc-send "/modify" "isf" (list (+ id instr-start) (car patch) (cadr patch)))
  (sleep 0.1)
  (if (null? (cddr patch))
      0
      (resend-patch (cddr patch) id)))

(define (resend-patches patches id)
  (if (not (null? (car patches))) (resend-patch (car patches) id))
  (if (null? (cdr patches))
      0
      (resend-patches (cdr patches) (+ id 1))))

(define (randomise-patches patches id)
  (if (not (null? (car patches))) (randomise-patch (car patches) id))
  (if (null? (cdr patches))
      0
      (randomise-patches (cdr patches) (+ id 1))))


(define (update-instr-widgets widgets patch)
  (cond ((not (null? widgets))
         (let ((name (send (car widgets) get-label)))
           (send (car widgets) set-value (inexact->exact (* 1000 (value-patch name (cadr patch))))))
         (update-instr-widgets (cdr widgets) patch))))

(define (update-widgets widgets patches)
  (if (not (null? (car patches)))
      (update-instr-widgets (car widgets) (car patches)))
  (if (null? (cdr widgets))
      0
      (update-widgets (cdr widgets) (cdr patches))))

(define (make-instrument master parent instr count n sliders)
  (cond 
    ((null? instr)
     sliders)
    (else
     (cond 
       ((zero? n)
        (set! n count)
        (set! parent (instantiate vertical-pane% (master)))))
     (let ((max (inexact->exact (* 1000 (car (cdr (car instr)))))))
       (make-instrument master parent (cdr instr) count (- n 1) 
                        (cons (instantiate slider% ((car (car instr))) (min-value 0) (max-value max) 
                                (parent parent) (callback slider-cb) (vert-margin 0) (horiz-margin 0)
                                (min-height 1) (stretchable-height #f)) sliders))))))

(define (slider-cb slider control-event)
  (let ((name (send slider get-label))
        (value (/ (send slider get-value) 1000)))
    (set! patches (update-patches name value current-instr patches))
    (osc-send "/modify" "isf" (list (+ current-instr instr-start) name value))))

(define (tab-cb tab control-event)
  (let ((last-instr current-instr))
    (set! current-instr (send tab get-selection))
    (send tab delete-child (vector-ref panels last-instr))
    (send tab add-child (vector-ref panels current-instr))))

(define (add-instr instr id master)
  (let ((panel (if (zero? id) 
                   (instantiate horizontal-panel% (master))
                   (instantiate horizontal-panel% (master) (style (list 'deleted))))))
    (set! widgets (cons (make-instrument panel 0 (cadr instr) 10 0 '()) widgets))
    (set! patches (append patches (list (list (car instr) '()))))
    (vector-set! panels id panel)))

(define (save-cb button control-event)
  (if (file-exists? patch-file) (delete-file patch-file))
  (let ((f (open-output-file patch-file)))
    (write patches f)
    (write sample-list f)
    (close-output-port f)))

(define (load-cb button control-event)
  (let ((f (open-input-file patch-file)))
    (set! patches (read f))
    (set! sample-list (read f))
    (update-widgets widgets (reverse patches))
    (load-sample-list sample-list)
    (close-input-port f)))

(define (resend-cb button control-event)
  (resend-patches patches 0))

(define (randomise-cb button control-event)
  (randomise-patches patches 0))


(define (play-cb button control-event)
  (display current-instr)(newline)
  (osc-send "/play" "iiiffffi" (list 0 0 (+ current-instr instr-start) 440 440 1 0 79)))

(define (play2-cb button control-event)
  (osc-send "/play" "iiiffffi" (list 0 0 (+ current-instr instr-start) 220 220 1 0 79)))

(define (load-sample-list sample-list)
  (for-each 
   (lambda (sample)
     (osc-send "/addtoqueue" "is" (list (car sample) (cadr sample))))
   sample-list)
  (osc-send "/loadqueue" "" (list)))

(define (init-cb button control-event)
  (osc-send "/clear" "" (list))
  (load-sample-list sample-list)
  (osc-send "/setclock" "" (list))
  (osc-send "/addinstrument" "is" (list 1 "sub"))
  (osc-send "/addinstrument" "is" (list 2 "fm"))
  (osc-send "/addinstrument" "is" (list 3 "sub"))
  (osc-send "/addinstrument" "is" (list 4 "fm"))
  (osc-send "/addinstrument" "is" (list 5 "sub"))
  (osc-send "/addinstrument" "is" (list 6 "add"))
  (osc-send "/addinstrument" "is" (list 7 "sample"))
  )

(define frame (instantiate frame% ("itchy")))
(define tab (instantiate tab-panel% ((list "moog1" "fm1" "moog2" "fm2" "moog3" "add1" "sample")) (parent frame) (callback tab-cb)))
(define button-pane (instantiate horizontal-pane% (frame)))
(define save (instantiate button% ("save") (parent button-pane) (callback save-cb)))
(define load (instantiate button% ("load") (parent button-pane) (callback load-cb)))
(define resend (instantiate button% ("resend") (parent button-pane) (callback resend-cb)))
(define resend (instantiate button% ("randomise") (parent button-pane) (callback randomise-cb)))
(define resend (instantiate button% ("play") (parent button-pane) (callback play-cb)))
(define resend (instantiate button% ("play2") (parent button-pane) (callback play2-cb)))
(define resend (instantiate button% ("init") (parent button-pane) (callback init-cb)))

(add-instr moog 0 tab)
(add-instr fm 1 tab)
(add-instr moog 2 tab)
(add-instr fm 3 tab)
(add-instr moog 4 tab)
(add-instr add 5 tab)
(add-instr sample 6 tab)

(send frame show #t)

(osc-send "/setclock" "" (list))