buffer.lisp

   1 (in-package :gsharp-buffer)
   2
   3 (defparameter *gsharp-readtable-v3* (copy-readtable))
   4 (defparameter *gsharp-readtable-v4* (copy-readtable))
   5
   6 (defun read-gsharp-object-v4 (stream char)
   7   (declare (ignore char))
   8   (apply #'make-instance (read-delimited-list #\] stream t)))
   9
  10 (make-dispatch-macro-character #\[ nil *gsharp-readtable-v3*)
  11 (set-macro-character #\[ #'read-gsharp-object-v4 nil *gsharp-readtable-v4*)
  12 (set-syntax-from-char #\] #\) *gsharp-readtable-v3*)
  13 (set-syntax-from-char #\] #\) *gsharp-readtable-v4*)
  14
  15 (defgeneric slots-to-be-saved (object)
  16   (:method-combination append :most-specific-last))
  17
  18 (defun save-object (object stream)
  19   (pprint-logical-block (stream nil :prefix "[" :suffix "]")
  20     (format stream "~s ~2i" (class-name (class-of object)))
  21     (loop for slot-name in (slots-to-be-saved object)
  22           do (let ((slot (find slot-name (clim-mop:class-slots (class-of object))
  23                                :key #'clim-mop:slot-definition-name
  24                                :test #'eq)))
  25                (format stream "~_~W ~W "
  26                        (car (clim-mop:slot-definition-initargs slot))
  27                        (slot-value object (clim-mop:slot-definition-name slot)))))))
  28
  29 (defclass gsharp-object () ())
  30
  31 (defmethod print-object ((obj gsharp-object) stream)
  32   (if *print-circle*
  33       (save-object obj stream)
  34       (print-unreadable-object (obj stream :type t :identity t))))
  35
  36 (define-condition gsharp-condition (error) ())
  37
  38 (defgeneric name (obj))
  39
  40 (defclass name-mixin ()
  41   ((name :initarg :name :accessor name)))
  42
  43 (defmethod slots-to-be-saved append ((obj name-mixin))
  44   '(name))
  45
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47 ;;;
  48 ;;; Staff
  49
  50 (defclass staff (gsharp-object name-mixin)
  51   ((buffer :initarg :buffer :accessor buffer))
  52   (:default-initargs :name "default staff"))
  53
  54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55 ;;;
  56 ;;; Element
  57
  58 ;;; Return the bar to which the element belongs, or nil of the element
  59 ;;; currently does not belong to any bar.
  60 (defgeneric bar (element))
  61
  62 (defclass element (gsharp-object)
  63   ((bar :initform nil :initarg :bar :accessor bar)
  64    (xoffset :initform 0 :initarg :xoffset :accessor xoffset)
  65    (annotations :initform nil :initarg :annotations :accessor annotations)))
  66
  67 (defmethod slots-to-be-saved append ((e element))
  68   '(xoffset annotations))
  69
  70 (defmethod duration ((element element)) 0)
  71 (defmethod rbeams ((element element)) 0)
  72 (defmethod lbeams ((element element)) 0)
  73
  74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75 ;;;
  76 ;;; Rhythmic element
  77
  78 ;;; Return the notehead of the element.  With setf, set the notehead
  79 ;;; of the element.
  80 (defgeneric notehead (rhythmic-element))
  81 (defgeneric (setf notehead) (notehead rhythmic-element))
  82
  83 ;;; Return the number of right beams of the element.  With setf, set
  84 ;;; the number of right beams of the element.
  85 (defgeneric rbeams (rhythmic-element))
  86 (defgeneric (setf rbeams) (rbeams rhythmic-element))
  87
  88 ;;; Return the number of left beams of the element.  With setf, set
  89 ;;; the number of left beams of the element.
  90 (defgeneric lbeams (rhythmic-element))
  91 (defgeneric (setf lbeams) (lbeams rhythmic-element))
  92
  93 ;;; Return the number of dots of the element.  With setf, set the
  94 ;;; number of dots of the element.
  95 (defgeneric dots (rhythmic-element))
  96 (defgeneric (setf dots) (dots rhythmic-element))
  97
  98 (defclass rhythmic-element (element)
  99   ((notehead :initform :whole :initarg :notehead :accessor notehead)
 100    (rbeams :initform 0 :initarg :rbeams :accessor rbeams)
 101    (lbeams :initform 0 :initarg :lbeams :accessor lbeams)
 102    (dots :initform 0 :initarg :dots :accessor dots)))
 103
 104 (defmethod slots-to-be-saved append ((e rhythmic-element))
 105   '(notehead rbeams lbeams dots))
 106
 107 (defmethod undotted-duration ((element rhythmic-element))
 108   (ecase (notehead element)
 109     (:long 4)
 110     (:breve 2)
 111     (:whole 1)
 112     (:half 1/2)
 113     (:filled (/ (expt 2 (+ 2 (max (rbeams element)
 114                                   (lbeams element))))))))
 115
 116 (defmethod duration ((element rhythmic-element))
 117   (let ((duration (undotted-duration element)))
 118     (do ((dot-duration (/ duration 2) (/ dot-duration 2))
 119          (nb-dots (dots element) (1- nb-dots)))
 120         ((zerop nb-dots))
 121       (incf duration dot-duration))
 122     duration))
 123
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 ;;;
 126 ;;; Bar
 127
 128 ;;; It is recommended that the concept of a bar be hidden from the
 129 ;;; user, and that a measure bar, or a repeat sign be considered by
 130 ;;; the end-user as members of slices the way clusters are.
 131
 132 ;;; Return the slice to which the bar belongs, or nil if the bar
 133 ;;; currently does not belong to any slice.
 134 (defgeneric slice (bar))
 135
 136 ;;; Return the elements of the bar.
 137 (defgeneric elements (bar))
 138
 139 ;;; Return the number of elements of the bar.
 140 (defgeneric nb-elements (bar))
 141
 142 ;;; Return the element at the position of the bar.
 143 (defgeneric elementno (bar position))
 144
 145 ;;; Add an element to the bar at the position indicated
 146 (defgeneric add-element (element bar position))
 147
 148 ;;; Delete an element from the bar to which it belongs.
 149 (defgeneric remove-element (element bar))
 150
 151 (defclass bar (gsharp-object)
 152   ((slice :initform nil :initarg :slice :accessor slice)
 153    (elements :initform '() :initarg :elements :accessor elements)))
 154
 155 (defmethod initialize-instance :after ((b bar) &rest args)
 156   (declare (ignore args))
 157   (loop for element in (elements b)
 158         do (setf (bar element) b)))
 159
 160 (defmethod slots-to-be-saved append ((b bar))
 161   '(elements))
 162
 163 ;;; The duration of a bar is simply the sum of durations
 164 ;;; of its elements.  We might want to improve on the
 165 ;;; implementation of this method so that it uses some
 166 ;;; kind of cache, in order to avoid looping over each
 167 ;;; element and computing the duration of each one each time.
 168 (defmethod duration ((bar bar))
 169   (reduce #'+ (elements bar) :key #'duration))
 170
 171 (defgeneric make-bar-for-staff (staff &rest args &key elements))
 172
 173 (defmethod nb-elements ((bar bar))
 174   (length (elements bar)))
 175
 176 (defmethod elementno ((bar bar) position)
 177   (with-slots (elements) bar
 178     (elt elements position)))
 179
 180 (define-condition element-already-in-bar (gsharp-condition) ()
 181   (:report
 182    (lambda (condition stream)
 183      (declare (ignore condition))
 184      (format stream "Attempt to add an element already in a bar"))))
 185
 186 (defmethod add-element ((element element) (b bar) position)
 187   (with-slots (bar) element
 188     (assert (not bar) () 'element-already-in-bar)
 189     (with-slots (elements) b
 190       (setf elements (ninsert-element element elements position)))
 191     (setf bar b)))
 192
 193 ;;; fix this and move it to melody.lisp
 194 (defun maybe-update-key-signatures (bar)
 195   (let* ((layer (layer (slice bar)))
 196          (staves (staves layer)))
 197     (dolist (staff staves)
 198       ;; FIXME: this isn't the Right Thing: instead we should be using
 199       ;; something like maybe-update-key-signatures-using-staff.
 200       (when (typep staff 'fiveline-staff)
 201         (let ((key-signatures (key-signatures staff)))
 202           (when (and key-signatures
 203                      (find (gsharp-numbering:number bar) key-signatures
 204                            :key (lambda (x) (gsharp-numbering:number (bar x)))))
 205             ;; we actually only need to invalidate everything in the
 206             ;; current bar using the staff, not the entire staff, but...
 207             (gsharp-measure::invalidate-everything-using-staff (buffer staff) staff)
 208             ;; there might be more than one key signature in the bar,
 209             ;; and they might have changed their relative order as a
 210             ;; result of the edit.
 211             (setf (staffwise-elements staff)
 212                   (sort (staffwise-elements staff)
 213                         (lambda (x y) (gsharp::starts-before-p x (bar y) y))))))))))
 214
 215 (defmethod add-element :after ((element element) (bar bar) position)
 216   (maybe-update-key-signatures bar))
 217
 218 (define-condition element-not-in-bar (gsharp-condition) ()
 219   (:report
 220    (lambda (condition stream)
 221      (declare (ignore condition))
 222      (format stream "Attempt to delete an element not in a bar"))))
 223
 224 (defmethod remove-element ((element element) (b bar))
 225   (with-slots (bar) element
 226     (assert (and bar (eq b bar)) () 'element-not-in-bar)
 227     (with-slots (elements) bar
 228       (setf elements (delete element elements :test #'eq)))
 229     (setf bar nil)))
 230
 231 (defmethod remove-element :before ((element element) (bar bar))
 232   (maybe-update-key-signatures bar))
 233
 234 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 235 ;;;
 236 ;;; Slice
 237
 238 ;;; Return the layer of the slice
 239 (defgeneric layer (slice))
 240
 241 ;;; Return the bars of the slisce
 242 (defgeneric bars (slice))
 243
 244 ;;; Return the number of bars of the slice
 245 (defgeneric nb-bars (slice))
 246
 247 ;;; Return the bar at the position
 248 (defgeneric barno (slice position))
 249
 250 ;;; Add a bar to the slice at the position indicates
 251 (defgeneric add-bar (bar slice position))
 252
 253 ;;; Delete a bar from the slice to which it belongs.
 254 (defgeneric remove-bar (bar))
 255
 256 (defclass slice (gsharp-object)
 257   ((layer :initform nil :initarg :layer :accessor layer)
 258    (bars :initform '() :initarg :bars :accessor bars)))
 259
 260 (defmethod initialize-instance :after ((s slice) &rest args)
 261   (declare (ignore args))
 262   (loop for bar in (bars s)
 263         do (setf (slice bar) s)))
 264
 265 (defun make-slice (&rest args &key bars)
 266   (declare (type list bars)
 267            (ignore bars))
 268   (apply #'make-instance 'slice args))
 269
 270 (defmethod slots-to-be-saved append ((s slice))
 271   '(bars))
 272
 273 (defun read-slice-v3 (stream char n)
 274   (declare (ignore char n))
 275   (apply #'make-instance 'slice (read-delimited-list #\] stream t)))
 276
 277 (set-dispatch-macro-character #\[ #\/
 278   #'read-slice-v3
 279   *gsharp-readtable-v3*)
 280
 281 (defmethod nb-bars ((slice slice))
 282   (length (bars slice)))
 283
 284 (defmethod barno ((slice slice) position)
 285   (elt (bars slice) position))
 286
 287 (define-condition bar-already-in-slice (gsharp-condition) ()
 288   (:report
 289    (lambda (condition stream)
 290      (declare (ignore condition))
 291      (format stream "Attempt to add a bar already in a slice"))))
 292
 293 (defmethod add-bar ((bar bar) (s slice) position)
 294   (with-slots (slice) bar
 295     (assert (not slice) () 'bar-already-in-slice)
 296     (with-slots (bars) s
 297       (setf bars (ninsert-element bar bars position)))
 298     (setf slice s)))
 299
 300 (define-condition bar-not-in-slice (gsharp-condition) ()
 301   (:report
 302    (lambda (condition stream)
 303      (declare (ignore condition))
 304      (format stream "Attempt to delete a bar not in a slice"))))
 305
 306 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 307 ;;;
 308 ;;; Layer
 309
 310 ;;; Return the segment to which the layer belongs.
 311 (defgeneric segment (layer))
 312
 313 ;;; Return a list of the (exactly three) slices of the layer.  This
 314 ;;; function may or may not return an object that reflects some
 315 ;;; internal structure of Gsharp.  Don't modify this object.  On the
 316 ;;; other hand, this function may also require some unnecessary
 317 ;;; consing.  For that reason, use the function slice whenever
 318 ;;; possible.
 319 (defgeneric slices (layer))
 320
 321 ;;; Return a slice of a layer.  The position argument is a
 322 ;;; non-negative integer which must be greater than or equal to zero
 323 ;;; and strictly less than three.
 324 (defgeneric sliceno (layer position))
 325
 326 ;;; Return the head slice of the layer
 327 (defgeneric head (layer))
 328
 329 ;;; Return the body slice of the layer
 330 (defgeneric body (layer))
 331
 332 ;;; Return the tail slice of the layer
 333 (defgeneric tail (layer))
 334
 335 (defclass layer (gsharp-object name-mixin)
 336   ((segment :initform nil :initarg :segment :accessor segment)
 337    (staves :initarg :staves :accessor staves)
 338    (head :initarg :head :accessor head)
 339    (body :initarg :body :accessor body)
 340    (tail :initarg :tail :accessor tail))
 341   (:default-initargs :name "default layer"))
 342
 343 (defmethod initialize-instance :after ((l layer) &rest args &key head body tail)
 344   (declare (ignore args))
 345   (let ((staff (car (staves l))))
 346     (unless head
 347       (setf (head l) (make-slice :bars (list (make-bar-for-staff staff)))))
 348     (unless body
 349       (setf (body l) (make-slice :bars (list (make-bar-for-staff staff)))))
 350     (unless tail
 351       (setf (tail l) (make-slice :bars (list (make-bar-for-staff staff))))))
 352   (setf (layer (head l)) l
 353         (layer (body l)) l
 354         (layer (tail l)) l))
 355
 356 (defmethod slots-to-be-saved append ((l layer))
 357   '(staves head body tail))
 358
 359 (defgeneric make-layer-for-staff (staff &rest args &key staves head body tail &allow-other-keys))
 360
 361 (defun make-layer (staves &rest args &key head body tail &allow-other-keys)
 362   (declare (type list staves)
 363            (type (or slice null) head body tail)
 364            (ignore head body tail))
 365   (apply #'make-layer-for-staff (car staves) :staves staves args))
 366
 367 (defmethod slices ((layer layer))
 368   (with-slots (head body tail) layer
 369     (list head body tail)))
 370
 371 (defmethod sliceno ((layer layer) position)
 372   (ecase position
 373     (0 (head layer))
 374     (1 (body layer))
 375     (2 (tail layer))))
 376
 377 (define-condition staff-already-in-layer (gsharp-condition) ()
 378   (:report
 379    (lambda (condition stream)
 380      (declare (ignore condition))
 381      (format stream "That staff is already in the layer"))))
 382
 383 (define-condition staff-not-in-layer (gsharp-condition) ()
 384   (:report
 385    (lambda (condition stream)
 386      (declare (ignore condition))
 387      (format stream "That staff is not in the layer"))))
 388
 389 (define-condition only-staff-in-layer (gsharp-condition) ()
 390   (:report
 391    (lambda (condition stream)
 392      (declare (ignore condition))
 393      (format stream "Only staff in the layer"))))
 394
 395 (defmethod add-staff-to-layer ((staff staff) (layer layer))
 396   (assert (not (member staff (staves layer) :test #'eq))
 397           () 'staff-already-in-layer)
 398   (push staff (staves layer)))
 399
 400 (defmethod remove-staff-from-layer ((staff staff) (layer layer))
 401   (assert (not (null (staves layer)))
 402           () 'only-staff-in-layer)
 403   (assert (member staff (staves layer) :test #'eq)
 404           () 'staff-not-in-layer)
 405   (setf (staves layer)
 406         (delete staff (staves layer) :test #'eq)))
 407
 408 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 409 ;;;
 410 ;;; Segment
 411
 412 ;;; Return the buffer to which the segment belongs, or nil if the
 413 ;;; segment is currently not inserted in any buffer.
 414 (defgeneric buffer (segment))
 415
 416 ;;; Return a list of the layers of the segment.  This function may or
 417 ;;; may not return an object that reflects some internal structure of
 418 ;;; Gsharp.  Don't modify this object.  On the other hand, this
 419 ;;; function may also require some unnecessary consing.  For that
 420 ;;; reason, use the function segment-layer whenever possible.
 421 (defgeneric layers (segment))
 422
 423 ;;; Return the number of layers in the segment
 424 (defgeneric nb-layers (segment))
 425
 426 ;;; Return a layer of the segment.  The position argument is a
 427 ;;; non-negative integer which must be greater than or equal to zero
 428 ;;; and strictly less than the number of layers of the segment.
 429 (defgeneric layerno (segment position))
 430
 431 ;;; Add a layer to a segment.
 432 (defgeneric add-layer (layer segment))
 433
 434 ;;; Delete a layer from the segment to which it belongs
 435 (defgeneric remove-layer (layer))
 436
 437 (defclass segment (gsharp-object)
 438   ((buffer :initform nil :initarg :buffer :accessor buffer)
 439    (layers :initform '() :initarg :layers :accessor layers)
 440    (tempo :initform 128 :initarg :tempo :accessor tempo)
 441    (tuning :initform (make-instance '12-edo)
 442            :initarg :tuning :accessor tuning)))
 443
 444 (defmethod initialize-instance :after ((s segment) &rest args &key staff)
 445   (declare (ignore args))
 446   (with-slots (layers) s
 447     (when (null layers)
 448       (assert (not (null staff)))
 449       (push (make-layer (list staff)) layers))
 450     (loop for layer in layers
 451           do (setf (segment layer) s))))
 452
 453 (defmethod slots-to-be-saved append ((s segment))
 454   '(layers tempo tuning))
 455
 456 (defun read-segment-v3 (stream char n)
 457   (declare (ignore char n))
 458   (apply #'make-instance 'segment (read-delimited-list #\] stream t)))
 459
 460 (set-dispatch-macro-character #\[ #\S
 461   #'read-segment-v3
 462   *gsharp-readtable-v3*)
 463
 464 (defmethod nb-layers ((segment segment))
 465   (length (layers segment)))
 466
 467 (defmethod layerno ((segment segment) position)
 468   (elt (layers segment) position))
 469
 470 (define-condition layer-already-in-a-segment (gsharp-condition) ()
 471   (:report
 472    (lambda (condition stream)
 473      (declare (ignore condition))
 474      (format stream "Attempt to add a layer already in a segment"))))
 475
 476 (defmethod add-layer ((layer layer) (seg segment))
 477   (with-slots (segment) layer
 478     (assert (not segment) () 'layer-already-in-a-segment)
 479     (with-slots (layers) seg
 480        (push layer layers))
 481     (setf segment seg)))
 482
 483 (define-condition layer-not-in-segment (gsharp-condition) ()
 484   (:report
 485    (lambda (condition stream)
 486      (declare (ignore condition))
 487      (format stream "Attempt to delete a layer which is not in a segment"))))
 488
 489 (defmethod remove-layer ((layer layer))
 490   (with-slots (segment) layer
 491     (assert segment () 'layer-not-in-segment)
 492     (with-slots (layers) segment
 493       (setf layers (delete layer layers :test #'eq))
 494       ;; make sure there is one layer left
 495       (unless layers
 496         (add-layer (make-layer (staves (buffer segment)))
 497                    segment)))
 498     (setf segment nil)))
 499
 500 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 501 ;;;
 502 ;;; Buffer
 503
 504 ;;; Return a list of all the segment (in the right order) of the
 505 ;;; buffer.  This function may or may not return an object that
 506 ;;; reflects some internal structure of Gsharp.  Don't modify this
 507 ;;; object.  On the other hand, this function may also require some
 508 ;;; unnecessary consing.  For that reason, use the function
 509 ;;; buffer-segment whenever possible.
 510 (defgeneric segments (buffer))
 511
 512 ;;; Return the number of segments of the buffer
 513 (defgeneric nb-segments (buffer))
 514
 515 ;;; Return the segment indicated by the integer position.  The value of
 516 ;;; segno must be greater than or equal to 0 and strictly less than
 517 ;;; the number of segments of the buffer.
 518 (defgeneric segmentno (buffer position))
 519
 520 ;;; Return the staves of the buffer
 521 (defgeneric staves (buffer))
 522
 523 ;;; Find a staff based on its name
 524 (defgeneric find-staff (staff-name buffer &optional errorp))
 525
 526 ;;; Add a segment to the buffer at the position given
 527 (defgeneric add-segment (segment buffer position))
 528
 529 ;;; Delete a segment from the buffer to which it belongs
 530 (defgeneric remove-segment (segment))
 531
 532 (defvar *default-spacing-style* 0.4)
 533 (defvar *default-min-width* 17)
 534 (defvar *default-right-edge* 700)
 535 (defvar *default-left-offset* 30)
 536 (defvar *default-left-margin* 20)
 537
 538 (defclass buffer (gsharp-object esa-buffer-mixin)
 539   ((segments :initform '() :initarg :segments :accessor segments)
 540    (staves :initform (list (make-fiveline-staff))
 541            :initarg :staves :accessor staves)
 542    (rastral-size :initform 6 :initarg :r-size :accessor rastral-size)
 543    ;; the min width determines the preferred geographic distance after the
 544    ;; timeline with the shortest duration on a line.
 545    (min-width :initform *default-min-width* :initarg :min-width :accessor min-width)
 546    ;; the spacing style of the buffer determines the how geographic distance
 547    ;; between adjacent timelines is related to temporal distance.
 548    ;; a value of 0 means constant spacing, a value of 1 means proportional spacing
 549    (spacing-style :initform *default-spacing-style* :initarg :spacing-style :accessor spacing-style)
 550    (right-edge :initform *default-right-edge* :initarg :right-edge :accessor right-edge)
 551    (left-offset :initform *default-left-offset* :initarg :left-offset :accessor left-offset)
 552    (left-margin :initform *default-left-margin* :initarg :left-margin :accessor left-margin)))
 553
 554 (defmethod left-offset ((buffer buffer))
 555   (* (rastral-size buffer) 4))
 556
 557 (defun buffer-selection (buffer)
 558   (when (buffer-back-selection buffer)
 559     (car (buffer-back-selection buffer))))
 560
 561 (defun selection-browse-backward (buffer)
 562   (when (buffer-back-selection buffer)
 563     (push (car (buffer-back-selection buffer))
 564           (buffer-forward-selection buffer))
 565     (setf (buffer-back-selection buffer)
 566           (cdr (buffer-back-selection buffer)))))
 567
 568 (defun selection-browse-forward (buffer)
 569   (when (buffer-forward-selection buffer)
 570     (push (car (buffer-forward-selection buffer))
 571           (buffer-back-selection buffer))
 572     (setf (buffer-forward-selection buffer)
 573           (cdr (buffer-forward-selection buffer)))))
 574
 575 (defun add-new-selection (element-list buffer)
 576   (dolist (selection (buffer-forward-selection buffer)
 577            (push element-list (buffer-back-selection buffer)))
 578     (push selection (buffer-back-selection buffer))))
 579
 580 (defun set-buffer-of-staves (buffer)
 581   (loop for staff in (staves buffer)
 582         do (setf (buffer staff) buffer)))
 583
 584 (defmethod (setf staves) :after (staves (buffer buffer))
 585   (declare (ignore staves))
 586   (set-buffer-of-staves buffer))
 587
 588 (defmethod initialize-instance :after ((b buffer) &rest args)
 589   (declare (ignore args))
 590   (set-buffer-of-staves b)
 591   (with-slots (segments) b
 592     (when (null segments)
 593       (add-segment (make-instance 'segment :staff (car (staves b))) b 0))
 594     (loop for segment in segments
 595           do (setf (buffer segment) b))))
 596
 597 (defmethod slots-to-be-saved append ((b buffer))
 598   '(min-width spacing-style right-edge left-offset left-margin staves segments))
 599
 600 (defun read-buffer-v3 (stream char n)
 601   (declare (ignore char n))
 602   (apply #'make-instance 'buffer (read-delimited-list #\] stream t)))
 603
 604 (set-dispatch-macro-character #\[ #\B
 605   #'read-buffer-v3
 606   *gsharp-readtable-v3*)
 607
 608 (defmethod nb-segments ((buffer buffer))
 609   (length (segments buffer)))
 610
 611 (defmethod segmentno ((buffer buffer) position)
 612   (elt (segments buffer) position))
 613
 614 (define-condition segment-already-in-a-buffer (gsharp-condition)
 615   ()
 616   (:report
 617    (lambda (condition stream)
 618      (declare (ignore condition))
 619      (format stream "Attempt to add a segment already in some buffer"))))
 620
 621 (defmethod add-segment ((segment segment) (buf buffer) position)
 622   (with-slots (buffer) segment
 623     (assert (not buffer) () 'segment-already-in-a-buffer)
 624     (with-slots (segments) buf
 625       (setf segments (ninsert-element segment segments position)))
 626     (setf buffer buf)))
 627
 628 (define-condition segment-not-in-buffer (gsharp-condition)
 629   ()
 630   (:report
 631    (lambda (condition stream)
 632      (declare (ignore condition))
 633      (format stream "Attempt to delete a segment which is not in a buffer"))))
 634
 635 (defmethod remove-segment ((segment segment))
 636   (with-slots (buffer) segment
 637     (assert buffer () 'segment-not-in-buffer)
 638     (with-slots (segments) buffer
 639       (setf segments (delete segment segments :test #'eq))
 640       ;; make sure there is one segment left
 641       (unless segments
 642         (add-segment (make-instance 'segment :staff (car (staves buffer))) buffer 0)))
 643     (setf buffer nil)))
 644
 645 (define-condition staff-already-in-buffer (gsharp-condition) ()
 646   (:report
 647    (lambda (condition stream)
 648      (declare (ignore condition))
 649      (format stream "A staff with that name is already in the buffer"))))
 650
 651 (define-condition staff-not-in-buffer (gsharp-condition) ()
 652   (:report
 653    (lambda (condition stream)
 654      (declare (ignore condition))
 655      (format stream "No staff with that name in the buffer"))))
 656
 657 (defmethod find-staff (staff-name (buffer buffer) &optional (errorp t))
 658   (let ((staff (find staff-name (staves buffer) :key #'name :test #'string=)))
 659     (when errorp (assert staff () 'staff-not-in-buffer))
 660     staff))
 661
 662 (defun add-staff-before (newstaff staff staves)
 663   (assert (not (null staves)))
 664   (if (eq staff (car staves))
 665       (cons newstaff staves)
 666       (cons (car staves) (add-staff-before newstaff staff (cdr staves)))))
 667
 668 (defmethod add-staff-before-staff (staff newstaff (buffer buffer))
 669   (setf (staves buffer)
 670         (add-staff-before newstaff staff (staves buffer))))
 671
 672 (defun add-staff-after (newstaff staff staves)
 673   (assert (not (null staves)))
 674   (if (eq staff (car staves))
 675       (push newstaff (cdr staves))
 676       (add-staff-after newstaff staff (cdr staves)))
 677   staves)
 678
 679 (defmethod add-staff-after-staff (staff newstaff (buffer buffer))
 680   (setf (staves buffer)
 681         (add-staff-after newstaff staff (staves buffer))))
 682
 683 (defmethod rename-staff (staff-name (staff staff) (buffer buffer))
 684   (assert (not (find-staff staff-name buffer nil)) () 'staff-already-in-buffer)
 685   (setf (name staff) staff-name))
 686
 687 (define-condition staff-in-use (gsharp-condition) ()
 688   (:report
 689    (lambda (condition stream)
 690      (declare (ignore condition))
 691      (format stream "Staff in use"))))
 692
 693 (defmethod remove-staff-from-buffer (staff (buffer buffer))
 694   (assert (notany (lambda (segment)
 695                     (some (lambda (layer)
 696                             (member staff (staves layer)))
 697                           (layers segment)))
 698                   (segments buffer))
 699           () 'staff-in-use)
 700   (setf (staves buffer)
 701         (delete staff (staves buffer) :test #'eq)))
 702
 703 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 704 ;;;
 705 ;;; Reading and writing files
 706
 707 (define-condition file-does-not-exist (gsharp-condition) ()
 708   (:report
 709    (lambda (condition stream)
 710      (declare (ignore condition))
 711      (format stream "File does not exist"))))
 712
 713 (define-condition unknown-file-version (gsharp-condition) ()
 714   (:report
 715    (lambda (condition stream)
 716      (declare (ignore condition))
 717      (format stream "Unknown file version"))))
 718
 719 (defparameter *readtables*
 720   `(("G#V3" . ,*gsharp-readtable-v3*)
 721     ("G#V4" . ,*gsharp-readtable-v4*)))
 722
 723 (defun read-everything (filename)
 724   (assert (probe-file filename) () 'file-does-not-exist)
 725   (with-open-file (stream filename :direction :input)
 726     (let* ((version (read-line stream))
 727            (readtable (cdr (assoc version *readtables* :test #'string=))))
 728       (assert readtable () 'unknown-file-version)
 729       (let ((*read-eval* nil)
 730             (*readtable* readtable))
 731         (read stream)))))
 732
 733 (defun read-buffer-from-stream (stream)
 734   (let* ((version (read-line stream))
 735          (readtable (cdr (assoc version *readtables* :test #'string=))))
 736     (assert readtable () 'unknown-file-version)
 737     (let ((*read-eval* nil)
 738           (*readtable* readtable))
 739       (read stream))))
 740
 741 (defmethod frame-save-buffer-to-stream (application-frame (buffer buffer) stream)
 742   (let ((*print-circle* t)
 743         (*package* (find-package :keyword)))
 744     ;;    (format stream "G#V3~%")
 745     (format stream "G#V4~%")
 746     (pprint buffer stream)
 747     (terpri stream)
 748     (finish-output stream)))