;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          dtmf.lisp
;;;; Purpose:       Common Lisp DTMF (dual tone) wave generator
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  June 2007
;;;;
;;;; Copyright (c) 2007 Kevin M. Rosenberg
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above copyright
;;;;    notice, this list of conditions and the following disclaimer in the
;;;;    documentation and/or other materials provided with the distribution.
;;;; 3. Neither the name of the author nor the names of the contributors
;;;;    may be used to endorse or promote products derived from this software
;;;;    without specific prior written permission.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;;; SUCH DAMAGE.
;;;; *************************************************************************

(in-package #:cluck)

(defconstant +dtmf-tones+
  '(
    ;; keypad
    (1 . (1209 . 697))
    (2 . (1336 . 697))
    (3 . (1477 . 697))
    (A . (1633 . 697))
    (4 . (1209 . 770))
    (5 . (1336 . 770))
    (6 . (1477 . 770))
    (B . (1633 . 770))
    (7 . (1209 . 852))
    (8 . (1336 . 852))
    (9 . (1477 . 852))
    (C . (1633 . 852))
    (* . (1209 . 941))
    (0 . (1336 . 941))
    (\# . (1477 . 941))
    (D . (1633 . 941))

    ;; events
    (busy . (620 . 480))
    (dial-tone . (440 . 350))
    (ringback . (480 . 440))
    ))

(defun dtmf-ratios ()
  (let ((unsorted nil))
    (dolist (record +dtmf-tones+)
      (push (list (car record) (cddr record) (/ (cadr record) (cddr record)))
            unsorted))
    (sort unsorted (lambda (a b) (< (third a) (third b))))))

(defun print-dtmf-ratios (&optional (stream *standard-output*))
  (dolist (v (dtmf-ratios))
    (format stream "~A ~D ~6,4F~%" (first v) (second v) (third v))))

;; DTMF formula: f(t) = A(high)*sin(2*pi*f(high)*t) + A(low)*sin(2*pi*f(low)*t)
;; A(low) / A(high) between 0.7 and 0.9

(defun dtmf-waveform (key duration sample-freq
                      &key (min -1d0) (max 1d0) (element-type 'double-float)
                      &aux dtmf-record)
  "Returns the DTMF waveform of a key code for duration seconds
at a sample frequency of sample-freq. Waveform normalized to -1 to 1 output."
  (setq dtmf-record (get-alist key +dtmf-tones+))
  (unless dtmf-record (return-from dtmf-waveform nil))

  (let* ((period (/ 1D0 sample-freq))
         (samples (ceiling (* duration sample-freq)))
         (wave (make-array (list samples) :element-type 'double-float))
         (out-wave (make-array (list samples) :element-type element-type))
         (time 0D0)
         (amplitude-ratio 0.8D0)
         (raw-min 0D0)
         (raw-max 0D0)
         (raw-range 0D0)
         (range (coerce (- max min) 'double-float))
         (f-high 0D0)
         (f-low 0D0))
    (declare (double-float raw-min raw-max raw-range range
                           time amplitude-ratio f-high f-low))
    (setq f-high (* 2 pi (car dtmf-record)))
    (setq f-low (* 2 pi (cdr dtmf-record)))

    (dotimes (i samples)
      (declare (fixnum i))

      (let ((a (+ (sin (* time f-high))
                  (* amplitude-ratio (sin (* time f-low))))))
        (cond
          ((> a raw-max)
           (setq raw-max a))
          ((< a raw-min)
           (setq raw-min a)))

        (setf (aref wave i) a))
      (incf time period))

    (setq raw-range (- raw-max raw-min))
    (dotimes (i samples)
      (declare (fixnum i))
      (let ((scaled (+ (* range (/ (- (aref wave i) raw-min) raw-range)) min)))
        (when (subtypep element-type 'integer)
          (setq scaled (round scaled)))
        (setf (aref out-wave i) scaled)))
    out-wave))


(defun write-dtmf (file key duration sample-freq &key (delimiter #\tab)
                   &aux wave)
  (setq wave (dtmf-waveform key duration sample-freq))
  (unless wave (return-from write-dtmf nil))

  (with-open-file (os file :direction :output)
    (let ((period (/ 1D0 sample-freq))
          (time 0D0))
      (declare (double-float time period))

      (dotimes (i (length wave))
        (declare (fixnum i))
        (format os "~F~A~F~%" time delimiter (aref wave i))
        (incf time period)))))


;;; Functions optionally defined if supporting packages have already
;;; been loaded
;;;
;;; Functions requiring CL-WAV-SYNTH, used for it WAV file writing

(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (find-package '#:cl-wav-synth)
    (pushnew :kmr-cl-wav-synth cl:*features*)))

#+:kmr-cl-wav-synth
(defun write-dtmf-wav (file key duration &key (sample-freq 8000)
                       (n-bits-per-sample 8)
                       &aux wave)
  (setq wave (dtmf-waveform key duration sample-freq
                            :min (ecase n-bits-per-sample
                                   (8 0)
                                   (16 -32768))
                            :max (ecase n-bits-per-sample
                                   (8 255)
                                   (16 32767))
                            :element-type (ecase n-bits-per-sample
                                            (8 '(unsigned-byte 8))
                                            (16  '(signed-byte 16)))))
  (unless wave (return-from write-dtmf-wav nil))

  (let ((sample (make-instance 'cl-wav-synth:sample
                               :n-channels 1
                               :n-bits-per-sample n-bits-per-sample
                               :n-samples-per-sec sample-freq
                               :data wave)))
    (cl-wav-synth::set-sample-info sample)
    (cl-wav-synth::set-total-byte-from-data sample)
    (cl-wav-synth::set-last-sample sample)
    (cl-wav-synth:write-sample file sample)
    sample))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (find :kmr-cl-wav-synth cl:*features*)
    (setq cl:*features* (delete :kmr-cl-wav-synth cl:*features*))))


;;; Functions requiring CGN, a plotting package

(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (find-package '#:cgn)
    (pushnew :kmr-cgn cl:*features*)))

#+:kmr-cgn
(defun plot-dtmf (key duration sample-freq &aux wave)
  (setq wave (dtmf-waveform key duration sample-freq))
  (unless wave (return-from plot-dtmf nil))

  (let ((period (/ 1D0 sample-freq))
        (x (make-list (length wave)))
        (y (make-list (length wave)))
        (time 0D0))
    (declare (double-float time period)
             (list x y))

    (dotimes (i (length wave))
      (declare (fixnum i))
      (setf (nth i x) time)
      (setf (nth i y) (aref wave i))
      (incf time period))

    (cgn:with-gnuplot ('linux)
      (cgn:set-range 'x 0 duration)
      (cgn:set-range 'y -1 1)
      (cgn:plot-points x y)
      )))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (find :kmr-cgn cl:*features*)
    (setq cl:*features* (delete :kmr-cgn cl:*features*))))