full-sound-test

gistfile1.lisp

(define-foreign-library alsa
  (t (:default "libasound")))

(defcenum snd-pcm-stream-t
  :snd_pcm_stream_playback
  :snd_pcm_stream_capture)

(defcenum snd-pcm-state-t
  :SND_PCM_STATE_OPEN
  :SND_PCM_STATE_SETUP
  :SND_PCM_STATE_PREPARED
  :SND_PCM_STATE_RUNNING
  :SND_PCM_STATE_XRUN
  :SND_PCM_STATE_DRAINING
  :SND_PCM_STATE_PAUSED
  :SND_PCM_STATE_SUSPENDED
  :SND_PCM_STATE_DISCONNECTED)

(defcenum snd-pcm-format-t
  (:SND_PCM_FORMAT_UNKNOWN -1)
  (:SND_PCM_FORMAT_S8 0)
  :SND_PCM_FORMAT_U8
  :SND_PCM_FORMAT_S16_LE
  :SND_PCM_FORMAT_S16_BE
  :SND_PCM_FORMAT_U16_LE
  :SND_PCM_FORMAT_U16_BE
  :SND_PCM_FORMAT_S24_LE
  :SND_PCM_FORMAT_S24_BE
  :SND_PCM_FORMAT_U24_LE
  :SND_PCM_FORMAT_U24_BE
  :SND_PCM_FORMAT_S32_LE
  :SND_PCM_FORMAT_S32_BE
  :SND_PCM_FORMAT_U32_LE
  :SND_PCM_FORMAT_U32_BE
  :SND_PCM_FORMAT_FLOAT_LE
  :SND_PCM_FORMAT_FLOAT_BE
  :SND_PCM_FORMAT_FLOAT64_LE
  :SND_PCM_FORMAT_FLOAT64_BE
  :SND_PCM_FORMAT_IEC958_SUBFRAME_LE
  :SND_PCM_FORMAT_IEC958_SUBFRAME_BE
  :SND_PCM_FORMAT_MU_LAW
  :SND_PCM_FORMAT_A_LAW
  :SND_PCM_FORMAT_IMA_ADPCM  :SND_PCM_FORMAT_MPEG
  :SND_PCM_FORMAT_GSM
  (:SND_PCM_FORMAT_SPECIAL 31)
  (:SND_PCM_FORMAT_S24_3LE 32)
  :SND_PCM_FORMAT_S24_3BE
  :SND_PCM_FORMAT_U24_3LE
  :SND_PCM_FORMAT_U24_3BE
  :SND_PCM_FORMAT_S20_3LE
  :SND_PCM_FORMAT_S20_3BE
  :SND_PCM_FORMAT_U20_3LE
  :SND_PCM_FORMAT_U20_3BE
  :SND_PCM_FORMAT_S18_3LE
  :SND_PCM_FORMAT_S18_3BE
  :SND_PCM_FORMAT_U18_3LE
  :SND_PCM_FORMAT_U18_3BE)

(defcenum snd-pcm-access-t
  :SND_PCM_ACCESS_MMAP_INTERLEAVED
  :SND_PCM_ACCESS_MMAP_NONINTERLEAVED
  :SND_PCM_ACCESS_MMAP_COMPLEX
  :SND_PCM_ACCESS_RW_INTERLEAVED
  :SND_PCM_ACCESS_RW_NONINTERLEAVED)

(defctype snd-pcm-ptr :pointer)
(defctype snd-pcm-hw-params-ptr :pointer)
(defctype snd-pcm-sw-params-ptr :pointer)
(defcstruct snd-pcm-channel-area-t
  "PCM Structure representing the sound buffer area to be written to."
  ;; Addr is the base address of the pointer
  (addr :pointer)
  ;; First is offset in BITS to the first sample
  (first :unsigned-int)
  ;; Step is the samples distance in bits (i.e. measured in Bits per Sample)
  ;; NOTE: I'm still not *sure* what this is.
  ;; but the calculation I use is (when writing to the buffer):
  ;; samples = addr + first / 8 + offset * area.step / 16
  ;; where offset is the frame we are writing to relative to the first address
  (step :unsigned-int))

