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     ;; event
  62     (busy . (480 . 620))
  63     (dial-tone . (350 . 440))
  64     (ringback . (440 . 480))
  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)
  83                       (element-type 'double-float)
  84                       &aux dtmf-record)
  85   "Returns the DTMF waveform of a key code for duration seconds
  86 at a sample frequency of sample-freq. Waveform normalized to -1 to 1 output."
  87   (setq dtmf-record (get-alist key +dtmf-tones+))
  88   (unless dtmf-record (return-from dtmf-waveform nil))
  89
  90   (let* ((period (/ 1D0 sample-freq))
  91          (samples (ceiling (* duration sample-freq)))
  92          (wave (make-array (list samples) :element-type 'double-float))
  93          (out-wave (make-array (list samples) :element-type element-type))
  94          (time 0D0)
  95          (amplitude-ratio 0.8D0)
  96          (raw-min 0D0)
  97          (raw-max 0D0)
  98          (raw-range 0D0)
  99          (range (coerce (- max min) 'double-float))
 100          (f-high 0D0)
 101          (f-low 0D0))
 102     (declare (double-float raw-min raw-max raw-range range
 103                            time amplitude-ratio f-high f-low))
 104     (setq f-high (* 2 pi (car dtmf-record)))
 105     (setq f-low (* 2 pi (cdr dtmf-record)))
 106
 107     (dotimes (i samples)
 108       (declare (fixnum i))
 109
 110       (let ((a (+ (sin (* time f-high))
 111                   (* amplitude-ratio (sin (* time f-low))))))
 112         (cond
 113           ((> a raw-max)
 114            (setq raw-max a))
 115           ((< a raw-min)
 116            (setq raw-min a)))
 117
 118         (setf (aref wave i) a))
 119       (incf time period))
 120
 121     (setq raw-range (- raw-max raw-min))
 122     (dotimes (i samples)
 123       (declare (fixnum i))
 124       (let ((scaled (+ (* range (/ (- (aref wave i) raw-min) raw-range)) min)))
 125         (when (subtypep element-type 'integer)
 126           (setq scaled (round scaled)))
 127         (setf (aref out-wave i) scaled)))
 128     out-wave))
 129
 130
 131 (defun write-dtmf (file key duration sample-freq &key (delimiter #\tab)
 132                    &aux wave)
 133   (setq wave (dtmf-waveform key duration sample-freq))
 134   (unless wave (return-from write-dtmf nil))
 135
 136   (with-open-file (os file :direction :output)
 137     (let ((period (/ 1D0 sample-freq))
 138           (time 0D0))
 139       (declare (double-float time period))
 140
 141       (dotimes (i (length wave))
 142         (declare (fixnum i))
 143         (format os "~F~A~F~%" time delimiter (aref wave i))
 144         (incf time period)))))
 145
 146 (defun write-dtmf-wav (file key duration &key (sample-freq 8000)
 147                        (n-bits-per-sample 8)
 148                        &aux wave)
 149   (setq wave (dtmf-waveform key duration sample-freq
 150                             :min (ecase n-bits-per-sample
 151                                        (8 -128)
 152                                        (16 -32768))
 153                             :max (ecase n-bits-per-sample
 154                                        (8 127)
 155                                        (16 32767))
 156                             :element-type (list 'signed-byte n-bits-per-sample)))
 157   (unless wave (return-from write-dtmf-wav nil))
 158
 159   (let ((sample (make-instance 'cl-wav-synth:sample
 160                                :n-channels 1
 161                                :n-bits-per-sample n-bits-per-sample
 162                                :n-samples-per-sec sample-freq
 163                                :data wave)))
 164     (cl-wav-synth::set-sample-info sample)
 165     (cl-wav-synth::set-total-byte-from-data sample)
 166     (cl-wav-synth::set-last-sample sample)
 167     (cl-wav-synth:write-sample file sample)
 168     sample))
 169
 170 #|
 171 (defun plot-dtmf (key duration sample-freq &aux wave)
 172   (setq wave (dtmf-waveform key duration sample-freq))
 173   (unless wave (return-from plot-dtmf nil))
 174
 175   (let ((period (/ 1D0 sample-freq))
 176         (x (make-list (length wave)))
 177         (y (make-list (length wave)))
 178         (time 0D0))
 179     (declare (double-float time period)
 180              (list x y))
 181
 182     (dotimes (i (length wave))
 183       (declare (fixnum i))
 184       (setf (nth i x) time)
 185       (setf (nth i y) (aref wave i))
 186       (incf time period))
 187
 188     (cgn:with-gnuplot ('linux)
 189       (cgn:set-range 'x 0 duration)
 190       (cgn:set-range 'y -1 1)
 191       (cgn:plot-points x y)
 192       )))
 193 |#