#lang racket

(require portaudio/s16vec-play ffi/vector racket/stxparam)

(require (for-syntax racket/base syntax/stx racket/syntax))

(define channels 2)

(begin-for-syntax
  
  (define (stx-append . rest)
    (apply append (map stx->list rest)))
  
  (struct synth-def (states sr-form) #:constructor-name make-synth-def #:prefab)
  
  (define (saw->synth-def sl-stx fr)
    (let* ([fr (sl->synth-def fr)]
           [acc (generate-temporary)])
      (make-synth-def (cons (list acc 0.0) (synth-def-states fr))
                      #`(let* ([result #,acc])
                          (set! #,acc (+ result (* 1/44100 #,(synth-def-sr-form fr))))
                          (when (> #,acc 1) (set! #,acc (- #,acc (floor #,acc))))
                          result))))
  
  (define (fun->synth-def sl-stx fun args)
    (let ([args (map sl->synth-def (stx->list args))])
      (make-synth-def (apply append (map synth-def-states args))
                      (datum->syntax sl-stx
                                     (cons fun (map synth-def-sr-form args))
                                     sl-stx))))
  
  (define (sl->synth-def sl-stx)
    (define sl (syntax-e sl-stx))
    (cond [(number? sl) (make-synth-def '() sl-stx)]
          [(symbol? sl) (make-synth-def '() sl-stx)]
          [(list? sl)
           (syntax-case sl-stx ()
             [(lt ([var expr-stx] ...) body-stx)
              (let* ([formals (stx-map (λ (f) (cons (stx-car f) (sl->synth-def (stx-cdr f))))
                                       #'((var . expr-stx) ...))]
                     [body (sl->synth-def #'body-stx)])
                (make-synth-def (apply append (map synth-def-states (cons body (map cdr formals))))
                                #`(let #,(map (λ (f) (list (car f) (synth-def-sr-form (cdr f)))) formals)
                                    #,(synth-def-sr-form body))))]              
             [(saw fr) (saw->synth-def sl-stx #'fr)]
             [(fun . args) (fun->synth-def sl-stx #'fun #'args)])])))

(define-syntax (play stx)
  (syntax-case stx ()
    [(_ sl secs)
     (let ([sd (sl->synth-def #'sl)])
       #`(let ([v (make-s16vector (* channels 44100 secs))]
               #,@(synth-def-states sd))
           (for ([i (in-range (* 44100 secs))])
             (define sample #,(synth-def-sr-form sd))
             (cond [(number? sample) (set! sample (vector sample sample))]
                   [(list? sample) (set! sample
                                         (vector (first sample)
                                                 (if (empty? (cdr sample))
                                                     (first sample)
                                                     (second sample))))]
                   [(vector? sample) (when (< (vector-length sample) 2)
                                       (set! sample
                                         (vector (vector-ref sample 0)
                                                 (vector-ref sample 0))))])
             (s16vector-set! v (* i channels) (inexact->exact (round (* 32767 (vector-ref sample 0)))))
             (s16vector-set! v (add1 (* i channels)) (inexact->exact (round (* 32767 (vector-ref sample 1))))))
           (s16vec-play v 0 #f 44100)))]))


(define-syntax (repl stx)
  (syntax-case stx ()
    [(_ ([id sequence-expr] ...) body)
     (datum->syntax stx
                    (cons vector (syntax-local-eval
                                #`(for/list ([id sequence-expr] ...)
                                    #`(let-syntax ([id (λ (stx) (datum->syntax #'id #,id #'id))] ...)
                                        body)))))]))

; (play (repl ([i (in-range 2)]) (saw (* (+ i 1) 400))) 3)
; (play (vector (saw (* (+ 0 1) 400)) (saw (* (+ 1 1) 400))) 3)