[gsharp-cvs] CVS gsharp

[rstrandh]

Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp:/tmp/cvs-serv21781

Modified Files:
	buffer.lisp 
Log Message:
Embryonic key signature protocol.



--- /project/gsharp/cvsroot/gsharp/buffer.lisp	2006/02/06 04:20:23	1.30
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp	2006/02/08 18:36:28	1.31
@@ -276,6 +276,65 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
+;;; 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 (melody-element)
+  ((%staff :initarg :staff :reader staff)
+   (%alterations :initform (make-array 7 :initial-element :natural) 
+		 :initarg :alterations :reader 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