1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Common Lisp DTML tone generator
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: June 2007
10 ;;;; $Id: cluck.lisp 11571 2007-03-09 14:53:51Z kevin $
12 ;;;; Copyright (c) 2007 Kevin M. Rosenberg
14 ;;;; Redistribution and use in source and binary forms, with or without
15 ;;;; modification, are permitted provided that the following conditions
17 ;;;; 1. Redistributions of source code must retain the above copyright
18 ;;;; notice, this list of conditions and the following disclaimer.
19 ;;;; 2. Redistributions in binary form must reproduce the above copyright
20 ;;;; notice, this list of conditions and the following disclaimer in the
21 ;;;; documentation and/or other materials provided with the distribution.
22 ;;;; 3. Neither the name of the author nor the names of the contributors
23 ;;;; may be used to endorse or promote products derived from this software
24 ;;;; without specific prior written permission.
26 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
27 ;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
28 ;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
29 ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
30 ;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
31 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
32 ;;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
33 ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
34 ;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
35 ;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
37 ;;;; *************************************************************************
41 (defconstant +dtmf-tones+
63 (dial-tone . (440 . 350))
64 (ringback . (480 . 440))
69 (dolist (record +dtmf-tones+)
70 (push (list (car record) (cddr record) (/ (cadr record) (cddr record)))
72 (sort unsorted (lambda (a b) (< (third a) (third b))))))
74 (defun print-dtmf-ratios (&optional (stream *standard-output*))
75 (dolist (v (dtmf-ratios))
76 (format stream "~A ~D ~6,4F~%" (first v) (second v) (third v))))
78 ;; DTMF formula: f(t) = A(high)*sin(2*pi*f(high)*t) + A(low)*sin(2*pi*f(low)*t)
79 ;; A(low) / A(high) between 0.7 and 0.9
81 (defun dtmf-waveform (key duration sample-freq
82 &key (min -1d0) (max 1d0) (element-type 'double-float)
84 "Returns the DTMF waveform of a key code for duration seconds
85 at a sample frequency of sample-freq. Waveform normalized to -1 to 1 output."
86 (setq dtmf-record (get-alist key +dtmf-tones+))
87 (unless dtmf-record (return-from dtmf-waveform nil))
89 (let* ((period (/ 1D0 sample-freq))
90 (samples (ceiling (* duration sample-freq)))
91 (wave (make-array (list samples) :element-type 'double-float))
92 (out-wave (make-array (list samples) :element-type element-type))
94 (amplitude-ratio 0.8D0)
98 (range (coerce (- max min) 'double-float))
101 (declare (double-float raw-min raw-max raw-range range
102 time amplitude-ratio f-high f-low))
103 (setq f-high (* 2 pi (car dtmf-record)))
104 (setq f-low (* 2 pi (cdr dtmf-record)))
109 (let ((a (+ (sin (* time f-high))
110 (* amplitude-ratio (sin (* time f-low))))))
117 (setf (aref wave i) a))
120 (setq raw-range (- raw-max raw-min))
123 (let ((scaled (+ (* range (/ (- (aref wave i) raw-min) raw-range)) min)))
124 (when (subtypep element-type 'integer)
125 (setq scaled (round scaled)))
126 (setf (aref out-wave i) scaled)))
130 (defun write-dtmf (file key duration sample-freq &key (delimiter #\tab)
132 (setq wave (dtmf-waveform key duration sample-freq))
133 (unless wave (return-from write-dtmf nil))
135 (with-open-file (os file :direction :output)
136 (let ((period (/ 1D0 sample-freq))
138 (declare (double-float time period))
140 (dotimes (i (length wave))
142 (format os "~F~A~F~%" time delimiter (aref wave i))
143 (incf time period)))))
146 ;;; Functions optionally defined if supporting packages have already
149 ;;; Functions requiring CL-WAV-SYNTH, used for it WAV file writing
151 (eval-when (:compile-toplevel :load-toplevel :execute)
152 (when (find-package '#:cl-wav-synth)
153 (pushnew :kmr-cl-wav-synth cl:*features*)))
156 (defun write-dtmf-wav (file key duration &key (sample-freq 8000)
157 (n-bits-per-sample 8)
159 (setq wave (dtmf-waveform key duration sample-freq
160 :min (ecase n-bits-per-sample
163 :max (ecase n-bits-per-sample
166 :element-type (ecase n-bits-per-sample
167 (8 '(unsigned-byte 8))
168 (16 '(signed-byte 16)))))
169 (unless wave (return-from write-dtmf-wav nil))
171 (let ((sample (make-instance 'cl-wav-synth:sample
173 :n-bits-per-sample n-bits-per-sample
174 :n-samples-per-sec sample-freq
176 (cl-wav-synth::set-sample-info sample)
177 (cl-wav-synth::set-total-byte-from-data sample)
178 (cl-wav-synth::set-last-sample sample)
179 (cl-wav-synth:write-sample file sample)
182 (eval-when (:compile-toplevel :load-toplevel :execute)
183 (when (find :kmr-cl-wav-synth cl:*features*)
184 (setq cl:*features* (delete :kmr-cl-wav-synth cl:*features*))))
187 ;;; Functions requiring CGN, a plotting package
189 (eval-when (:compile-toplevel :load-toplevel :execute)
190 (when (find-package '#:cgn)
191 (pushnew :kmr-cgn cl:*features*)))
194 (defun plot-dtmf (key duration sample-freq &aux wave)
195 (setq wave (dtmf-waveform key duration sample-freq))
196 (unless wave (return-from plot-dtmf nil))
198 (let ((period (/ 1D0 sample-freq))
199 (x (make-list (length wave)))
200 (y (make-list (length wave)))
202 (declare (double-float time period)
205 (dotimes (i (length wave))
207 (setf (nth i x) time)
208 (setf (nth i y) (aref wave i))
211 (cgn:with-gnuplot ('linux)
212 (cgn:set-range 'x 0 duration)
213 (cgn:set-range 'y -1 1)
214 (cgn:plot-points x y)
217 (eval-when (:compile-toplevel :load-toplevel :execute)
218 (when (find :kmr-cgn cl:*features*)
219 (setq cl:*features* (delete :kmr-cgn cl:*features*))))