;;********************************************
;;********************************************
;;////////////////////////////////////////////
;;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))))