;;; -*- syntax: common-lisp; package: clm; base: 10; mode: lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File:             moog.ins
;;;
;;; Purpose:          Modified from Bill's ugex.ins, inspired by appendix 36
;;;                   from "Shapes for sounds" by Tim Donaldson, text-thumbs
;;;                   will turn any text (string) into the sound of someone
;;;                   texting the words in on a touchtone phone. 
;;; 
;;; Date:             May 2011                   
;;;
;;; Author:           Michael Edwards - m@michael-edwards.org
;;;
;;; $$ Last modified: 11:06:22 Tue Jul  5 2011 BST
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defparameter +touch-tab-1+
  '(0 697 697 697 770 770 770 852 852 852 941 941 941))

(defparameter +touch-tab-2+
  '(0 1209 1336 1477 1209 1336 1477 1209 1336 1477 1209 1336 1477))

(defparameter +text-thumb+
  ;; each element corresponds to the successive letters of the alphabet
  ;; (lower-case) and represents how many times you have to press a number key
  ;; on a mobile to get that letter
  '(2 22 222 3 33 333 4 44 444 5 55 555 6 66 666 7 77 777 7777 8 88 888 9 99
    999 9999))

(let ((a (char-code #\a)))
  (defun letter2number (letter)         ; must be a char
    (check-type letter character "letter must be a character type")
    (cond ((char= letter #\Space)
           (values 0 1))                ; space is handled by zero
          ((alpha-char-p letter)
           (let* ((ref (- (char-code letter) a))
                  (full-num (nth ref +text-thumb+))
                  (num (mod full-num 10))
                  (full-num-len (length (format nil "~d" full-num))))
             (values num full-num-len))))))

(defun string2numbers (string)
  ;; all lower case
  (loop for i below (length string)
     for letter = (elt string i)
     with result
     do
     (multiple-value-bind 
           (num howmany)
         (letter2number letter)
       (when num
         (loop repeat howmany do (push num result))))
     finally (return (nreverse result))))


;;; dur is a proporition of rhythm
(defun text-thumbs (rhythm string &optional (dur 0.5) (amp 0.5))
  (let ((nums (string2numbers (string-downcase string))))
    (loop with d = (* rhythm dur)
       for n in nums 
       for time from 0.0 by rhythm
       do
         (touch-tone-phone n time d amp))))

(defun slurp-strings (list)
  (format nil "~{~a ~^~}" list))
 
(definstrument touch-tone-phone (number begin-time duration amplitude)
  (let* ((i (if (integerp number)
                (if (/= 0 number) number 11)
                (if (eq number '*) 10 12)))
         (frq1 (make-oscil :frequency (nth i +touch-tab-1+)))
         (frq2 (make-oscil :frequency (nth i +touch-tab-2+)))
         (beg (* *srate* begin-time))
         (end (floor (+ beg (* duration *srate*)))))
    (run
     (loop for j from beg to end do
          (outa j (* 0.25 (+ (oscil frq1) (oscil frq2))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|

(with-sound (:srate 48000 :output "don't-flinch.wav")
  (text-thumbs
   (* 0.125 (/ 60 56))
   "don't flinch"))

(with-sound (:srate 48000)
  (text-thumbs
   (* 0.125 (/ 60 56))
   (slurp-strings
    '("Lichen-green lines of shingle pulsate and waver"
      "when you lift your eyes. It's the glare. Don't flinch"
      "The news you were reading"
      "(who tramples whom) is antique"
      "and on the death pages you've seen already"
      "worms doing their normal work"
      "on the life that was: the chewers chewing"
      "at a sensuality that wrestled doom"
      "an anger steeped in love they can't"
      "even taste. How could this still"
      "shock or sicken you? Friends go missing, mute"
      "nameless.. Toss"
      "the paper. Reach again"
      "for the Iliad. The lines"
      "pulse into sense. Turn up the music"
      "Now do you hear it? can you smell smoke" 
      "under the near shingles?"))))


|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EOF text-thumbs.ins
