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