;;********************************************

;;********************************************

;;////////////////////////////////////////////

;;Microtonal Transposition for SCORE files

;;////////////////////////////////////////////

;;Mauricio Rodriguez - 2008

;;////////////////////////////////////////////

;;marod@ccrma.stanford.edu

;;////////////////////////////////////////////

;;********************************************

;;********************************************

 

#|

******************************

******************************

Use and copying of this software and preparation of derivative works

based upon this software are prohibited unless permission of the author.

Suggestions, comments and bug reports are welcome. Please address email to:

marod@ccrma.stanford.edu

******************************

******************************

|#

 

;;Main:

 

;; transpose-pmx-score [staff-number-list interval direction]

;;(transpose-pmx-score '(1 2) '>2 '-)

 

;;Code:

 

#|

 

(defun expand-note (note-symbol)

  (read-from-string

   (remove #\#

           (remove #\\

                   (write-to-string

                    (coerce

                     (write-to-string note-symbol)

                     'list))))))

 

|#

 

#|

 

(defun transposition-interval (interval)

  (case interval

    (unison 0)

    (minor2 1)

    (major2 2)

    (minor3 3)

    (major3 4)

    (perfect4 5)

    (tritone 6)

    (perfect5 7)

    (minor6 8)

    (major6 9)

    (minor7 10)

    (major8 11)

    (octave 12)))

 

;;(transposition-interval 'minor2)

;;(transposition-interval 'tritone)

;;(transposition-interval 'octave)

 

|#

 

(defun transposition-interval-up (interval)

  (case interval

    (u 0)

    (<2 1)

    (>2 2)

    (<3 3)

    (>3 4)

    (p4 5)

    (tt 6)

    (p5 7)

    (<6 8)

    (>6 9)

    (<7 10)

    (>7 11)

    (o 12)))

 

(defun transposition-interval-down (interval)

  (case interval

    (u 12)

    (<2 11)

    (>2 10)

    (<3 9)

    (>3 8)

    (p4 7)

    (tt 6)

    (p5 5)

    (<6 4)

    (>6 3)

    (<7 2)

    (>7 1)

    (o 0)))

 

(defun transposition-interval (interval direction)

  (cond ((equal direction '+)

         (transposition-interval-up interval))

        ((equal direction '-)

         (transposition-interval-down interval))))

 

;;(transposition-interval '<2 '+)

;;(transposition-interval '<2 '-)

 

#|

 

(defun score-transposition (interval)

  (case interval

    (0 0)

    (1 1)

    (2 1)

    (3 2)

    (4 2)

    (5 3)

    (6 3)

    (7 4)

    (8 5)

    (9 5)

    (10 6)

    (11 6)

    (12 7)))

 

;;(score-transposition 0)

;;(score-transposition 1)

;;(score-transposition 2)

 

|#

 

(defun locate-values-from-index (index compound-list)

  (loop for x in compound-list

        collect (elt x index)))

 

(defun transposition-matrix (accidental-reference)

  (case accidental-reference

    (4 '((0 0 1 1 2 3 3 4 4 5 5 6 7)

         (4 1 4 1 4 4 1 4 1 4 1 4 4)))

    (7 '((0 0 1 1 2 3 3 4 4 5 5 6 7)

         (7 6 7 6 7 7 6 7 6 7 6 7 7)))

    (1 '((0 1 1 2 2 3 3 4 5 5 6 6 7)

         (1 4 1 4 1 1 0 1 4 1 4 1 1)))

    (6 '((0 1 1 2 2 3 3 4 5 5 6 6 7)

         (6 7 6 7 6 6 8 6 7 6 7 6 6)))

    (3 '((0 1 1 2 2 3 3 4 5 5 6 6 7)

         (3 1 3 1 3 3 2 3 1 3 1 3 3)))

    (0 '((0 1 1 2 2 3 3 4 5 5 6 6 7)

         (0 1 0 1 0 0 2 0 1 0 1 0 0)))

    (8 '((0 1 1 2 2 3 3 4 5 5 6 6 7)

         (8 6 8 6 8 8 9 8 6 8 6 8 8)))

    (2 '((0 1 1 2 2 3 3 4 5 5 6 6 7)

         (2 0 2 0 2 2 5 2 0 2 0 2 2)))

    (9 '((0 1 1 2 2 3 4 4 5 5 6 6 7)

         (9 8 9 8 9 9 8 9 8 9 8 9 9)))

    (5 '((0 1 1 2 2 3 4 4 5 5 6 6 7)

         (5 2 5 2 5 5 2 5 2 5 2 5 5)))))

 

;;(transposition-matrix 0)

 

 

(defun collide-list (list)

  (first

   (read-from-string

    (remove #\space

            (write-to-string list)))))

 

#|

 

(defun pitch-and-accident-substitution (pitch stem-accident transpose-interval)

  (let* ((current-pitch

          (truncate pitch))

        (current-stem-accident

         (expand-note (truncate stem-accident)))

        (current-transposition

         (transposition-interval transpose-interval))

        (current-matrix

         (locate-values-from-index current-transposition

                                   (transposition-matrix (second current-stem-accident)))))

    (list (float (+ current-pitch (first current-matrix)))

          (float (collide-list (list (first current-stem-accident)

                                     (second current-matrix)))))))

 

;;(pitch-and-accident-substitution 0.0 28.0 'minor2)

;;(pitch-and-accident-substitution 0.0 28.0 'major2)

 

|#

 

(defun pitch-and-accident-substitution (pitch stem-accident transpose-interval direction)

  (let* ((current-pitch

          (truncate pitch))

        (current-stem-accident

         (expand-note (truncate stem-accident)))

        (current-transposition

         (transposition-interval transpose-interval direction))

        (current-matrix

         (locate-values-from-index current-transposition

                                   (transposition-matrix (second current-stem-accident)))))

    (cond ((equal direction '-)

           (list (float (- (+ current-pitch (first current-matrix)) 7.0))

                 (float (collide-list (list (first current-stem-accident)

                                            (second current-matrix))))))

          ((equal direction '+)

           (list (float (+ current-pitch (first current-matrix)))

                 (float (collide-list (list (first current-stem-accident)

                                            (second current-matrix)))))))))

 

 

(defun get-from-index (indexing list)

  (if (atom indexing)

    (elt list (- indexing 1))

    (loop for x in indexing

          collect (elt list (- x 1)))))

 

 

(defun substitute-from-index* (indexing counter list)

  (if (= counter 1)

    (cons (second indexing) (rest list))

    (cons (first list)

          (substitute-from-index* indexing (decf counter) (rest list)))))

 

 

(defun substitute-from-index** (indexing list)

  (substitute-from-index* indexing (first indexing) list))

 

 

(defvar *current-transformed-list* nil)

 

(defun substitute-from-index (indexing list)

  (setf *current-transformed-list* nil)

  (do ((current-indexing

        indexing

        (rest current-indexing))

       (*current-transformed-list*

        list

        (substitute-from-index** (first current-indexing) *current-transformed-list*)))

      ((endp current-indexing) *current-transformed-list*)))

 

(defun transpose-note (interval direction note)

  (let* ((original-vertical-position (get-from-index 4 note))

         (original-stem-accident (get-from-index 5 note))

         (new-values (pitch-and-accident-substitution

                      original-vertical-position

                      original-stem-accident

                      interval

                      direction)))

    (substitute-from-index (list

                            (list 4 (first new-values))

                            (list 5 (second new-values)))

                           note)))

 

#|

 

(defun member-p (element list)

  (if (member element list)

    t

    nil))

 

|#

 

(defun transpose-staff-line (staff-number-list interval direction score)

  (cond ((endp score) nil)

        ((and (equal (first (first score)) 1.0)

              (member-p (second (first score)) (mapcar #'float staff-number-list)))

         (cons (transpose-note interval direction (first score))

               (transpose-staff-line staff-number-list interval direction (rest score))))

        (t (cons (first score)

                 (transpose-staff-line staff-number-list interval direction (rest score))))))

 

#|

 

(transpose-staff-line

'(1 2)

'>2

'-

'(

(8.0 1.0 0.0 0.0 0.0 180.0)

(3.0 1.0)

(1.0 1.0 20.0 1.0 12.0 0.0 1.0)

(1.0 1.0 21.0 8.0 29.0 0.0 0.5)

(1.0 2.0 21.5 8.0 29.0 0.0 0.5)

(1.0 3.0 22.0 8.0 29.0 0.0 1.0))

)

 

|#

 

 

#|

 

(defvar *string-sequence* nil)

 

(defun load-pmx-file* ()

  (setf *string-sequence* nil)

  (setf *string-sequence*

        (with-open-file (input (choose-file-dialog)

                               :direction :input)

          (read-from input))))

 

(defun read-from (stream)

  (let ((current-line (read-line stream nil)))

    (unless (not current-line)

      (cons current-line

            (read-from stream)))))

 

;;(load-pmx-file*)

 

(defun load-pmx-file ()

  (load-pmx-file*)

  (loop for x in *string-sequence*

        collect (read-from-string (concatenate 'string "(" x ")"))))

 

;;(load-pmx-file)

 

|#

 

 

(defvar *current-pmx-score* nil)

 

(defun get-pmx-score ()

  (setf *current-pmx-score* nil)

  (setf *current-pmx-score* (load-pmx-file)))

 

;;(get-pmx-score)

 

#|

 

(defun transpose-pmx-score (staff-number-list interval direction)

  (get-pmx-score)

  (transpose-staff-line staff-number-list interval direction *current-pmx-score*))

 

;;(transpose-pmx-score '(1 2) '>2 '-)

 

|#

 

(defun transpose-pmx-score (staff-number-list interval direction)

  (get-pmx-score)

  (print-pmx-score

   (transpose-staff-line staff-number-list interval direction *current-pmx-score*)))

 

;;(transpose-pmx-score '(1 2) '>2 '-)

;;(transpose-pmx-score '(1 2) 'p5 '+)

 

 

;;////////////////////////////////////////////

;;Microtonal Transposition Model after Craig Sapp

;;////////////////////////////////////////////

 

 

(defun accidental-base (number)

  (case number

    (4 -4)

    (7 -3)

    (1 -2)

    (6 -1)

    (3 0)

    (0 0)

    (8 1)

    (2 2)

    (9 3)

    (5 4)))

 

(defun microtonal-base-to-accidental (number)

  (case number

    (-4 4)

    (-3 7)

    (-2 1)

    (-1 6)

    ;;(0 3)

    (0 0)

    (1 8)

    (2 2)

    (3 9)

    (4 5)))

 

(defun pitch-chroma (number)

  (case (mod (- (mod (truncate number) 7) 1) 7)

    (0 0)

    (1 26)

    (2 52)

    (3 77)

    (4 103)

    (5 129)

    (6 155)))

 

(defun chroma-value-to-pitch (number)

  (case number

    (0 1.0)

    (26 2.0)

    (52 3.0)

    (77 4.0)

    (103 5.0)

    (129 6.0)

    (155 7.0)))

 

#|

 

(defun octave-case (octave)

  (case octave

    (0 -28.0)

    (1 -21.0)

    (2 -14.0)

    (3 -7.0)

    (4 0.0)

    (5 7.0)

    (6 14.0)

    (7 21.0)

    (8 28.0)))

 

|#

 

(defun octave-equivalence (number)

  (cond ((<= -27.0 number -21.0) 0)

        ((<= -20.0 number -14.0) 1)

        ((<= -13.0 number -7.0) 2)

        ((<= -6.0 number -0.0) 3)

        ((<= 1.0 number 7.0) 4)

        ((<= 8.0 number 14.0) 5)

        ((<= 15.0 number 21.0) 6)

        ((<= 22.0 number 28.0) 7)

        ((<= 29.0 number 35.0) 8)))

 

 

;;(octave-equivalence 0.0)

;;(octave-equivalence 1.0)

;;(octave-equivalence 8.0)

 

;;============================================

;;Arguments of the following function are in Score notation:

;;============================================

 

(defun approximate-number* (number list)

  (if (endp list) nil

      (cons (list (abs (- (first list) number)) (first list))

            (approximate-number* number (rest list)))))

 

(defun min-number-in-list (min-number list)

  (cond ((endp list)

         nil)

        ((eql min-number (first (first list)))

         (cons (second (first list)) (min-number-in-list min-number (rest list))))

        (t (min-number-in-list min-number (rest list)))))

 

(defun approximate-number (number list)

  (let* ((current-list (approximate-number* number list))

         (min-value (eval (cons 'min (mapcar #'(lambda (x) (first x)) current-list ))))

         (result-list (min-number-in-list min-value current-list)))

    (if (atom result-list) result-list (apply #'min result-list))))

 

(defun pitch-to-base-180 (pitch-number alteration-number)

  (let ((diatonic-chroma

         (pitch-chroma pitch-number))

        (alteration-value

         (accidental-base (second (expand-note alteration-number))))

        (octave-value (octave-equivalence pitch-number)))

    (+ (* 180 octave-value) 12 diatonic-chroma alteration-value)))

 

(defun base-180-to-pitch (number)

  (let* ((octave-value (truncate (/ number 180.0)))

        (chroma-approximation (- (mod number 180) 12))

        (diatonic-pitch (approximate-number chroma-approximation '(0 26 52 77 103 129 155)))

        (accidental (- chroma-approximation diatonic-pitch))

        (score-pitch-and-octave (+ (chroma-value-to-pitch diatonic-pitch)

                                    (octave-case octave-value)))

        (stem-direction (if (>= 7.0 score-pitch-and-octave) 1 2)))

    (if (equal 'nil (microtonal-base-to-accidental accidental))

      "Out of microtonal SCORE notation"

      (list score-pitch-and-octave

            (float (collide-list (list stem-direction

                                       (microtonal-base-to-accidental accidental))))))))

 

(defun chroma-array (reference direction)

  (cond

   ((and (or (equal reference 0) (equal reference 180))

         (equal direction '-))

    155)

   ((and (or (equal reference 0) (equal reference 180))

         (equal direction '+))

    26)

   ((and (equal reference 26)

         (equal direction '-))

    0)

   ((and (equal reference 26)

         (equal direction '+))

    52)

   ((and (equal reference 52)

         (equal direction '-))

    26)

   ((and (equal reference 52)

         (equal direction '+))

    77)

   ((and (equal reference 77)

         (equal direction '-))

    52)

   ((and (equal reference 77)

         (equal direction '+))

    103)

   ((and (equal reference 103)

         (equal direction '-))

    77)

   ((and (equal reference 103)

         (equal direction '+))

    129)

   ((and (equal reference 129)

         (equal direction '-))

    103)

   ((and (equal reference 129)

         (equal direction '+))

    155)

   ((and (equal reference 155)

         (equal direction '-))

    129)

   ((and (equal reference 155)

         (equal direction '+))

    180)))

 

(defun enharmonic-down (pitch-number alteration-number)

  (let* ((current-chroma (if (equal (pitch-chroma pitch-number) 0)

                           180

                           (pitch-chroma pitch-number)))

         (chroma-in-array (chroma-array current-chroma '-))

         (current-pitch-in-base-180 (pitch-to-base-180 pitch-number alteration-number)))

    (base-180-to-pitch (- (+ current-pitch-in-base-180

                             current-chroma)

                          chroma-in-array

                          (* 2 (- 25 1))))))

 

(defun enharmonic-up (pitch-number alteration-number)

  (let* ((current-chroma (if (equal (pitch-chroma pitch-number) 180)

                           0

                           (pitch-chroma pitch-number)))

         (chroma-in-array (chroma-array current-chroma '+))

         (current-pitch-in-base-180 (pitch-to-base-180 pitch-number alteration-number)))

    (base-180-to-pitch (- (+ current-pitch-in-base-180

                             (* 2 (- 25 1))

                             current-chroma)

                          chroma-in-array))))