dtmf.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          dtmf.lisp
   6 ;;;; Purpose:       Common Lisp DTML tone generator
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  June 2007
   9 ;;;;
  10 ;;;; $Id: cluck.lisp 11571 2007-03-09 14:53:51Z kevin $
  11 ;;;;
  12 ;;;; Copyright (c) 2007 Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; Redistribution and use in source and binary forms, with or without
  15 ;;;; modification, are permitted provided that the following conditions
  16 ;;;; are met:
  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.
  25 ;;;;
  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
  36 ;;;; SUCH DAMAGE.
  37 ;;;; *************************************************************************
  38
  39 (in-package #:cluck)
  40
  41 (defconstant +dtmf-tones+
  42   '(
  43     ;; keypad
  44     (1 . (1209 . 697))
  45     (2 . (1336 . 697))
  46     (3 . (1477 . 697))
  47     (A . (1633 . 697))
  48     (4 . (1209 . 770))
  49     (5 . (1336 . 770))
  50     (6 . (1477 . 770))
  51     (B . (1633 . 770))
  52     (7 . (1209 . 852))
  53     (8 . (1336 . 852))
  54     (9 . (1477 . 852))
  55     (C . (1633 . 852))
  56     (* . (1209 . 941))
  57     (0 . (1336 . 941))
  58     (\# . (1477 . 941))
  59     (D . (1633 . 941))
  60
  61     ;; events
  62     (busy . (620 . 480))
  63     (dial-tone . (440 . 350))
  64     (ringback . (480 . 440))
  65     ))
  66
  67 (defun dtmf-ratios ()
  68   (let ((unsorted nil))
  69     (dolist (record +dtmf-tones+)
  70       (push (list (car record) (cddr record) (/ (cadr record) (cddr record)))
  71             unsorted))
  72     (sort unsorted (lambda (a b) (< (third a) (third b))))))
  73
  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))))
  77
  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
  80
  81 (defun dtmf-waveform (key duration sample-freq
  82                       &key (min -1d0) (max 1d0) (element-type 'double-float)
  83                       &aux dtmf-record)
  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))
  88
  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))
  93          (time 0D0)
  94          (amplitude-ratio 0.8D0)
  95          (raw-min 0D0)
  96          (raw-max 0D0)
  97          (raw-range 0D0)
  98          (range (coerce (- max min) 'double-float))
  99          (f-high 0D0)
 100          (f-low 0D0))
 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)))
 105
 106     (dotimes (i samples)
 107       (declare (fixnum i))
 108
 109       (let ((a (+ (sin (* time f-high))
 110                   (* amplitude-ratio (sin (* time f-low))))))
 111         (cond
 112           ((> a raw-max)
 113            (setq raw-max a))
 114           ((< a raw-min)
 115            (setq raw-min a)))
 116
 117         (setf (aref wave i) a))
 118       (incf time period))
 119
 120     (setq raw-range (- raw-max raw-min))
 121     (dotimes (i samples)
 122       (declare (fixnum i))
 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)))
 127     out-wave))
 128
 129
 130 (defun write-dtmf (file key duration sample-freq &key (delimiter #\tab)
 131                    &aux wave)
 132   (setq wave (dtmf-waveform key duration sample-freq))
 133   (unless wave (return-from write-dtmf nil))
 134
 135   (with-open-file (os file :direction :output)
 136     (let ((period (/ 1D0 sample-freq))
 137           (time 0D0))
 138       (declare (double-float time period))
 139
 140       (dotimes (i (length wave))
 141         (declare (fixnum i))
 142         (format os "~F~A~F~%" time delimiter (aref wave i))
 143         (incf time period)))))
 144
 145
 146 ;;; Functions optionally defined if supporting packages have already
 147 ;;; been loaded
 148 ;;;
 149 ;;; Functions requiring CL-WAV-SYNTH, used for it WAV file writing
 150
 151 (eval-when (:compile-toplevel :load-toplevel :execute)
 152   (when (find-package '#:cl-wav-synth)
 153     (pushnew :kmr-cl-wav-synth cl:*features*)))
 154
 155 #+:kmr-cl-wav-synth
 156 (defun write-dtmf-wav (file key duration &key (sample-freq 8000)
 157                        (n-bits-per-sample 8)
 158                        &aux wave)
 159   (setq wave (dtmf-waveform key duration sample-freq
 160                             :min (ecase n-bits-per-sample
 161                                    (8 0)
 162                                    (16 -32768))
 163                             :max (ecase n-bits-per-sample
 164                                    (8 255)
 165                                    (16 32767))
 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))
 170
 171   (let ((sample (make-instance 'cl-wav-synth:sample
 172                                :n-channels 1
 173                                :n-bits-per-sample n-bits-per-sample
 174                                :n-samples-per-sec sample-freq
 175                                :data wave)))
 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)
 180     sample))
 181
 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*))))
 185
 186
 187 ;;; Functions requiring CGN, a plotting package
 188
 189 (eval-when (:compile-toplevel :load-toplevel :execute)
 190   (when (find-package '#:cgn)
 191     (pushnew :kmr-cgn cl:*features*)))
 192
 193 #+:kmr-cgn
 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))
 197
 198   (let ((period (/ 1D0 sample-freq))
 199         (x (make-list (length wave)))
 200         (y (make-list (length wave)))
 201         (time 0D0))
 202     (declare (double-float time period)
 203              (list x y))
 204
 205     (dotimes (i (length wave))
 206       (declare (fixnum i))
 207       (setf (nth i x) time)
 208       (setf (nth i y) (aref wave i))
 209       (incf time period))
 210
 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)
 215       )))
 216
 217 (eval-when (:compile-toplevel :load-toplevel :execute)
 218   (when (find :kmr-cgn cl:*features*)
 219     (setq cl:*features* (delete :kmr-cgn cl:*features*))))