#lang racket
(require "rsound.rkt"
racket/gui
racket/class)
(provide rsound-draw
vectors-draw
interpolate
rasterize-column
abs-max-from)
(define channels 2)
(define (make-sound-drawing-callback left-getter right-getter vec-len)
(let ([sound-max (max (abs-max-from left-getter vec-len)
(abs-max-from right-getter vec-len))])
(lambda (canvas dc)
(let* ([h (send canvas get-height)]
[half-h (/ h 2)]
[w (send canvas get-width)]
[frames vec-len]
[h-scale (/ (- frames 1) (- w 1))]
[v-scale (/ (/ half-h 2) sound-max)]
[upper-centerline (* 1/2 half-h)]
[lower-centerline (* 3/2 half-h)])
(for ([i (in-range 1 (- w 1))])
(let ([raster-left (* h-scale (- i 1/2))]
[raster-right (* h-scale (+ i 1/2))])
(let*-values ([(left-min left-max) (rasterize-column left-getter raster-left raster-right)]
[(right-min right-max) (rasterize-column right-getter raster-left raster-right)])
(send dc draw-line
i (inexact->exact (floor (- upper-centerline (* v-scale left-max))))
i (inexact->exact (floor (- upper-centerline (* v-scale left-min)))))
(send dc draw-line
i (inexact->exact (floor (- lower-centerline (* v-scale right-max))))
i (inexact->exact (floor (- lower-centerline (* v-scale right-min))))))))))))
(define (abs-max-from getter limit)
(for/fold ([abs-max 0])
([i (in-range limit)])
(max (abs (getter i)) abs-max)))
(define (rasterize-column getter left-edge right-edge)
(let* ([left-edge-left-value (interpolate getter left-edge)]
[left-edge-right-value (interpolate getter right-edge)]
[in-between-left-values (for/list ([i (in-range (ceiling left-edge) (floor right-edge))])
(getter i))]
[all-vals (cons left-edge-left-value (cons left-edge-right-value in-between-left-values))]
[left-min (apply min all-vals)]
[left-max (apply max all-vals)])
(values left-min left-max)))
(define (interpolate get-sample n)
(let* ([fl (floor n)]
[frac (- n fl)])
(+ (* (- 1 frac) (get-sample fl)) (* frac (get-sample (+ fl 1))))))
(define sound-canvas%
(class canvas%
(init-field len)
(init-field frame-num-text)
(inherit get-width get-parent)
(define/override (on-event evt)
(let* ([x (send evt get-x)])
(send frame-num-text begin-edit-sequence #f)
(send frame-num-text erase)
(send frame-num-text insert (number->string (pixel->frame x)))
(send frame-num-text end-edit-sequence)))
(define (pixel->frame x)
(floor (* len (/ x (get-width)))))
(super-new)))
(define (vectors-draw title left-getter right-getter len width height)
(let* ([f (new frame% [label title] [width width] [height height])]
[t (new text%)]
[c (new sound-canvas%
[parent f]
[paint-callback (make-sound-drawing-callback left-getter right-getter len)]
[len len]
[frame-num-text t])]
[ec (new editor-canvas%
[parent f]
[editor t]
[style '(no-border no-hscroll no-vscroll)]
[stretchable-width #f]
[stretchable-height #f]
[horizontal-inset 1]
[vertical-inset 1]
[min-width 50]
[min-height 20])])
(send f show #t)))
(define (rsound-draw sound #:title [title "picture of sound"] #:width [width 800] #:height [height 200])
(vectors-draw title
(lambda (i) (rsound-nth-sample/left sound i))
(lambda (i) (rsound-nth-sample/right sound i))
(rsound-frames sound)
width
height))