melody.lisp

   1 (in-package :gsharp-buffer)
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;;;
   5 ;;; Clef
   6
   7 ;;; The line number on which the clef is located on the staff.
   8 ;;; The bottom line of the staff is number 1.
   9 (defgeneric lineno (clef))
  10
  11 ;;; for key signature drawing calcluations.  FIXME: in fact the layout
  12 ;;; of key signatures isn't the same across all clefs.
  13 (defgeneric b-position (clef))
  14 (defgeneric f-position (clef))
  15
  16 ;;; the note number of the bottom line of this clef.
  17 (defgeneric bottom-line (clef))
  18
  19 (defclass clef (staffwise-element gsharp-object name-mixin)
  20   ((lineno :reader lineno :initarg :lineno
  21            :type (or (integer 0 8) null))))
  22
  23 (defun make-clef (name &key lineno)
  24   (declare (type (member :treble :treble8 :bass :c :percussion) name)
  25            (type (or (integer 0 8) null) lineno))
  26   (when (null lineno)
  27     (setf lineno
  28           (ecase name
  29             ((:treble :treble8) 2)
  30             (:bass 6)
  31             (:c 4)
  32             (:percussion 3))))
  33   (make-instance 'clef :name name :lineno lineno))
  34
  35 (defmethod slots-to-be-saved append ((c clef))
  36   '(lineno))
  37
  38 (defun read-clef-v3 (stream char n)
  39   (declare (ignore char n))
  40   (apply #'make-instance 'clef (read-delimited-list #\] stream t)))
  41
  42 (set-dispatch-macro-character #\[ #\K
  43   #'read-clef-v3
  44   *gsharp-readtable-v3*)
  45
  46 ;;; given a clef, return the staff step of the B that should have
  47 ;;; the first flat sign in key signatures with flats
  48 (defmethod b-position ((clef clef))
  49   (ecase (name clef)
  50     (:bass (- (lineno clef) 4))
  51     ((:treble :treble8) (+ (lineno clef) 2))
  52     (:c (- (lineno clef) 1))))
  53
  54
  55 ;;; given a clef, return the staff step of the F that should have
  56 ;;; the first sharp sign in key signatures with sharps
  57 (defmethod f-position ((clef clef))
  58   (ecase (name clef)
  59     (:bass (lineno clef))
  60     ((:treble :treble8) (+ (lineno clef) 6))
  61     (:c (+ (lineno clef) 3))))
  62
  63 (defmethod bottom-line ((clef clef))
  64   (- (ecase (name clef)
  65        (:treble 32)
  66        (:bass 24)
  67        (:c 28)
  68        (:treble8 25))
  69      (lineno clef)))
  70
  71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72 ;;;
  73 ;;; Fiveline staff
  74
  75 (defgeneric clef (fiveline-staff))
  76
  77 (defclass fiveline-staff (staff)
  78   ((clef :accessor clef :initarg :clef :initform (make-clef :treble))
  79    (%keysig :accessor keysig :initarg :keysig
  80             :initform (make-array 7 :initial-element :natural))
  81    (staffwise-elements :accessor staffwise-elements :initform nil)))
  82
  83 (defgeneric key-signatures (staff)
  84   (:method ((s fiveline-staff))
  85     (remove-if #'(lambda (x) (not (typep x 'key-signature)))
  86                (staffwise-elements s))))
  87 (defgeneric time-signatures (staff)
  88   (:method ((s fiveline-staff))
  89     (remove-if #'(lambda (x) (not (typep x 'time-signature)))
  90                (staffwise-elements s))))
  91
  92 (defmethod initialize-instance :after ((obj fiveline-staff) &rest args)
  93   (declare (ignore args))
  94   (with-slots (%keysig) obj
  95     (when (vectorp %keysig)
  96       (setf %keysig
  97             (make-instance 'key-signature :staff obj :alterations %keysig)))))
  98
  99 (defun make-fiveline-staff (&rest args &key name clef keysig)
 100   (declare (ignore name clef keysig))
 101   (apply #'make-instance 'fiveline-staff args))
 102
 103 (defmethod slots-to-be-saved append ((s fiveline-staff))
 104   '(clef %keysig))
 105
 106 (defun read-fiveline-staff-v3 (stream char n)
 107   (declare (ignore char n))
 108   (apply #'make-instance 'fiveline-staff (read-delimited-list #\] stream t)))
 109
 110 (set-dispatch-macro-character #\[ #\=
 111   #'read-fiveline-staff-v3
 112   *gsharp-readtable-v3*)
 113
 114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 115 ;;;
 116 ;;; Note
 117
 118 ;;; Notes are immutable objets.  If you want to alter (say) the staff
 119 ;;; or the pitch of a note, you have to delete it and add a new note
 120 ;;; with the right characteristics.
 121
 122 ;;; Return the pitch of the note.
 123 (defgeneric pitch (note))
 124
 125 ;;; Return the accidentals of the note.  The value returned is one of
 126 ;;; :natural :flat :double-flat :sharp or :double-sharp.
 127 (defgeneric accidentals (note))
 128
 129 ;;; Return a non-negative integer indicating the number of dots of the
 130 ;;; note.  The value nil is returned whenever the note takes its
 131 ;;; number of dots from the cluster to which it belongs.
 132 (defgeneric dots (note))
 133
 134 ;;; Returns the cluster to which the note belongs, or nil if the note
 135 ;;; currently does not belong to any cluster.
 136 (defgeneric cluster (note))
 137
 138 ;;; The pitch is a number from 0 to 128
 139 ;;;
 140 ;;; The staff is a staff object.
 141 ;;;
 142 ;;; Head can be :long, :breve, :whole, :half, :filled, or nil.  A
 143 ;;; value of nil means that the notehead is determined by that of the
 144 ;;; cluster to which the note belongs.
 145 ;;;
 146 ;;; Accidentals can be :natural :flat :double-flat :sharp or :double-sharp.
 147 ;;; The default is :natural.  Whether a note is actually displayed
 148 ;;; preceded by one of the corresponding signs is a matter of context and
 149 ;;; display style.
 150 ;;;
 151 ;;; The number of dots can be an integer or nil, meaning that the number
 152 ;;; of dots is taken from the cluster.  The default value is nil.
 153 ;;;
 154 ;;; The actual duration of the note is computed from the note head, the
 155 ;;; number of beams of the cluster to which the note belongs, and the
 156 ;;; number of dots in the usual way.
 157
 158 (defclass note (gsharp-object)
 159   ((cluster :initform nil :initarg :cluster :accessor cluster)
 160    (pitch :initarg :pitch :reader pitch :type (integer 0 127))
 161    (staff :initarg :staff :reader staff :type staff)
 162    (head :initform nil :initarg :head :reader head
 163          :type (or (member :long :breve :whole :half :filled) null))
 164    (accidentals :initform :natural :initarg :accidentals :reader accidentals
 165                 ;; FIXME: we want :TYPE ACCIDENTAL here but need to
 166                 ;; sort out order of definition for that to be useful.
 167                 #+nil #+nil
 168                 :type (member :natural :flat :double-flat :sharp :double-sharp))
 169    (dots :initform nil :initarg :dots :reader dots
 170          :type (or (integer 0 3) null))
 171    (%tie-right :initform nil :initarg :tie-right :accessor tie-right)
 172    (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))
 173
 174 (defun make-note (pitch staff &rest args &key head (accidentals :natural) dots)
 175   (declare (type (integer 0 127) pitch)
 176            (type staff staff)
 177            (type (or (member :long :breve :whole :half :filled) null) head)
 178            ;; FIXME: :TYPE ACCIDENTAL
 179            #+nil #+nil
 180            (type (member :natural :flat :double-flat :sharp :double-sharp)
 181                  accidentals)
 182            (type (or (integer 0 3) null) dots)
 183            (ignore head accidentals dots))
 184   (apply #'make-instance 'note :pitch pitch :staff staff args))
 185
 186 (defmethod slots-to-be-saved append ((n note))
 187   '(pitch staff head accidentals dots %tie-right %tie-left))
 188
 189 (defun read-note-v3 (stream char n)
 190   (declare (ignore char n))
 191   (apply #'make-instance 'note (read-delimited-list #\] stream t)))
 192
 193 (set-dispatch-macro-character #\[ #\N
 194   #'read-note-v3
 195   *gsharp-readtable-v3*)
 196
 197 ;;; Return true if note1 is considered less than note2.
 198 (defun note-less (note1 note2)
 199   (< (pitch note1) (pitch note2)))
 200
 201 ;;; Return true if note1 is considered equal to note2.
 202 (defun note-equal (note1 note2)
 203   (= (pitch note1) (pitch note2)))
 204
 205
 206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 207 ;;;
 208 ;;; Tuning (support for microtonal and historical tunings/temperaments)
 209
 210 ;;; FIXME: add name-mixin also?
 211 (defclass tuning (gsharp-object)
 212   ((master-pitch-note :initform (make-instance 'note :pitch 33 ; a above middle c
 213                                                      :staff (make-instance 'staff))
 214                       :initarg :master-pitch-note
 215                       :type note
 216                       :accessor master-pitch-note)
 217    (master-pitch-freq :initform 440
 218                       :initarg :master-pitch-freq
 219                       :accessor master-pitch-freq)))
 220
 221 (defmethod slots-to-be-saved append ((tuning tuning))
 222   '(master-pitch-note master-pitch-freq))
 223
 224 ;;; Returns how a note should be tuned in a given tuning
 225 ;;; in terms of a cent value.
 226 (defgeneric note-cents (note tuning))
 227
 228 ;;; 12-edo is provided for efficiency only. It is a
 229 ;;; special case of a regular temperament. Perhaps it
 230 ;;; should be removed?
 231 (defclass 12-edo (tuning)
 232   ())
 233
 234 (defmethod slots-to-be-saved append ((tuning 12-edo))
 235   '())
 236
 237 (defmethod note-cents ((note note) (tuning 12-edo))
 238   (multiple-value-bind (octave pitch) (floor (pitch note) 7)
 239     (+ (* 1200 (1+ octave))
 240        (ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100))
 241        (ecase (accidentals note)
 242          (:double-flat -200)
 243          (:sesquiflat -150)
 244          (:flat -100)
 245          (:semiflat -50)
 246          (:natural 0)
 247          (:semisharp 50)
 248          (:sharp 100)
 249          (:sesquisharp 150)
 250          (:double-sharp 200)))))
 251
 252 ;;; regular temperaments are temperaments that
 253 ;;; retain their interval sizes regardless of modulation, as opposed to
 254 ;;; irregular temperaments.
 255 (defclass regular-temperament (tuning)
 256   ((octave-cents :initform 1200 :initarg :octave-cents :accessor octave-cents)
 257    (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents)
 258    (quartertone-cents :initform 50 :initarg :quartertone-cents :accessor quartertone-cents)
 259    ;; TODO: Add cent sizes of various microtonal accidentals, perhaps in an alist?
 260    ))
 261
 262 (defmethod slots-to-be-saved append ((tuning regular-temperament))
 263   '(octave-cents fifth-cents))
 264
 265 (defmethod note-cents ((note note) (tuning regular-temperament))
 266   (let ((octaves 1)
 267         (fifths 0)
 268         (sharps 0) ;; short for 7 fifths up and 4 octaves down
 269         (quartertones 0))
 270     (incf octaves (floor (pitch note) 7))
 271     (ecase (mod (pitch note) 7)
 272       (0 (progn))
 273       (1 (progn (incf octaves -1) (incf fifths 2)))
 274       (2 (progn (incf octaves -2) (incf fifths 4)))
 275       (3 (progn (incf octaves 1) (incf fifths -1)))
 276       (4 (progn (incf fifths 1)))
 277       (5 (progn (incf octaves -1) (incf fifths 3)))
 278       (6 (progn (incf octaves -2) (incf fifths 5))))
 279     (ecase (accidentals note)
 280       (:double-flat (incf sharps -2))
 281       (:sesquiflat (incf sharps -1) (incf quartertones -1))
 282       (:flat (incf sharps -1))
 283       (:semiflat (incf quartertones -1))
 284       (:natural)
 285       (:semisharp (incf quartertones 1))
 286       (:sharp (incf sharps 1))
 287       (:sesquisharp (incf sharps 1) (incf quartertones 1))
 288       (:double-sharp (incf sharps 2)))
 289     (incf octaves (* -4 sharps))
 290     (incf fifths (* 7 sharps))
 291     (+ (* octaves (octave-cents tuning))
 292        (* fifths (fifth-cents tuning))
 293        (* quartertones (quartertone-cents tuning)))))
 294
 295 ;;; TODO: (defclass irregular-temperament ...)
 296
 297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 298 ;;;
 299 ;;; Melody element
 300
 301 (defclass melody-element (rhythmic-element) ())
 302
 303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 304 ;;;
 305 ;;; Key signature
 306
 307 (defgeneric alterations (key-signature)
 308   (:documentation "return the alterations in the form of a
 309 7-element array where each element is either :natural,
 310 :sharp, or :flat according to how each staff position
 311 should be altered"))
 312
 313 (defgeneric more-sharps (key-signature &optional n)
 314   (:documentation "make the key signature N alterations
 315 sharper by removing some flats and/or adding some sharps"))
 316
 317 (defgeneric more-flats (key-signature &optional n)
 318   (:documentation "make the key signature N alterations
 319 flatter by removing some sharps and/or adding some flats"))
 320
 321 (defclass staffwise-element (element)
 322   ((%staff :initarg :staff :reader staff)))
 323 (defmethod slots-to-be-saved append ((s-e staffwise-element))
 324   '(%staff))
 325
 326 (defclass key-signature (staffwise-element)
 327   ((%alterations :initform (make-array 7 :initial-element :natural)
 328                  :initarg :alterations :reader alterations)))
 329
 330 (defun make-key-signature (staff &rest args &key alterations)
 331   (declare (type (or null (simple-vector 7)) alterations)
 332            (ignore alterations))
 333   (apply #'make-instance 'key-signature :staff staff args))
 334
 335 (defmethod slots-to-be-saved append ((k key-signature))
 336   '(%alterations))
 337
 338 (defmethod more-sharps ((sig key-signature) &optional (n 1))
 339   (let ((alt (alterations sig)))
 340     (loop repeat n
 341           do (cond ((eq (aref alt 3) :flat) (setf (aref alt 3) :natural))
 342                    ((eq (aref alt 0) :flat) (setf (aref alt 0) :natural))
 343                    ((eq (aref alt 4) :flat) (setf (aref alt 4) :natural))
 344                    ((eq (aref alt 1) :flat) (setf (aref alt 1) :natural))
 345                    ((eq (aref alt 5) :flat) (setf (aref alt 5) :natural))
 346                    ((eq (aref alt 2) :flat) (setf (aref alt 2) :natural))
 347                    ((eq (aref alt 6) :flat) (setf (aref alt 6) :natural))
 348                    ((eq (aref alt 3) :natural) (setf (aref alt 3) :sharp))
 349                    ((eq (aref alt 0) :natural) (setf (aref alt 0) :sharp))
 350                    ((eq (aref alt 4) :natural) (setf (aref alt 4) :sharp))
 351                    ((eq (aref alt 1) :natural) (setf (aref alt 1) :sharp))
 352                    ((eq (aref alt 5) :natural) (setf (aref alt 5) :sharp))
 353                    ((eq (aref alt 2) :natural) (setf (aref alt 2) :sharp))
 354                    ((eq (aref alt 6) :natural) (setf (aref alt 6) :sharp))))))
 355
 356 (defmethod more-flats ((sig key-signature) &optional (n 1))
 357   (let ((alt (alterations sig)))
 358     (loop repeat n
 359           do (cond ((eq (aref alt 6) :sharp) (setf (aref alt 6) :natural))
 360                    ((eq (aref alt 2) :sharp) (setf (aref alt 2) :natural))
 361                    ((eq (aref alt 5) :sharp) (setf (aref alt 5) :natural))
 362                    ((eq (aref alt 1) :sharp) (setf (aref alt 1) :natural))
 363                    ((eq (aref alt 4) :sharp) (setf (aref alt 4) :natural))
 364                    ((eq (aref alt 0) :sharp) (setf (aref alt 0) :natural))
 365                    ((eq (aref alt 3) :sharp) (setf (aref alt 3) :natural))
 366                    ((eq (aref alt 6) :natural) (setf (aref alt 6) :flat))
 367                    ((eq (aref alt 2) :natural) (setf (aref alt 2) :flat))
 368                    ((eq (aref alt 5) :natural) (setf (aref alt 5) :flat))
 369                    ((eq (aref alt 1) :natural) (setf (aref alt 1) :flat))
 370                    ((eq (aref alt 4) :natural) (setf (aref alt 4) :flat))
 371                    ((eq (aref alt 0) :natural) (setf (aref alt 0) :flat))
 372                    ((eq (aref alt 3) :natural) (setf (aref alt 3) :flat))))))
 373
 374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 375 ;;;
 376 ;;; Time signature
 377 ;; * no make function (no type checking)
 378 ;; * slots-to-be-saved only 'cos it's there
 379 ;; * What accessors do we need (if any)?
 380 ;; * Should I copy the (keysig) functionality from gui.lisp?
 381
 382 (defclass time-signature (staffwise-element)
 383   ((%components :initarg :components :reader time-signature-components
 384                 :initform nil)))
 385 (defmethod slots-to-be-saved append ((t-s time-signature))
 386   '(%components))
 387 (defun make-time-signature (staff &rest args)
 388   (apply #'make-instance 'time-signature :staff staff args))
 389
 390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 391 ;;;
 392 ;;; Cluster
 393
 394 ;;; Return a list of the notes of the cluster
 395 (defgeneric notes (cluster))
 396
 397 ;;; Add a note to the cluster.  It is an error if there is already a
 398 ;;; note in the cluster with the same staff and the same pitch.
 399 (defgeneric add-note (cluster note))
 400
 401 ;;; Find a note in a cluster.  The comparison is made using only the
 402 ;;; pitch of the supplied note.  If the note does not exist nil is returned.
 403 (defgeneric find-note (cluster note))
 404
 405 ;;; Delete a note from the cluster to which it belongs.  It is an
 406 ;;; error to call this function if the note currently does not belong
 407 ;;; to any cluster.
 408 (defgeneric remove-note (note))
 409
 410 (defclass cluster (melody-element)
 411   ((notes :initform '() :initarg :notes :accessor notes)
 412    (stem-direction :initform :auto :initarg :stem-direction :accessor stem-direction)))
 413
 414 (defmethod initialize-instance :after ((c cluster) &rest args)
 415   (declare (ignore args))
 416   (loop for note in (notes c)
 417         do (setf (cluster note) c)))
 418
 419 (defun make-cluster (&rest args
 420                      &key (notehead :filled) (lbeams 0) (rbeams 0) (dots 0)
 421                      (xoffset 0) notes (stem-direction :auto))
 422   (declare (type (member :long :breve :whole :half :filled) notehead)
 423            (type (integer 0 5) lbeams)
 424            (type (integer 0 5) rbeams)
 425            (type (integer 0 3) dots)
 426            (type number xoffset)
 427            (type list notes)
 428            (type (member :up :down :auto) stem-direction)
 429            (ignore notehead lbeams rbeams dots xoffset notes stem-direction))
 430   (apply #'make-instance 'cluster args))
 431
 432 (defmethod slots-to-be-saved append ((c cluster))
 433   '(stem-direction notes))
 434
 435 (defun read-cluster-v3 (stream char n)
 436   (declare (ignore char n))
 437   (apply #'make-instance 'cluster (read-delimited-list #\] stream t)))
 438
 439 (set-dispatch-macro-character #\[ #\%
 440   #'read-cluster-v3
 441   *gsharp-readtable-v3*)
 442
 443 (define-condition note-already-in-cluster (gsharp-condition) ()
 444   (:report
 445    (lambda (condition stream)
 446      (declare (ignore condition))
 447      (format stream "Attempt to add a note already in a cluster"))))
 448
 449 (defmethod add-note ((cluster cluster) (note note))
 450   (with-slots (notes) cluster
 451     (assert (not (find note notes :test #'note-equal))
 452             ()
 453             'note-already-in-cluster)
 454     (setf notes (merge 'list notes (list note) #'note-less)
 455           (cluster note) cluster)))
 456
 457 (defmethod find-note ((cluster cluster) (note note))
 458   (with-slots (notes) cluster
 459     (car (member (pitch note) notes :key #'pitch))))
 460
 461 (define-condition note-not-in-cluster (gsharp-condition) ()
 462   (:report
 463    (lambda (condition stream)
 464      (declare (ignore condition))
 465      (format stream "Attempt to delete a note not in a cluster"))))
 466
 467 (defmethod remove-note ((note note))
 468   (with-slots (cluster) note
 469     (assert cluster () 'note-not-in-cluster)
 470     (with-slots (notes) cluster
 471       (setf notes (delete note notes :test #'eq)))
 472     (setf cluster nil)))
 473
 474 (defun lower-bound (bound list &key (test #'<))
 475   "Return the `largest' element in the sorted list LIST such that
 476 \(TEST element BOUND) is true."
 477   (let ((last nil))
 478     (dolist (item list)
 479       (unless (funcall test item bound)
 480         (return-from lower-bound last))
 481       (setf last item))
 482     last))
 483
 484 (defmethod cluster-lower-bound ((cluster cluster) (bound note))
 485   (with-slots (notes) cluster
 486     (lower-bound bound notes :test #'note-less)))
 487
 488 (defmethod cluster-upper-bound ((cluster cluster) (bound note))
 489   (with-slots (notes) cluster
 490     (lower-bound bound (reverse notes) :test (complement #'note-less))))
 491
 492 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 493 ;;;
 494 ;;; Rest
 495
 496 (defclass rest (melody-element)
 497   ((staff :initarg :staff :reader staff)
 498    (staff-pos :initarg :staff-pos :initform 4 :reader staff-pos)))
 499
 500 (defun make-rest (staff &rest args
 501                   &key (staff-pos 4) (notehead :filled) (lbeams 0) (rbeams 0)
 502                   (dots 0) (xoffset 0))
 503   (declare (type staff staff)
 504            (type integer staff-pos)
 505            (type (member :long :breve :whole :half :filled) notehead)
 506            (type (integer 0 5) lbeams)
 507            (type (integer 0 5) rbeams)
 508            (type (integer 0 3) dots)
 509            (type number xoffset)
 510            (ignore staff-pos notehead lbeams rbeams dots xoffset))
 511   (apply #'make-instance 'rest
 512          :staff staff args))
 513
 514 (defmethod slots-to-be-saved append ((s rest))
 515   '(staff staff-pos))
 516
 517 (defun read-rest-v3 (stream char n)
 518   (declare (ignore char n))
 519   (apply #'make-instance 'rest (read-delimited-list #\] stream t)))
 520
 521 (set-dispatch-macro-character #\[ #\-
 522   #'read-rest-v3
 523   *gsharp-readtable-v3*)
 524
 525 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 526 ;;;
 527 ;;; Melody bar
 528
 529 (defclass melody-bar (bar) ())
 530
 531 (defun make-melody-bar (&rest args &key elements)
 532   (declare (type list elements)
 533            (ignore elements))
 534   (apply #'make-instance 'melody-bar args))
 535
 536 (defmethod make-bar-for-staff ((staff fiveline-staff) &rest args &key elements)
 537   (declare (ignore elements))
 538   (apply #'make-instance 'melody-bar args))
 539
 540 (defun read-melody-bar-v3 (stream char n)
 541   (declare (ignore char n))
 542   (apply #'make-instance 'melody-bar (read-delimited-list #\] stream t)))
 543
 544 (set-dispatch-macro-character #\[ #\|
 545   #'read-melody-bar-v3
 546   *gsharp-readtable-v3*)
 547
 548 (defmethod remove-bar ((bar melody-bar))
 549   (with-slots (slice) bar
 550     (assert slice () 'bar-not-in-slice)
 551     (with-slots (bars) slice
 552       (setf bars (delete bar bars :test #'eq))
 553       (unless bars
 554         ;; make sure there is one bar left
 555         (add-bar (make-melody-bar) slice 0)))
 556     (setf slice nil)))
 557
 558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 559 ;;;
 560 ;;; Melody layer
 561
 562 (defclass melody-layer (layer) ())
 563
 564 (defun read-melody-layer-v3 (stream char n)
 565   (declare (ignore char n))
 566   (apply #'make-instance 'melody-layer (read-delimited-list #\] stream t)))
 567
 568 (set-dispatch-macro-character #\[ #\_
 569   #'read-melody-layer-v3
 570   *gsharp-readtable-v3*)
 571
 572 (defmethod make-layer-for-staff ((staff fiveline-staff) &rest args &key staves head body tail &allow-other-keys)
 573   (declare (ignore staves head body tail))
 574   (apply #'make-instance 'melody-layer args))
 575
 576 (defgeneric clefs (staff)
 577   (:method ((s t)) nil)
 578   (:method ((s fiveline-staff))
 579     (remove-if #'(lambda (x) (not (typep x 'clef)))
 580                (staffwise-elements s))))