316 lines
11 KiB
Scheme
316 lines
11 KiB
Scheme
;;;
|
|
;;; Copyright (C) 2024 Skylar Widulski
|
|
;;;
|
|
;;; This file is part of Yammer.
|
|
;;;
|
|
;;; Yammer is free software: you can redistribute it and/or modify it under the
|
|
;;; terms of the GNU General Public License as published by the Free Software
|
|
;;; Foundation, either version 3 of the License, or (at your option) any later
|
|
;;; version.
|
|
;;;
|
|
;;; Yammer is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
|
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
|
|
;;; details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License along with
|
|
;;; Yammer. If not, see <https://www.gnu.org/licenses/>.
|
|
;;;
|
|
|
|
(define-module (yammer)
|
|
#:use-module (sdl2)
|
|
#:use-module (sdl2 blend-mode)
|
|
#:use-module (sdl2 events)
|
|
#:use-module (sdl2 render)
|
|
#:use-module (sdl2 rect)
|
|
#:use-module (sdl2 surface)
|
|
#:use-module (sdl2 video)
|
|
#:use-module (ice-9 binary-ports)
|
|
#:use-module (ice-9 futures)
|
|
#:use-module (ice-9 receive)
|
|
#:use-module (ice-9 threads)
|
|
#:use-module (ice-9 q)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (scheme base)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (system foreign)
|
|
#:use-module (yammer ffi)
|
|
#:export (start))
|
|
|
|
(define fd #f)
|
|
(define pa-simple #f)
|
|
|
|
(define using-fftw? #t)
|
|
(define using-pulse? #t)
|
|
(define source "/tmp/mpd.fifo")
|
|
(define source-type 'mpd)
|
|
(define pulse-latency 10)
|
|
(define bitrate 44100)
|
|
(define sample-factor 2)
|
|
(define fps 20)
|
|
(define resolution 1)
|
|
(define scale 1)
|
|
(define color #xff99c8ff)
|
|
(define bgcolor #x2e2016ff)
|
|
(define queue-size 1)
|
|
(define fft #f)
|
|
(define interpolation 0)
|
|
(define smoothing-mode 'none)
|
|
(define moving-average-block-size 24)
|
|
(define exponential-factor 0.5)
|
|
|
|
;; Define widely used constants in relation to config values
|
|
(define recip-fps (/ 1 fps))
|
|
(define sample-size
|
|
(exact (* 4 (round (* sample-factor (* (/ bitrate 4) recip-fps))))))
|
|
|
|
(define (start config:using-fftw? config:using-pulse? config:source
|
|
config:source-type config:pulse-latency config:bitrate
|
|
config:sample-factor config:fps config:resolution config:scale
|
|
config:color config:bgcolor config:queue-size config:fft
|
|
config:interpolation config:smoothing-mode
|
|
config:moving-average-block-size config:exponential-factor)
|
|
(set! using-fftw? config:using-fftw?)
|
|
(set! using-pulse? config:using-pulse?)
|
|
(set! source config:source)
|
|
(set! source-type config:source-type)
|
|
(set! pulse-latency config:pulse-latency)
|
|
(set! bitrate config:bitrate)
|
|
(set! sample-factor config:sample-factor)
|
|
(set! fps config:fps)
|
|
(set! resolution config:resolution)
|
|
(set! scale config:scale)
|
|
(set! color config:color)
|
|
(set! bgcolor config:bgcolor)
|
|
(set! queue-size config:queue-size)
|
|
(set! fft config:fft)
|
|
(set! interpolation config:interpolation)
|
|
(set! smoothing-mode config:smoothing-mode)
|
|
(set! moving-average-block-size config:moving-average-block-size)
|
|
(set! exponential-factor config:exponential-factor)
|
|
|
|
(set! recip-fps (/ 1 fps))
|
|
(set! sample-size
|
|
(exact (* 4 (round (* sample-factor (* (/ bitrate 4) recip-fps))))))
|
|
|
|
(if (and fft using-fftw?)
|
|
(set! plan (init_plan (exact (/ sample-size 4)))))
|
|
|
|
;; Initially open the MPD FIFO or connect to pulseaudio
|
|
(cond
|
|
((eq? source-type 'mpd)
|
|
(set! fd (open-fifo source)))
|
|
((eq? source-type 'pulse)
|
|
(set! pa-simple (make-pa-simple bitrate source pulse-latency))))
|
|
|
|
(sdl-init '(video events)) ;; Initialize SDL2
|
|
(set! window (make-window #:title "Yammer")) ;; Create window
|
|
(set-window-resizable! window #t) ;; Allow window resizing
|
|
(set! renderer (make-renderer window)) ;; Create renderer from window
|
|
|
|
(lp renderer fft) ;; Run the loop
|
|
|
|
(delete-renderer! renderer) ;; Free renderer on close
|
|
(close-window! window) ;; Close window
|
|
(sdl-quit) ;; Quit SDL2
|
|
(cond
|
|
((eq? source-type 'mpd)
|
|
(close-port fd))
|
|
((eq? source-type 'pulse)
|
|
(pa_simple_free pa-simple)))
|
|
|
|
;; Free FFT plan if FFT is enabled
|
|
(if (and fft using-fftw?) (monitor (fftw_destroy_plan plan))))
|
|
|
|
;; Plan definition (if using fft)
|
|
(define plan #f)
|
|
|
|
;; Initialize more values
|
|
(define window #f)
|
|
(define renderer #f)
|
|
(define bv (make-list (/ sample-size 2) 0))
|
|
(define queue (make-q))
|
|
|
|
;; Turns a list lst into a list of pairs (chunks of 2)
|
|
(define (chunk2 lst)
|
|
(if (>= (length lst) 2)
|
|
(cons (take lst 2)
|
|
(chunk2 (drop lst 2)))
|
|
'()))
|
|
|
|
;; Open the MPD FIFO
|
|
(define (open-fifo filename)
|
|
(define fd (open-input-file filename))
|
|
(fcntl fd F_SETFL (logior O_NONBLOCK
|
|
(fcntl fd F_GETFL)))
|
|
(setvbuf fd 'block sample-size)
|
|
fd)
|
|
|
|
;; Read from the MPD FIFO
|
|
(define (read-fifo fd)
|
|
(if (port-closed? fd)
|
|
(set! fd (open-fifo source)))
|
|
(define new-bv #vu8())
|
|
(define bytes-read 0)
|
|
(while (< bytes-read sample-size)
|
|
;; TODO: timeout this read operation somehow
|
|
(set! new-bv (bytevector-append new-bv (bytevector (read-u8 fd))))
|
|
(set! bytes-read (1+ bytes-read))
|
|
(set! new-bv (bytevector-append
|
|
new-bv (get-bytevector-n
|
|
fd (- sample-size bytes-read))))
|
|
(set! bytes-read (bytevector-length new-bv)))
|
|
(enq! queue (bytevector->sint-list new-bv (native-endianness) 2))
|
|
(if (>= (q-length queue) queue-size)
|
|
(set! bv (deq! queue))))
|
|
|
|
(define (read-pa pa)
|
|
(define new-bv
|
|
(bytevector->sint-list
|
|
(pointer->bytevector
|
|
(read_from_pa pa (/ sample-size 2))
|
|
(/ sample-size 2) (sizeof int16) 's16)
|
|
(native-endianness) 2))
|
|
(enq! queue new-bv)
|
|
(if (>= (q-length queue) queue-size)
|
|
(set! bv (deq! queue))))
|
|
|
|
;; Draw to renderer `ren' from chunked list `plst'
|
|
(define (draw ren plst)
|
|
(clear-renderer ren)
|
|
(define init-surf #f)
|
|
(define surf #f)
|
|
(receive (x y) (window-size window)
|
|
(set! init-surf (make-rgb-surface x y 32))
|
|
;; Make `surf' have rgba8888 pixel format, though alpha is unused
|
|
(set! surf (convert-surface-format init-surf 'rgba8888))
|
|
;; Free `init-surf' (unused)
|
|
(delete-surface! init-surf)
|
|
;; Create surface-wide rectangle
|
|
(fill-rect surf #nil color)
|
|
(let ((y-mid (round/ y 2)))
|
|
(do ((i 0 (+ i (* (/ x (length plst)) resolution)))
|
|
(j 0 (1+ j)))
|
|
((>= j (length plst)))
|
|
(fill-rect
|
|
surf
|
|
(make-rect
|
|
(floor i) 0
|
|
(* (ceiling/ x (length plst)) resolution)
|
|
;; Math to make `scale' a sane value
|
|
(exact
|
|
(- y-mid (abs (round/ (* y (car (list-ref plst j)))
|
|
(/ 76800 scale))))))
|
|
bgcolor)
|
|
;; This value is used twice, define in let statement
|
|
(let ((n (abs (round/ (* y (cadr (list-ref plst j)))
|
|
(/ 76800 scale)))))
|
|
(fill-rect
|
|
surf
|
|
(make-rect
|
|
(floor i) (exact (+ y-mid n))
|
|
(* (ceiling/ x (length plst)) resolution)
|
|
(exact
|
|
(- y-mid n)))
|
|
bgcolor)))))
|
|
;; Create texture from surface
|
|
(define texture (surface->texture ren surf))
|
|
;; Send to renderer
|
|
(render-copy ren texture)
|
|
(present-renderer ren)
|
|
;; Free `texture' and `surf'
|
|
(delete-texture! texture)
|
|
(delete-surface! surf))
|
|
|
|
;; Smooth non-chunked list `lst' with mode `type'
|
|
(define (smooth lst type)
|
|
(define input lst)
|
|
(define ret '())
|
|
(define window 0)
|
|
(if (> interpolation 0)
|
|
;; Interpolate FFT values
|
|
(begin
|
|
(set! input '())
|
|
(do ((i 0 (1+ i)))
|
|
((>= (1+ i) (length lst)))
|
|
(set! input (append input (list (list-ref lst i))))
|
|
(do ((j 0 (1+ j)))
|
|
((> j interpolation))
|
|
(let ((n (- (list-ref lst (1+ i)) (list-ref lst i))))
|
|
(set! input (append input (list (* (expt (1+ j) (/ n 100000))
|
|
(list-ref lst i))))))))))
|
|
(cond
|
|
((eq? type 'moving-average)
|
|
(do ((i 1 (1+ i)))
|
|
((>= i (- (length input) moving-average-block-size)))
|
|
(set! window (list-ref input (- i 1)))
|
|
(do ((j 0 (1+ j)))
|
|
((>= j moving-average-block-size))
|
|
(set! window (+ window (list-ref input (+ i j)))))
|
|
(set! window (round/ window moving-average-block-size))
|
|
(set! ret (append ret (list window)))))
|
|
((eq? type 'exponential)
|
|
(do ((i 0 (1+ i)))
|
|
((>= i (length input)))
|
|
(if (= i 0)
|
|
(set! ret (list (car input)))
|
|
(set! ret
|
|
(append
|
|
ret
|
|
(list
|
|
(/ (+ (list-ref ret (1- i))
|
|
(* exponential-factor
|
|
(- (list-ref input i)
|
|
(list-ref ret (1- i)))))
|
|
(/ (log (log (expt i 2))) (log 3)))))))))
|
|
(else (set! ret input)))
|
|
ret)
|
|
|
|
;; Run loop
|
|
(define (lp ren fft?)
|
|
(define read-future #f)
|
|
(define sleep-future #f)
|
|
(define plst '())
|
|
(while (not (window-closed-event? (poll-event))) ;; Break on window close
|
|
;; Initialize fps sleep to touch later
|
|
(set! sleep-future (future (usleep (round (* recip-fps 1000)))))
|
|
;; In the meantime, check if the read bytevector is the right size
|
|
(if (= (length bv) (/ sample-size 2))
|
|
(begin
|
|
;; Chunk the bytevector
|
|
(set! plst (chunk2 bv))
|
|
;; Read again
|
|
(cond
|
|
((eq? source-type 'mpd)
|
|
(set! read-future (future (read-fifo fd))))
|
|
((eq? source-type 'pulse)
|
|
(set! read-future (future (read-pa pa-simple)))))
|
|
|
|
(if (and fft? using-fftw?)
|
|
;; FFF smoothing enabled check
|
|
(if (not (equal? smoothing-mode #f))
|
|
(draw ren
|
|
(map list
|
|
(smooth (s16vector->list
|
|
(do-dft plan (map car plst)
|
|
(length plst)))
|
|
smoothing-mode)
|
|
(smooth (s16vector->list
|
|
(do-dft plan (map cadr plst)
|
|
(length plst)))
|
|
smoothing-mode)))
|
|
(draw ren
|
|
(map list
|
|
(s16vector->list
|
|
(do-dft plan (map car plst)
|
|
(length plst)))
|
|
(s16vector->list
|
|
(do-dft plan (map cadr plst)
|
|
(length plst))))))
|
|
;; No FFT
|
|
(if (not (equal? smoothing-mode #f))
|
|
(draw ren (map list (smooth (map car plst) smoothing-mode)
|
|
(smooth (map cadr plst) smoothing-mode)))
|
|
(draw ren plst)))))
|
|
(touch sleep-future)))
|