1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Common Lisp DTMF (dual tone) wave generator
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: June 2007
10 ;;;; Copyright (c) 2007 Kevin M. Rosenberg
12 ;;;; Redistribution and use in source and binary forms, with or without
13 ;;;; modification, are permitted provided that the following conditions
15 ;;;; 1. Redistributions of source code must retain the above copyright
16 ;;;; notice, this list of conditions and the following disclaimer.
17 ;;;; 2. Redistributions in binary form must reproduce the above copyright
18 ;;;; notice, this list of conditions and the following disclaimer in the
19 ;;;; documentation and/or other materials provided with the distribution.
20 ;;;; 3. Neither the name of the author nor the names of the contributors
21 ;;;; may be used to endorse or promote products derived from this software
22 ;;;; without specific prior written permission.
24 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
25 ;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
26 ;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
27 ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
28 ;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
30 ;;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31 ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 ;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
33 ;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
35 ;;;; *************************************************************************
39 (defconstant +dtmf-tones+
61 (dial-tone . (440 . 350))
62 (ringback . (480 . 440))
67 (dolist (record +dtmf-tones+)
68 (push (list (car record) (cddr record) (/ (cadr record) (cddr record)))
70 (sort unsorted (lambda (a b) (< (third a) (third b))))))
72 (defun print-dtmf-ratios (&optional (stream *standard-output*))
73 (dolist (v (dtmf-ratios))
74 (format stream "~A ~D ~6,4F~%" (first v) (second v) (third v))))
76 ;; DTMF formula: f(t) = A(high)*sin(2*pi*f(high)*t) + A(low)*sin(2*pi*f(low)*t)
77 ;; A(low) / A(high) between 0.7 and 0.9
79 (defun dtmf-waveform (key duration sample-freq
80 &key (min -1d0) (max 1d0) (element-type 'double-float)
82 "Returns the DTMF waveform of a key code for duration seconds
83 at a sample frequency of sample-freq. Waveform normalized to -1 to 1 output."
84 (setq dtmf-record (get-alist key +dtmf-tones+))
85 (unless dtmf-record (return-from dtmf-waveform nil))
87 (let* ((period (/ 1D0 sample-freq))
88 (samples (ceiling (* duration sample-freq)))
89 (wave (make-array (list samples) :element-type 'double-float))
90 (out-wave (make-array (list samples) :element-type element-type))
92 (amplitude-ratio 0.8D0)
96 (range (coerce (- max min) 'double-float))
99 (declare (double-float raw-min raw-max raw-range range
100 time amplitude-ratio f-high f-low))
101 (setq f-high (* 2 pi (car dtmf-record)))
102 (setq f-low (* 2 pi (cdr dtmf-record)))
107 (let ((a (+ (sin (* time f-high))
108 (* amplitude-ratio (sin (* time f-low))))))
115 (setf (aref wave i) a))
118 (setq raw-range (- raw-max raw-min))
121 (let ((scaled (+ (* range (/ (- (aref wave i) raw-min) raw-range)) min)))
122 (when (subtypep element-type 'integer)
123 (setq scaled (round scaled)))
124 (setf (aref out-wave i) scaled)))
128 (defun write-dtmf (file key duration sample-freq &key (delimiter #\tab)
130 (setq wave (dtmf-waveform key duration sample-freq))
131 (unless wave (return-from write-dtmf nil))
133 (with-open-file (os file :direction :output)
134 (let ((period (/ 1D0 sample-freq))
136 (declare (double-float time period))
138 (dotimes (i (length wave))
140 (format os "~F~A~F~%" time delimiter (aref wave i))
141 (incf time period)))))
144 ;;; Functions optionally defined if supporting packages have already
147 ;;; Functions requiring CL-WAV-SYNTH, used for it WAV file writing
149 (eval-when (:compile-toplevel :load-toplevel :execute)
150 (when (find-package '#:cl-wav-synth)
151 (pushnew :kmr-cl-wav-synth cl:*features*)))
154 (defun write-dtmf-wav (file key duration &key (sample-freq 8000)
155 (n-bits-per-sample 8)
157 (setq wave (dtmf-waveform key duration sample-freq
158 :min (ecase n-bits-per-sample
161 :max (ecase n-bits-per-sample
164 :element-type (ecase n-bits-per-sample
165 (8 '(unsigned-byte 8))
166 (16 '(signed-byte 16)))))
167 (unless wave (return-from write-dtmf-wav nil))
169 (let ((sample (make-instance 'cl-wav-synth:sample
171 :n-bits-per-sample n-bits-per-sample
172 :n-samples-per-sec sample-freq
174 (cl-wav-synth::set-sample-info sample)
175 (cl-wav-synth::set-total-byte-from-data sample)
176 (cl-wav-synth::set-last-sample sample)
177 (cl-wav-synth:write-sample file sample)
180 (eval-when (:compile-toplevel :load-toplevel :execute)
181 (when (find :kmr-cl-wav-synth cl:*features*)
182 (setq cl:*features* (delete :kmr-cl-wav-synth cl:*features*))))
185 ;;; Functions requiring CGN, a plotting package
187 (eval-when (:compile-toplevel :load-toplevel :execute)
188 (when (find-package '#:cgn)
189 (pushnew :kmr-cgn cl:*features*)))
192 (defun plot-dtmf (key duration sample-freq &aux wave)
193 (setq wave (dtmf-waveform key duration sample-freq))
194 (unless wave (return-from plot-dtmf nil))
196 (let ((period (/ 1D0 sample-freq))
197 (x (make-list (length wave)))
198 (y (make-list (length wave)))
200 (declare (double-float time period)
203 (dotimes (i (length wave))
205 (setf (nth i x) time)
206 (setf (nth i y) (aref wave i))
209 (cgn:with-gnuplot ('linux)
210 (cgn:set-range 'x 0 duration)
211 (cgn:set-range 'y -1 1)
212 (cgn:plot-points x y)
215 (eval-when (:compile-toplevel :load-toplevel :execute)
216 (when (find :kmr-cgn cl:*features*)
217 (setq cl:*features* (delete :kmr-cgn cl:*features*))))