#lang racket

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

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

(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 (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 hold push saw)
             [(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 (stx-map sl->synth-def #'(body-stx ...))])
                (make-synth-def (apply append (map synth-def-states (append body (map cdr formals))))
                                #`(let #,(map (λ (f) (list (car f) (synth-def-sr-form (cdr f)))) formals)
                                    #,@(map synth-def-sr-form body))))]              
             [(hold ([var init] ...) body-stx ...)
              (let ([body (stx-map sl->synth-def #'(body-stx ...))])
                (make-synth-def (apply append (stx-map (λ (i) (list (stx-car i) (eval (stx-cdr i)))) #'((var . init) ...))
                                       (map synth-def-states body))
                                (cons #'begin (map synth-def-sr-form body))))]
             [(push holder arg-sl)
              (let ([arg (sl->synth-def #'arg-sl)])
                (make-synth-def (synth-def-states arg) #`(set! holder #,(synth-def-sr-form arg))))]
             [(saw freq phase)
              (sl->synth-def
               #'(hold ([acc 0.0])
                       (lt ([result (+ acc phase)])
                           (push acc (+ acc (* 1/44100 freq)))
                           (- result (floor result)))))]
             [(fun . args) (fun->synth-def sl-stx #'fun #'args)])]))
  (trace sl->synth-def)
  )


(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-rule (saw-err freq phase)
  (hold ([acc 0.0])
        (lt ([result (+ acc phase)])
            (push acc (+ acc (* 1/44100 freq)))
            (- result (floor result)))))