Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv25693
Modified Files: buffer.lisp gsharp.asd Added Files: melody.lisp Log Message: I moved melody-related functionality from buffer.lisp to a new file.
--- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/10/22 10:03:40 1.56 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/10/22 11:45:36 1.57 @@ -33,6 +33,8 @@ (save-object obj stream) (print-unreadable-object (obj stream :type t :identity t))))
+(define-condition gsharp-condition (error) ()) + (defgeneric name (obj))
(defclass name-mixin () @@ -43,296 +45,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Clef - -;;; The line number on which the clef is located on the staff. -;;; The bottom line of the staff is number 1. -(defgeneric lineno (clef)) - -;;; for key signature drawing calcluations. FIXME: in fact the layout -;;; of key signatures isn't the same across all clefs. -(defgeneric b-position (clef)) -(defgeneric f-position (clef)) - -;;; the note number of the bottom line of this clef. -(defgeneric bottom-line (clef)) - -(defclass clef (gsharp-object name-mixin) - ((lineno :reader lineno :initarg :lineno - :type (or (integer 0 8) null)))) - -(defun make-clef (name &key lineno) - (declare (type (member :treble :treble8 :bass :c :percussion) name) - (type (or (integer 0 8) null) lineno)) - (when (null lineno) - (setf lineno - (ecase name - ((:treble :treble8) 2) - (:bass 6) - (:c 4) - (:percussion 3)))) - (make-instance 'clef :name name :lineno lineno)) - -(defmethod slots-to-be-saved append ((c clef)) - '(lineno)) - -(defun read-clef-v3 (stream char n) - (declare (ignore char n)) - (apply #'make-instance 'clef (read-delimited-list #] stream t))) - -(set-dispatch-macro-character #[ #\K - #'read-clef-v3 - *gsharp-readtable-v3*) - -;;; given a clef, return the staff step of the B that should have -;;; the first flat sign in key signatures with flats -(defmethod b-position ((clef clef)) - (ecase (name clef) - (:bass (- (lineno clef) 4)) - ((:treble :treble8) (+ (lineno clef) 2)) - (:c (- (lineno clef) 1)))) - - -;;; given a clef, return the staff step of the F that should have -;;; the first sharp sign in key signatures with sharps -(defmethod f-position ((clef clef)) - (ecase (name clef) - (:bass (lineno clef)) - ((:treble :treble8) (+ (lineno clef) 6)) - (:c (+ (lineno clef) 3)))) - -(defmethod bottom-line ((clef clef)) - (- (ecase (name clef) - (:treble 32) - (:bass 24) - (:c 28) - (:treble8 25)) - (lineno clef))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Staff
(defclass staff (gsharp-object name-mixin) ((buffer :initarg :buffer :accessor buffer)) (:default-initargs :name "default staff"))
-;;; fiveline - -(defgeneric clef (fiveline-staff)) - -(defclass fiveline-staff (staff) - ((clef :accessor clef :initarg :clef :initform (make-clef :treble)) - (%keysig :accessor keysig :initarg :keysig - :initform (make-array 7 :initial-element :natural)) - (key-signatures :accessor key-signatures :initform nil))) - -(defmethod initialize-instance :after ((obj fiveline-staff) &rest args) - (declare (ignore args)) - (with-slots (%keysig) obj - (when (vectorp %keysig) - (setf %keysig - (make-instance 'key-signature :staff obj :alterations %keysig))))) - -(defun make-fiveline-staff (&rest args &key name clef keysig) - (declare (ignore name clef keysig)) - (apply #'make-instance 'fiveline-staff args)) - -(defmethod slots-to-be-saved append ((s fiveline-staff)) - '(clef %keysig)) - -(defun read-fiveline-staff-v3 (stream char n) - (declare (ignore char n)) - (apply #'make-instance 'fiveline-staff (read-delimited-list #] stream t))) - -(set-dispatch-macro-character #[ #= - #'read-fiveline-staff-v3 - *gsharp-readtable-v3*) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Note - -;;; Notes are immutable objets. If you want to alter (say) the staff -;;; or the pitch of a note, you have to delete it and add a new note -;;; with the right characteristics. - -;;; Return the pitch of the note. -(defgeneric pitch (note)) - -;;; Return the accidentals of the note. The value returned is one of -;;; :natural :flat :double-flat :sharp or :double-sharp. -(defgeneric accidentals (note)) - -;;; Return a non-negative integer indicating the number of dots of the -;;; note. The value nil is returned whenever the note takes its -;;; number of dots from the cluster to which it belongs. -(defgeneric dots (note)) - -;;; Returns the cluster to which the note belongs, or nil if the note -;;; currently does not belong to any cluster. -(defgeneric cluster (note)) - -;;; The pitch is a number from 0 to 128 -;;; -;;; The staff is a staff object. -;;; -;;; Head can be :long, :breve, :whole, :half, :filled, or nil. A -;;; value of nil means that the notehead is determined by that of the -;;; cluster to which the note belongs. -;;; -;;; Accidentals can be :natural :flat :double-flat :sharp or :double-sharp. -;;; The default is :natural. Whether a note is actually displayed -;;; preceded by one of the corresponding signs is a matter of context and -;;; display style. -;;; -;;; The number of dots can be an integer or nil, meaning that the number -;;; of dots is taken from the cluster. The default value is nil. -;;; -;;; The actual duration of the note is computed from the note head, the -;;; number of beams of the cluster to which the note belongs, and the -;;; number of dots in the usual way. - -(defclass note (gsharp-object) - ((cluster :initform nil :initarg :cluster :accessor cluster) - (pitch :initarg :pitch :reader pitch :type (integer 0 127)) - (staff :initarg :staff :reader staff :type staff) - (head :initform nil :initarg :head :reader head - :type (or (member :long :breve :whole :half :filled) null)) - (accidentals :initform :natural :initarg :accidentals :reader accidentals - ;; FIXME: we want :TYPE ACCIDENTAL here but need to - ;; sort out order of definition for that to be useful. - #+nil #+nil - :type (member :natural :flat :double-flat :sharp :double-sharp)) - (dots :initform nil :initarg :dots :reader dots - :type (or (integer 0 3) null)) - (%tie-right :initform nil :initarg :tie-right :accessor tie-right) - (%tie-left :initform nil :initarg :tie-left :accessor tie-left))) - -(defun make-note (pitch staff &rest args &key head (accidentals :natural) dots) - (declare (type (integer 0 127) pitch) - (type staff staff) - (type (or (member :long :breve :whole :half :filled) null) head) - ;; FIXME: :TYPE ACCIDENTAL - #+nil #+nil - (type (member :natural :flat :double-flat :sharp :double-sharp) - accidentals) - (type (or (integer 0 3) null) dots) - (ignore head accidentals dots)) - (apply #'make-instance 'note :pitch pitch :staff staff args)) - -(defmethod slots-to-be-saved append ((n note)) - '(pitch staff head accidentals dots %tie-right %tie-left)) - -(defun read-note-v3 (stream char n) - (declare (ignore char n)) - (apply #'make-instance 'note (read-delimited-list #] stream t))) - -(set-dispatch-macro-character #[ #\N - #'read-note-v3 - *gsharp-readtable-v3*) - -;;; Return true if note1 is considered less than note2. -(defun note-less (note1 note2) - (< (pitch note1) (pitch note2))) - -;;; Return true if note1 is considered equal to note2. -(defun note-equal (note1 note2) - (= (pitch note1) (pitch note2))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Tuning (support for microtonal and historical tunings/temperaments) - -;;; FIXME: add name-mixin also? -(defclass tuning (gsharp-object) - ((master-pitch-note :initform (make-instance 'note :pitch 33 ; a above middle c - :staff (make-instance 'staff)) - :initarg :master-pitch-note - :type note - :accessor master-pitch-note) - (master-pitch-freq :initform 440 - :initarg :master-pitch-freq - :accessor master-pitch-freq))) - -(defmethod slots-to-be-saved append ((tuning tuning)) - '(master-pitch-note master-pitch-freq)) - -;;; Returns how a note should be tuned in a given tuning -;;; in terms of a cent value. -(defgeneric note-cents (note tuning)) - -;;; 12-edo is provided for efficiency only. It is a -;;; special case of a regular temperament. Perhaps it -;;; should be removed? -(defclass 12-edo (tuning) - ()) - -(defmethod slots-to-be-saved append ((tuning 12-edo)) - '()) - -(defmethod note-cents ((note note) (tuning 12-edo)) - (multiple-value-bind (octave pitch) (floor (pitch note) 7) - (+ (* 1200 (1+ octave)) - (ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100)) - (ecase (accidentals note) - (:double-flat -200) - (:sesquiflat -150) - (:flat -100) - (:semiflat -50) - (:natural 0) - (:semisharp 50) - (:sharp 100) - (:sesquisharp 150) - (:double-sharp 200))))) - -;;; regular temperaments are temperaments that -;;; retain their interval sizes regardless of modulation, as opposed to -;;; irregular temperaments. -(defclass regular-temperament (tuning) - ((octave-cents :initform 1200 :initarg :octave-cents :accessor octave-cents) - (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents) - (quartertone-cents :initform 50 :initarg :quartertone-cents :accessor quartertone-cents) - ;; TODO: Add cent sizes of various microtonal accidentals, perhaps in an alist? - )) - -(defmethod slots-to-be-saved append ((tuning regular-temperament)) - '(octave-cents fifth-cents)) - -(defmethod note-cents ((note note) (tuning regular-temperament)) - (let ((octaves 1) - (fifths 0) - (sharps 0) ;; short for 7 fifths up and 4 octaves down - (quartertones 0)) - (incf octaves (floor (pitch note) 7)) - (ecase (mod (pitch note) 7) - (0 (progn)) - (1 (progn (incf octaves -1) (incf fifths 2))) - (2 (progn (incf octaves -2) (incf fifths 4))) - (3 (progn (incf octaves 1) (incf fifths -1))) - (4 (progn (incf fifths 1))) - (5 (progn (incf octaves -1) (incf fifths 3))) - (6 (progn (incf octaves -2) (incf fifths 5)))) - (ecase (accidentals note) - (:double-flat (incf sharps -2)) - (:sesquiflat (incf sharps -1) (incf quartertones -1)) - (:flat (incf sharps -1)) - (:semiflat (incf quartertones -1)) - (:natural) - (:semisharp (incf quartertones 1)) - (:sharp (incf sharps 1)) - (:sesquisharp (incf sharps 1) (incf quartertones 1)) - (:double-sharp (incf sharps 2))) - (incf octaves (* -4 sharps)) - (incf fifths (* 7 sharps)) - (+ (* octaves (octave-cents tuning)) - (* fifths (fifth-cents tuning)) - (* quartertones (quartertone-cents tuning))))) - -;;; TODO: (defclass irregular-temperament ...) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Element @@ -404,216 +122,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Melody element - -(defclass melody-element (rhythmic-element) ()) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Key signature - -(defgeneric alterations (key-signature) - (:documentation "return the alterations in the form of a -7-element array where each element is either :natural, -:sharp, or :flat according to how each staff position -should be altered")) - -(defgeneric more-sharps (key-signature &optional n) - (:documentation "make the key signature N alterations -sharper by removing some flats and/or adding some sharps")) - -(defgeneric more-flats (key-signature &optional n) - (:documentation "make the key signature N alterations -flatter by removing some sharps and/or adding some flats")) - -(defclass key-signature (element) - ((%staff :initarg :staff :reader staff) - (%alterations :initform (make-array 7 :initial-element :natural) - :initarg :alterations :reader alterations))) - -(defun make-key-signature (staff &rest args &key alterations) - (declare (type (or null (simple-vector 7)) alterations) - (ignore alterations)) - (apply #'make-instance 'key-signature :staff staff args)) - -(defmethod slots-to-be-saved append ((k key-signature)) - '(%staff %alterations)) - -(defmethod more-sharps ((sig key-signature) &optional (n 1)) - (let ((alt (alterations sig))) - (loop repeat n - do (cond ((eq (aref alt 3) :flat) (setf (aref alt 3) :natural)) - ((eq (aref alt 0) :flat) (setf (aref alt 0) :natural)) - ((eq (aref alt 4) :flat) (setf (aref alt 4) :natural)) - ((eq (aref alt 1) :flat) (setf (aref alt 1) :natural)) - ((eq (aref alt 5) :flat) (setf (aref alt 5) :natural)) - ((eq (aref alt 2) :flat) (setf (aref alt 2) :natural)) - ((eq (aref alt 6) :flat) (setf (aref alt 6) :natural)) - ((eq (aref alt 3) :natural) (setf (aref alt 3) :sharp)) - ((eq (aref alt 0) :natural) (setf (aref alt 0) :sharp)) - ((eq (aref alt 4) :natural) (setf (aref alt 4) :sharp)) - ((eq (aref alt 1) :natural) (setf (aref alt 1) :sharp)) - ((eq (aref alt 5) :natural) (setf (aref alt 5) :sharp)) - ((eq (aref alt 2) :natural) (setf (aref alt 2) :sharp)) - ((eq (aref alt 6) :natural) (setf (aref alt 6) :sharp)))))) - -(defmethod more-flats ((sig key-signature) &optional (n 1)) - (let ((alt (alterations sig))) - (loop repeat n - do (cond ((eq (aref alt 6) :sharp) (setf (aref alt 6) :natural)) - ((eq (aref alt 2) :sharp) (setf (aref alt 2) :natural)) - ((eq (aref alt 5) :sharp) (setf (aref alt 5) :natural)) - ((eq (aref alt 1) :sharp) (setf (aref alt 1) :natural)) - ((eq (aref alt 4) :sharp) (setf (aref alt 4) :natural)) - ((eq (aref alt 0) :sharp) (setf (aref alt 0) :natural)) - ((eq (aref alt 3) :sharp) (setf (aref alt 3) :natural)) - ((eq (aref alt 6) :natural) (setf (aref alt 6) :flat)) - ((eq (aref alt 2) :natural) (setf (aref alt 2) :flat)) - ((eq (aref alt 5) :natural) (setf (aref alt 5) :flat)) - ((eq (aref alt 1) :natural) (setf (aref alt 1) :flat)) - ((eq (aref alt 4) :natural) (setf (aref alt 4) :flat)) - ((eq (aref alt 0) :natural) (setf (aref alt 0) :flat)) - ((eq (aref alt 3) :natural) (setf (aref alt 3) :flat)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Cluster - -;;; Return a list of the notes of the cluster -(defgeneric notes (cluster)) - -;;; Add a note to the cluster. It is an error if there is already a -;;; note in the cluster with the same staff and the same pitch. -(defgeneric add-note (cluster note)) - -;;; Find a note in a cluster. The comparison is made using only the -;;; pitch of the supplied note. If the note does not exist nil is returned. -(defgeneric find-note (cluster note)) - -;;; Delete a note from the cluster to which it belongs. It is an -;;; error to call this function if the note currently does not belong
[199 lines skipped] --- /project/gsharp/cvsroot/gsharp/gsharp.asd 2007/10/22 09:39:23 1.18 +++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2007/10/22 11:45:37 1.19 @@ -27,6 +27,7 @@ "sdl" "score-pane" "buffer" + "melody" "lyrics" "numbering" "Obseq/obseq"
--- /project/gsharp/cvsroot/gsharp/melody.lisp 2007/10/22 11:45:37 NONE +++ /project/gsharp/cvsroot/gsharp/melody.lisp 2007/10/22 11:45:37 1.1 (in-package :gsharp-buffer)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Clef
;;; The line number on which the clef is located on the staff. ;;; The bottom line of the staff is number 1. (defgeneric lineno (clef))
;;; for key signature drawing calcluations. FIXME: in fact the layout ;;; of key signatures isn't the same across all clefs. (defgeneric b-position (clef)) (defgeneric f-position (clef))
;;; the note number of the bottom line of this clef. (defgeneric bottom-line (clef))
(defclass clef (gsharp-object name-mixin) ((lineno :reader lineno :initarg :lineno :type (or (integer 0 8) null))))
(defun make-clef (name &key lineno) (declare (type (member :treble :treble8 :bass :c :percussion) name) (type (or (integer 0 8) null) lineno)) (when (null lineno) (setf lineno (ecase name ((:treble :treble8) 2) (:bass 6) (:c 4) (:percussion 3)))) (make-instance 'clef :name name :lineno lineno))
(defmethod slots-to-be-saved append ((c clef)) '(lineno))
(defun read-clef-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'clef (read-delimited-list #] stream t)))
(set-dispatch-macro-character #[ #\K #'read-clef-v3 *gsharp-readtable-v3*)
;;; given a clef, return the staff step of the B that should have ;;; the first flat sign in key signatures with flats (defmethod b-position ((clef clef)) (ecase (name clef) (:bass (- (lineno clef) 4)) ((:treble :treble8) (+ (lineno clef) 2)) (:c (- (lineno clef) 1))))
;;; given a clef, return the staff step of the F that should have ;;; the first sharp sign in key signatures with sharps (defmethod f-position ((clef clef)) (ecase (name clef) (:bass (lineno clef)) ((:treble :treble8) (+ (lineno clef) 6)) (:c (+ (lineno clef) 3))))
(defmethod bottom-line ((clef clef)) (- (ecase (name clef) (:treble 32) (:bass 24) (:c 28) (:treble8 25)) (lineno clef)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Fiveline staff
(defgeneric clef (fiveline-staff))
(defclass fiveline-staff (staff) ((clef :accessor clef :initarg :clef :initform (make-clef :treble)) (%keysig :accessor keysig :initarg :keysig :initform (make-array 7 :initial-element :natural)) (key-signatures :accessor key-signatures :initform nil)))
(defmethod initialize-instance :after ((obj fiveline-staff) &rest args) (declare (ignore args)) (with-slots (%keysig) obj (when (vectorp %keysig) (setf %keysig (make-instance 'key-signature :staff obj :alterations %keysig)))))
(defun make-fiveline-staff (&rest args &key name clef keysig) (declare (ignore name clef keysig)) (apply #'make-instance 'fiveline-staff args))
(defmethod slots-to-be-saved append ((s fiveline-staff)) '(clef %keysig))
(defun read-fiveline-staff-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'fiveline-staff (read-delimited-list #] stream t)))
(set-dispatch-macro-character #[ #= #'read-fiveline-staff-v3 *gsharp-readtable-v3*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Note
;;; Notes are immutable objets. If you want to alter (say) the staff ;;; or the pitch of a note, you have to delete it and add a new note ;;; with the right characteristics.
;;; Return the pitch of the note. (defgeneric pitch (note))
;;; Return the accidentals of the note. The value returned is one of ;;; :natural :flat :double-flat :sharp or :double-sharp. (defgeneric accidentals (note))
;;; Return a non-negative integer indicating the number of dots of the ;;; note. The value nil is returned whenever the note takes its ;;; number of dots from the cluster to which it belongs. (defgeneric dots (note))
;;; Returns the cluster to which the note belongs, or nil if the note ;;; currently does not belong to any cluster. (defgeneric cluster (note))
;;; The pitch is a number from 0 to 128 ;;; ;;; The staff is a staff object. ;;; ;;; Head can be :long, :breve, :whole, :half, :filled, or nil. A ;;; value of nil means that the notehead is determined by that of the ;;; cluster to which the note belongs. ;;; ;;; Accidentals can be :natural :flat :double-flat :sharp or :double-sharp. ;;; The default is :natural. Whether a note is actually displayed ;;; preceded by one of the corresponding signs is a matter of context and ;;; display style. ;;; ;;; The number of dots can be an integer or nil, meaning that the number ;;; of dots is taken from the cluster. The default value is nil. ;;; ;;; The actual duration of the note is computed from the note head, the ;;; number of beams of the cluster to which the note belongs, and the ;;; number of dots in the usual way.
(defclass note (gsharp-object) ((cluster :initform nil :initarg :cluster :accessor cluster) (pitch :initarg :pitch :reader pitch :type (integer 0 127)) (staff :initarg :staff :reader staff :type staff) (head :initform nil :initarg :head :reader head :type (or (member :long :breve :whole :half :filled) null)) (accidentals :initform :natural :initarg :accidentals :reader accidentals ;; FIXME: we want :TYPE ACCIDENTAL here but need to ;; sort out order of definition for that to be useful. #+nil #+nil :type (member :natural :flat :double-flat :sharp :double-sharp)) (dots :initform nil :initarg :dots :reader dots :type (or (integer 0 3) null)) (%tie-right :initform nil :initarg :tie-right :accessor tie-right) (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))
(defun make-note (pitch staff &rest args &key head (accidentals :natural) dots) (declare (type (integer 0 127) pitch) (type staff staff) (type (or (member :long :breve :whole :half :filled) null) head) ;; FIXME: :TYPE ACCIDENTAL #+nil #+nil (type (member :natural :flat :double-flat :sharp :double-sharp) accidentals) (type (or (integer 0 3) null) dots) (ignore head accidentals dots)) (apply #'make-instance 'note :pitch pitch :staff staff args))
(defmethod slots-to-be-saved append ((n note)) '(pitch staff head accidentals dots %tie-right %tie-left))
(defun read-note-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'note (read-delimited-list #] stream t)))
(set-dispatch-macro-character #[ #\N #'read-note-v3 *gsharp-readtable-v3*)
;;; Return true if note1 is considered less than note2. (defun note-less (note1 note2) (< (pitch note1) (pitch note2)))
;;; Return true if note1 is considered equal to note2. (defun note-equal (note1 note2) (= (pitch note1) (pitch note2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Tuning (support for microtonal and historical tunings/temperaments)
;;; FIXME: add name-mixin also? (defclass tuning (gsharp-object) ((master-pitch-note :initform (make-instance 'note :pitch 33 ; a above middle c :staff (make-instance 'staff)) :initarg :master-pitch-note :type note :accessor master-pitch-note) (master-pitch-freq :initform 440 :initarg :master-pitch-freq :accessor master-pitch-freq)))
(defmethod slots-to-be-saved append ((tuning tuning)) '(master-pitch-note master-pitch-freq))
;;; Returns how a note should be tuned in a given tuning ;;; in terms of a cent value. (defgeneric note-cents (note tuning))
;;; 12-edo is provided for efficiency only. It is a ;;; special case of a regular temperament. Perhaps it ;;; should be removed? (defclass 12-edo (tuning) ())
(defmethod slots-to-be-saved append ((tuning 12-edo)) '())
(defmethod note-cents ((note note) (tuning 12-edo)) (multiple-value-bind (octave pitch) (floor (pitch note) 7) (+ (* 1200 (1+ octave)) (ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100)) (ecase (accidentals note) (:double-flat -200) (:sesquiflat -150) (:flat -100) (:semiflat -50) (:natural 0) (:semisharp 50) (:sharp 100) (:sesquisharp 150) (:double-sharp 200)))))
;;; regular temperaments are temperaments that ;;; retain their interval sizes regardless of modulation, as opposed to ;;; irregular temperaments. (defclass regular-temperament (tuning) ((octave-cents :initform 1200 :initarg :octave-cents :accessor octave-cents) (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents) (quartertone-cents :initform 50 :initarg :quartertone-cents :accessor quartertone-cents) ;; TODO: Add cent sizes of various microtonal accidentals, perhaps in an alist? ))
(defmethod slots-to-be-saved append ((tuning regular-temperament)) '(octave-cents fifth-cents))
(defmethod note-cents ((note note) (tuning regular-temperament)) (let ((octaves 1) (fifths 0) (sharps 0) ;; short for 7 fifths up and 4 octaves down (quartertones 0)) (incf octaves (floor (pitch note) 7)) (ecase (mod (pitch note) 7) (0 (progn)) (1 (progn (incf octaves -1) (incf fifths 2))) (2 (progn (incf octaves -2) (incf fifths 4))) (3 (progn (incf octaves 1) (incf fifths -1))) (4 (progn (incf fifths 1))) (5 (progn (incf octaves -1) (incf fifths 3))) (6 (progn (incf octaves -2) (incf fifths 5)))) (ecase (accidentals note) (:double-flat (incf sharps -2)) (:sesquiflat (incf sharps -1) (incf quartertones -1)) (:flat (incf sharps -1)) (:semiflat (incf quartertones -1)) (:natural) (:semisharp (incf quartertones 1)) (:sharp (incf sharps 1)) (:sesquisharp (incf sharps 1) (incf quartertones 1)) (:double-sharp (incf sharps 2))) (incf octaves (* -4 sharps)) (incf fifths (* 7 sharps)) (+ (* octaves (octave-cents tuning)) (* fifths (fifth-cents tuning)) (* quartertones (quartertone-cents tuning)))))
;;; TODO: (defclass irregular-temperament ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Melody element
(defclass melody-element (rhythmic-element) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Key signature
(defgeneric alterations (key-signature) (:documentation "return the alterations in the form of a 7-element array where each element is either :natural, :sharp, or :flat according to how each staff position should be altered"))
(defgeneric more-sharps (key-signature &optional n) (:documentation "make the key signature N alterations sharper by removing some flats and/or adding some sharps"))
(defgeneric more-flats (key-signature &optional n) (:documentation "make the key signature N alterations flatter by removing some sharps and/or adding some flats"))
(defclass key-signature (element) ((%staff :initarg :staff :reader staff) (%alterations :initform (make-array 7 :initial-element :natural) :initarg :alterations :reader alterations)))
(defun make-key-signature (staff &rest args &key alterations) (declare (type (or null (simple-vector 7)) alterations) (ignore alterations)) (apply #'make-instance 'key-signature :staff staff args))
(defmethod slots-to-be-saved append ((k key-signature)) '(%staff %alterations))
(defmethod more-sharps ((sig key-signature) &optional (n 1)) (let ((alt (alterations sig))) (loop repeat n do (cond ((eq (aref alt 3) :flat) (setf (aref alt 3) :natural)) ((eq (aref alt 0) :flat) (setf (aref alt 0) :natural)) ((eq (aref alt 4) :flat) (setf (aref alt 4) :natural)) ((eq (aref alt 1) :flat) (setf (aref alt 1) :natural)) ((eq (aref alt 5) :flat) (setf (aref alt 5) :natural)) ((eq (aref alt 2) :flat) (setf (aref alt 2) :natural)) ((eq (aref alt 6) :flat) (setf (aref alt 6) :natural)) ((eq (aref alt 3) :natural) (setf (aref alt 3) :sharp)) ((eq (aref alt 0) :natural) (setf (aref alt 0) :sharp)) ((eq (aref alt 4) :natural) (setf (aref alt 4) :sharp)) ((eq (aref alt 1) :natural) (setf (aref alt 1) :sharp)) ((eq (aref alt 5) :natural) (setf (aref alt 5) :sharp)) ((eq (aref alt 2) :natural) (setf (aref alt 2) :sharp)) ((eq (aref alt 6) :natural) (setf (aref alt 6) :sharp))))))
(defmethod more-flats ((sig key-signature) &optional (n 1)) (let ((alt (alterations sig))) (loop repeat n do (cond ((eq (aref alt 6) :sharp) (setf (aref alt 6) :natural)) ((eq (aref alt 2) :sharp) (setf (aref alt 2) :natural)) ((eq (aref alt 5) :sharp) (setf (aref alt 5) :natural)) ((eq (aref alt 1) :sharp) (setf (aref alt 1) :natural)) ((eq (aref alt 4) :sharp) (setf (aref alt 4) :natural)) ((eq (aref alt 0) :sharp) (setf (aref alt 0) :natural)) ((eq (aref alt 3) :sharp) (setf (aref alt 3) :natural)) ((eq (aref alt 6) :natural) (setf (aref alt 6) :flat)) ((eq (aref alt 2) :natural) (setf (aref alt 2) :flat)) ((eq (aref alt 5) :natural) (setf (aref alt 5) :flat)) ((eq (aref alt 1) :natural) (setf (aref alt 1) :flat)) ((eq (aref alt 4) :natural) (setf (aref alt 4) :flat)) ((eq (aref alt 0) :natural) (setf (aref alt 0) :flat)) ((eq (aref alt 3) :natural) (setf (aref alt 3) :flat))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Cluster
;;; Return a list of the notes of the cluster (defgeneric notes (cluster))
;;; Add a note to the cluster. It is an error if there is already a ;;; note in the cluster with the same staff and the same pitch. (defgeneric add-note (cluster note))
;;; Find a note in a cluster. The comparison is made using only the ;;; pitch of the supplied note. If the note does not exist nil is returned. (defgeneric find-note (cluster note))
;;; Delete a note from the cluster to which it belongs. It is an ;;; error to call this function if the note currently does not belong ;;; to any cluster. (defgeneric remove-note (note))
(defclass cluster (melody-element) ((notes :initform '() :initarg :notes :accessor notes) (stem-direction :initform :auto :initarg :stem-direction :accessor stem-direction)))
(defmethod initialize-instance :after ((c cluster) &rest args) (declare (ignore args)) (loop for note in (notes c) do (setf (cluster note) c)))
(defun make-cluster (&rest args
[156 lines skipped]