#!/usr/bin/newlisp

;; This is the main script for the pcm-dispatch tool
;; last main-arg nominates the configuration file

; ############################################################
; misc API
(signal 1 (fn (x) (exit 0)))
(signal 2 (fn (x) (exit 0)))
(signal 15 (fn (x) (exit 0)))

(define (die N)
  (when (args) (write-line 2 (join (map string (args)) " ")))
  (when (number? N) (exit N)))

(define (enlist X) (if (list? X) X (list X)))

(define (comment? LINE) (and (regex "^\\s*(#|$)" LINE 0) true))

(define (first-word LINE) (and (regex "^\\s*(\\S+)" LINE 0) $1))

(define (prog1 X) X)

(define (read-config-line LINE)
  (map (fn (x) (if (regex "^([^=]+)=(.*)" x) (list $1 $2) x))
       (map trim (find-all "([^, ]+)" LINE $1 0))))

;; ############################################################
;; Load Configuration (~/.alsa-dispatcher)
; Format: one-liners for each option, ignoring comment lines starting
; with # and blank lines.
(constant
 'HOME (env "HOME")
 'CONFIG (format "%s/.alsa-dispatcher" HOME)
 'CFGLINES (if (read-file CONFIG) (clean comment? (parse $it "\n" ))
             '("bt,latency=1000" "plughw"))
 'CFGMAP (map read-config-line CFGLINES)
 'PCM-LIST (map first-word CFGLINES)
 )

(define (cfg-lookup PCM KEY DEFAULT)
  (if (if (assoc PCM CFGMAP) (lookup KEY $it)) (read-expr $it) DEFAULT))

; ############################################################
; libc API
(constant 'libc.so.6 "/lib/x86_64-linux-gnu/libc.so.6")
; https://www.gnu.org/software/libc/manual/html_mono/libc.html

;; (dup2 OLDFD NEWFD) - Duplicate file descriptor OLDFD onto NEWFD,
;; closing the latter first if open.
(import libc.so.6 "dup2" "int"
        "int" ; int oldfd
        "int" ; int newfd
        )

; ############################################################
; libasound API
(constant 'libasound.so "/usr/lib/x86_64-linux-gnu/libasound.so")
; https://www.alsa-project.org/alsa-doc/alsa-lib/
; /usr/include/asm-generic/errno-base.h

;; Used constants
(constant
 'SND_PCM_STREAM_PLAYBACK 0
 'SND_PCM_MODE_BLOCK 0 ; this mode label is invented here
 'SND_PCM_FORMAT_S16_LE 2
 'SND_PCM_ACCESS_RW_INTERLEAVED 3
 )

;; (snd_pcm_close PCM) - Close PCM handle. Closes the given PCM handle
;; and frees all associated resources.
(import libasound.so "snd_pcm_close" "int"
        "void*" ; snd_pcm_t *pcm
        )

;; (snd_pcm_drain PCM) - Stop PCM whilst preserving pending frames.
;; For playback wait for all pending frames to be played and then stop
;; the PCM. For capture stop PCM permitting to retrieve residual
;; frames.
(import libasound.so "snd_pcm_drain" "int"
        "void*" ; snd_pcm_t *pcm
        )

;; (snd_pcm_open NAME STREAM MODE) - Opens a PCM and returns its
;; handle or nil. Actual error code is discarded.
(letex ((IMP (import libasound.so "snd_pcm_open" "int"
                     "void*" ; snd_pcm_t **pcmp [output]
                     "char*" ; const char *name
                     "int"   ; snd_pcm_stream_t stream
                     "int"   ; int mode
                     )))
  (constant 'snd_pcm_open ; redefine the symbol to wrap the import
   (fn (NAME STREAM MODE)
     (let ((PCM (pack "Lu" 0)))
       (when (= (IMP PCM NAME STREAM MODE)) ((unpack "Lu" PCM) 0))))))

;; (snd_pcm_set_params PCM FMT ACCESS CH RATE RESAMPLE LATENCY) - Set
;; the hardware and software parameters in a simple way.
(import libasound.so "snd_pcm_set_params" "int"
        "void*" ; snd_pcm_t *pcm
        "int"   ; snd_pcm_format_t format
        "int"   ; snd_pcm_access_t access
        "unsigned int" ; unsigned int channels
        "unsigned int" ; unsigned int rate
        "int"   ;int soft_resample
        "unsigned int" ; unsigned int latency
        )

;; (snd_pcm_writei PCM BUFFER FRAMES) - Write interleaved frames to a
;; PCM. If the blocking behaviour is selected and the PCM is running,
;; then routine waits until all requested frames are played or put to
;; the playback ring buffer. The returned number of frames can be less
;; only if a signal or underrun occurred.
(import libasound.so "snd_pcm_writei" "long" ; snd_pcm_uframes_t 
	"void*" ; snd_pcm_t *pcm
        "void*" ; const void *buffer
        "long"   ; snd_pcm_uframes_t size
        )

;; Open a PCM by name
(define (open-pcm NAME)
  (snd_pcm_open NAME SND_PCM_STREAM_PLAYBACK SND_PCM_MODE_BLOCK))

;; Setup PCM 
(define (setup-pcm PCM NAME)
  (snd_pcm_set_params PCM
                      (cfg-lookup NAME "format" SND_PCM_FORMAT_S16_LE)
                      SND_PCM_ACCESS_RW_INTERLEAVED
                      2 ; channels
                      48000 ; rate
                      1 ; soft resample (0/1)
                      (cfg-lookup NAME "latency" 100000) ; (microseconds)
                      ))

;; ############################################################
; The main program

;; redirect stdout/err to /dev/null
(when true
  (let ((REDIR (open "/dev/null" "append")))
    (when (< REDIR) (exit 1))
    (when (< (dup2 REDIR 2)) (exit 1))
    (when (< (dup2 REDIR 1)) (exit 1))
    (close REDIR)
  ))

; find the first usable PCM
(setf PCM (unless (dolist (N PCM-LIST (open-pcm (setf NAME N))))
            (die 1 "No PCM available")))

; configure the PCM
(when (!= (setf E (setup-pcm PCM NAME)))
  (snd_pcm_close PCM)
  (die 1 "setup pcm" E))

(setf N 0 x 0 E 0 i 0)

(while (> (or (setf N (read 0 BUFFER 1000000)) 0))
  (while (> N) 
    (when (< (setf E (snd_pcm_writei PCM BUFFER (/ N 4))))
      (snd_pcm_close PCM)
      (die 1 "writing" E N))
    (setf E (* E 4))
    (setf BUFFER (E BUFFER))
    (dec N E)
    )
  )

(snd_pcm_drain PCM)
(snd_pcm_close PCM)
(exit 0)