;;; Commentary:
;;
;; A reimplementation of GStreamer's sine src in scheme. It's slow slow
;; slow -- my PIII/600 laptop can't do it in realtime. This is really
;; just a proof of concept.
;;
;;; Code:

(define-module (examples gstreamer sinesrc)
  :use-module (gnome gstreamer)
  :use-module (gnome gobject primitives)
  :export (<scm-sinesrc>))

(read-set! keywords 'prefix) ;; :keywords rather than #:keywords

(define-gobject-class <scm-sinesrc> <gst-element> "scm-sinesrc")

(let-params <scm-sinesrc>
            ((sample-rate (<gparam-int>
                           :nick "Sample rate" :blurb "Sample rate"
                           :minimum 4000 :maximum 48000 :default-value 44100
                           :flags '(read write construct)))
             (table-size (<gparam-int>
                          :nick "Table size" :blurb "Size of wavetable"
                          :minimum 1 :maximum gruntime:int-max :default-value 1024
                          :flags '(read write construct)))
             (buffer-size (<gparam-int>
                           :nick "Buffer size" :blurb "Buffer size (frames)"
                           :minimum 1 :maximum gruntime:int-max :default-value 1024
                           :flags '(read write construct)))
             (frequency (<gparam-float>
                         :nick "Frequency" :blurb "Frequency of sine source"
                         :minimum 0.0 :maximum 20000.0 :default-value 440.0
                         :flags '(read write construct)))
             (volume (<gparam-float>
                      :nick "Volume" :blurb "Volume of sine source"
                      :minimum 0.0 :maximum 1.0 :default-value 0.8
                      :flags '(read write construct)))
             (src-pad #f)
             (timestamp #f)
             (wavetable #f)
             (new-caps? #f)
             (table-pos #f))

  ;; the defines need to come before the define-methods

  (define uv-set! uniform-vector-set!)
  (define uv-ref uniform-vector-ref)

  (define (populate-sinetable src)
    (let* ((tsize (table-size src))
           (t (make-uniform-vector tsize 1.0))
           (pi2scaled (/ (* 3.141592653589 2 ) tsize)))
      (let loop ((i 0))
        (uv-set! t i (sin (* i pi2scaled)))
        (if (eq? (1+ i) tsize)
            #t
            (loop (1+ i))))
      (set! (wavetable src) t)))
  
  (define (get-func pad)
    (let* ((this (get-parent pad))
           (data-len (buffer-size this))
           (data (make-uniform-vector data-len 's)) ;; a vector of shorts
           (buffer (gst-buffer-new))
           (table-size (table-size this))
           (wavetable (wavetable this))
           (volume (volume this))
           (table-step (* table-size (/ (frequency this) (sample-rate this)))))
;;      (set-timestamp buffer (timestamp this))
      (gst-buffer-set-data buffer data)
      
;;      (set! (timestamp this) (+ (timestamp this) (* data-len gst:second)))
      
      (let ((lookup 0) (lookup-next 0) (f 0.0))
        (do ((i 0 (1+ i))
             (pos (table-pos this) (+ pos table-step)))
            ((eq? i data-len) (set! (table-pos this) pos))
          (set! lookup (modulo (inexact->exact (floor pos)) table-size))
          (set! lookup-next (modulo (1+ lookup) table-size))
          (set! f (- pos (floor pos)))
          
          ;; linear interpolation
          (uv-set! data i (inexact->exact
                           (* (+ (* f (uv-ref wavetable lookup-next))
                                 (* (- 1 f) (uv-ref wavetable lookup)))
                              (* volume 32767))))))
      
      (if (new-caps? this)
          (let ((caps (gst-caps-new
                       "sinesrc-src" "audio/raw"
                       (gst-props-new
                        '("format" string-type "int")
                        '("channels" int-type 1)
                        `("rate" int-type ,(sample-rate this))
                        '("law" int-type 0)
                        `("endianness" int-type ,gruntime:byte-order)
                        '("signed" boolean-type #t)
                        '("depth" int-type 16)
                        '("width" int-type 16)))))
            (try-set-caps (src-pad this) caps)
            (set! (new-caps? this) #f)))
      
      buffer))
  
  (define-method (gobject:set-property (obj <scm-sinesrc>) (name <symbol>) value)
    (case name
      ((sample-rate)
       (set! (sample-rate obj) value)
       (set! (new-caps? obj) #t))
      ((table-size)
       (set! (table-size obj) value)
       (populate-sinetable obj))
      ((buffer-size)
       (set! (buffer-size obj) value))
      ((frequency)
       (set! (frequency obj) value))
      ((volume)
       (set! (volume obj) value))
      (else
       (error "Unknown property: " name))))

  (define-method (gobject:get-property (obj <scm-sinesrc>) (name <symbol>))
    (case name
      ((sample-rate) (sample-rate obj))
      ((table-size) (table-size obj))
      ((buffer-size) (buffer-size obj))
      ((frequency) (frequency obj))
      ((volume) (volume obj))
      (else (error "Unknown property: " name))))

  (define-method (gobject:instance-init (class <gst-element>) (obj <scm-sinesrc>))
    (let* ((templates (get-pad-templates <scm-sinesrc>))
           (src-template (get-pad-template templates "src"))
           (src (gst-pad-new-from-template src-template "src")))
      (set! (src-pad obj) src)
      (add-pad obj src)
      (set-get-function src get-func)
      
      ;; no dparams (yet), sorry...
      ;; wavetable will be populated on construction automagically

      (set! (table-pos obj) 0.0)
      (set! (timestamp obj) 0)))

  (add-pad-template
   <scm-sinesrc>
   (gst-pad-template-new
    "src" 'src 'always
    (gst-caps-new
     "sinesrc-src" "audio/raw"
     (gst-props-new
      '("format" string-type "int")
      '("channels" int-type 1)
      '("rate" int-range-type 8000 48000)
      '("law" int-type 0)
      `("endianness" int-type ,gruntime:byte-order)
      '("signed" boolean-type #t)
      '("depth" int-type 16)
      '("width" int-type 16)))))
  
  (register-new-element <scm-sinesrc> "scm-sinesrc"))