dtmf.lisp

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