(defstruct sound
  (format :snd_pcm_format_s16_le)
  (access :snd_pcm_access_mmap_interleaved)
  (samples-per-second 48000)
  (num-channels 2)
  (buffer-size 4096)
  (num-periods 2)
  (period-size nil)
  (resample t))

;; TODO: how to build more intricate constructors?
(defstruct square-wave
  (running-sample-index 0)
  (frequency 440)
  (volume 3000)
  (half-period))

(defun full-sound-test ()
  (let* ((sound (make-sound))
	 (square-wave (make-square-wave)))
    (setf (square-wave-half-period square-wave)
	  (floor (/ (sound-samples-per-second sound)
		    (square-wave-frequency square-wave) 2)))
    (with-foreign-objects ((handle-ptr 'snd-pcm-ptr)
			   (hw-params-ptr 'snd-pcm-hw-params-ptr)
			   (sw-params-ptr 'snd-pcm-sw-params-ptr)
			   (channels-ptr :uint32)
			   (rate-ptr :uint32)
			   (direction-ptr :int32)
			   (buffer-size-ptr :uint32)
			   (period-size-ptr :uint32)
			   (frames-ptr :uint32)
			   (offset-ptr :uint32)
			   (sound-buffer :pointer))
      ;; TODO: fail if fail for all of these calls.
      (foreign-funcall "snd_pcm_open"
		       :pointer handle-ptr
		       :string "default"
		       snd-pcm-stream-t :snd_pcm_stream_playback
		       :int 0 ; NOTE: blocking mode
		       :int)
      (let ((pcm (mem-ref handle-ptr 'snd-pcm-ptr)))
	(macrolet ((pcm-call (name &rest args)
		     "PCM calls start with \"snd_pcm_\", take a snd-pcm-ptr, and return an :int"
		     `(foreign-funcall ,(concatenate 'string "snd_pcm_" name)
				       snd-pcm-ptr pcm
				       ,@args
				       :int)))
	  (labels ((pcm-prepare ()
		     (pcm-call "prepare"))
		   (run-recovery (err)
		     (case err
		       (-32 ; EPIPE
			(pcm-prepare))
		       (-86 ; ESTRPIPE
			;; I'm thinking I don't like loop very much.
			(when (minusp (loop with err = (pcm-call "resume")
					 while (= err -11 ; EAGAIN
						  )
					 do (sleep 0.00000001)
					 finally (return err)))
			  (pcm-prepare)))
		       (t (error "Unrecoverable error: ~a" err))))
		   (minusp-fail (call-name fn-name val)
		     (if (minusp val)
			 (error "~a ~a" call-name fn-name)))
		   (minusp-recovery (val)
		     (when (minusp val)
		       (run-recovery val))))
	    (block send-sound-parameters
	      (foreign-funcall "snd_pcm_hw_params_malloc" :pointer hw-params-ptr)

	      (let ((hw-params (mem-ref hw-params-ptr 'snd-pcm-hw-params-ptr)))
		(macrolet ((hw-call (name &rest args)
			     "hw-calls are pcm-calls that also take a snd-pcm-hw-params-ptr.
Additionally they fail (cause an error) if the return code is "
			     `(minusp-fail "hw-call" ,name
					   (pcm-call ,(concatenate 'string "hw_params_" name)
						     snd-pcm-hw-params-ptr hw-params
						     ,@args))))
		  ;; NOTE: setup hardware
		  ;; NOTE: Just fill the params with anything to make it valid.
		  (hw-call "any")
		  (hw-call "set_rate_resample"
			   ;; TODO: Leaving resampling off, because I don't know what it does
			   :int32 (if (sound-resample sound) 1 0))
		  (hw-call "set_access"
			   ;; MMAP gives us a direct pointer to the memory to write to.
			   ;; Interleaved mean L/R channels will be every other sample
			   snd-pcm-access-t (sound-access sound))
		  (hw-call "set_format"
			   ;; samples are 16-bit signed integers
			   ;; TODO: specify little/big-endianness?
			   snd-pcm-format-t (sound-format sound))
		  (setf (mem-ref channels-ptr :uint32) (sound-num-channels sound))
		  (hw-call "set_channels_near"
			   ;; Two Channels for stereo sound: Left/Right
			   :pointer channels-ptr)
		  (setf (sound-num-channels sound) (mem-ref channels-ptr :uint32))
		  ;; NOTE: these functions set to the nearest value, but return the value
		  ;; that was actually set.
		  (setf (mem-ref rate-ptr :uint32) (sound-samples-per-second sound)
			(mem-ref direction-ptr :int32) 0)
		  (hw-call "set_rate_near"
			   :pointer rate-ptr
			   :pointer direction-ptr ; Out-param telling us which side we fell on
			   )
		  ;; NOTE: Buffer size is in frames. A frame is NumChannels * SampleSize
		  ;; So it is 1/2x the sample size for 2-channel sound.
		  (setf (mem-ref buffer-size-ptr :uint32)
			(floor (sound-buffer-size sound) (sound-num-channels sound))
			(mem-ref direction-ptr :int32) 0)
		  (hw-call "set_buffer_size_near"
			   :pointer buffer-size-ptr
			   :pointer direction-ptr)
		  (setf (sound-buffer-size sound) (mem-ref buffer-size-ptr :uint32))
		  ;; NOTE: Period is how often we transfer memory. It's usually buffer_size/2
		  ;; This way the hardware interrupts 2 times in the course of playing the buffer.
		  ;; See: http://www.alsa-project.org/main/index.php/FramesPeriods
		  ;; period-size is also in frames
		  (setf (sound-period-size sound) (floor (sound-buffer-size sound)
							 (sound-num-periods sound)))
		  (setf (mem-ref period-size-ptr :uint32) (sound-period-size sound)
			(mem-ref direction-ptr :int32) 0)
		  (hw-call "set_period_size_near"
			   :pointer period-size-ptr
			   :pointer direction-ptr)
		  (setf (sound-period-size sound) (mem-ref period-size-ptr :uint32))
		  ;; NOTE: Finally send the parameters. We've only been modifying a local struct.
		  (minusp-fail "pcm-call" "hw_params"
			       (pcm-call "hw_params" snd-pcm-hw-params-ptr hw-params))
		  (setf (sound-samples-per-second sound) (mem-ref rate-ptr :uint32))
		  ;; NOTE: Done with the params structures. free it. (only store ephemoral data)
		  ;; (foreign-funcall "snd_pcm_hw_params_free"
		  ;; 		   snd-pcm-hw-params-ptr (mem-ref hw-params-ptr 'snd-pcm-hw-params-ptr)
		  ;; 		   )
		  ))

	      (foreign-funcall "snd_pcm_sw_params_malloc" :pointer sw-params-ptr)
	      ;; NOTE: set hardware before software, since sw values depend on it.
	      (let  ((sw-params (mem-ref sw-params-ptr 'snd-pcm-sw-params-ptr)))
		(macrolet ((sw-call (name &rest args)
			     "sw-calls are pcm-calls that also take a snd-pcm-sw-params-ptr.
Additionally they fail (cause an error) if the return code is "
			     `(minusp-fail "sw-call" ,name
					   (pcm-call ,(concatenate 'string "sw_params_" name)
						     snd-pcm-sw-params-ptr sw-params
						     ,@args))))
		  ;; NOTE: Software parameters.

		  ;; NOTE: fill sw-params with the current settings.
		  (sw-call "current")
		  ;; NOTE: this determines how much to fill the buffer before we start playing.
		  ;; Usually you want it full or mostly full. I set it to the buffer-size since
		  ;; and ASSUME our periods are an even division. The periods seem to be connected to
		  ;; the start threshold somehow...
		  (sw-call "set_start_threshold" :uint32 (sound-buffer-size sound))
		  ;; NOTE: avail_min is basically the period, since we don't want to write less than one period.
		  (sw-call "set_avail_min" :uint32 (sound-period-size sound))
		  ;; NOTE: write the params to ALSA
		  (pcm-call "sw_params" snd-pcm-sw-params-ptr sw-params)
		  ;; (pcm-call "sw_params_free"
		  ;; 	    snd-pcm-sw-params-ptr (mem-ref sw-params-ptr 'snd-pcm-sw-params-ptr))
		  ))
	      (block print-sound-settings
		(format t "access: ~a~%"
			(foreign-funcall "snd_pcm_access_name"
					 snd-pcm-access-t (sound-access sound)
					 :string))
		(format t "format: ~a~%"
			(foreign-funcall "snd_pcm_format_name"
					 snd-pcm-format-t (sound-format sound)
					 :string))
		(format t "samples-per-second: ~a~%buffer-size: ~a~%period-size: ~a~%num-channels: ~a~%resample?: ~a~%"
			(sound-samples-per-second sound)
			(sound-buffer-size sound)
			(sound-period-size sound)
			(sound-num-channels sound)
			(sound-resample sound))))
	    ;; NOTE: kick it off.
	    ;; TODO: fail if failed.
	    (pcm-call "start")
	    ;; NOTE: square wave
	    (loop until (< 48000 (square-wave-running-sample-index square-wave))
	       do
	       ;; NOTE: check state for XRUN or SUSPENDED, and try to recover.
		 (case (foreign-funcall "snd_pcm_state"
					snd-pcm-ptr pcm
					snd-pcm-state-t)
		   (:snd_pcm_state_xrun (run-recovery -32 ; EPIPE
						      ))
		   (:snd_pcm_state_suspended (run-recovery -86 ; ESTRPIPE
							   )))
		 (let ( ;; NOTE: necessary to call avail_update before snd_pcm_mmap_begin
		       (avail (pcm-call "avail_update")))
		   (cond
		     ((minusp avail) (run-recovery avail))
		     ((< avail (sound-period-size sound))
		      ;; NOTE: check the number of frames available to write to is at least one period.
		      ;; TODO: wait here?
		      )
		     (t
		      (loop with size = (sound-period-size sound)
			 while (plusp size)
			 do
			   (setf (mem-ref frames-ptr :uint32) size)
			 ;; NOTE: Grabs the pointer to the chunk of memory we are writing to.
			 ;; as well as the offset into the chunk and locks for writing
			   (minusp-recovery (pcm-call "mmap_begin"
						      :pointer sound-buffer
						      :pointer offset-ptr
						      :pointer frames-ptr))
			   (with-foreign-slots ((first step addr)
						(mem-ref sound-buffer :pointer)
						(:struct snd-pcm-channel-area-t))
			     (let* ((offset (mem-ref offset-ptr :uint32))
				    (frames (mem-ref frames-ptr :uint32))
				    ;; first is in bits
				    (first-byte-offset (floor first 8))
				    (bytes-per-sample 2)
				    ;; Steps are in bits-per-sample.
				    (step-size-per-byte (floor step 8))
				    (samples (inc-pointer addr (+ first-byte-offset
								  (* offset step-size-per-byte)))))
			       (loop repeat frames
				  do
				    (let ((sample-value
					   (if (/= 0 (mod (floor (square-wave-running-sample-index square-wave)
								 (square-wave-half-period square-wave))
							  2))
					       (square-wave-volume square-wave)
					       (- (square-wave-volume square-wave)))))
				      (incf (square-wave-running-sample-index square-wave))
				      (setf (mem-ref samples :int16) sample-value)
				      (incf-pointer samples bytes-per-sample)
				      (setf (mem-ref samples :int16) sample-value)
				      (incf-pointer samples bytes-per-sample)))
			       ;; NOTE: Commits the changes and releases the lock.
			       (let ((commits (pcm-call "mmap_commit"
							:uint32 offset
							:uint32 frames)))
				 (when (or (minusp commits)
					   (/= commits frames))
				   (run-recovery (if (minusp commits)
						     commits
						     ;; NOTE: error is -EPIPE if commits is positive
						     -32))))
			       (decf size frames))))))))
	    (pcm-call "close")))))))