/[gsharp]/gsharp/buffer.lisp
ViewVC logotype

Contents of /gsharp/buffer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.60 - (show annotations)
Mon Apr 20 15:04:47 2009 UTC (5 years ago) by dlewis
Branch: MAIN
CVS Tags: HEAD
Changes since 1.59: +2 -2 lines
Basic time signature support. Only some sigs supported and spacing is basic.
Key and time signatures now share a staffwise-elements slot in the stave.
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 ;; the min width determines the preferred geographic distance after the
543 ;; timeline with the shortest duration on a line.
544 (min-width :initform *default-min-width* :initarg :min-width :accessor min-width)
545 ;; the spacing style of the buffer determines the how geographic distance
546 ;; between adjacent timelines is related to temporal distance.
547 ;; a value of 0 means constant spacing, a value of 1 means proportional spacing
548 (spacing-style :initform *default-spacing-style* :initarg :spacing-style :accessor spacing-style)
549 (right-edge :initform *default-right-edge* :initarg :right-edge :accessor right-edge)
550 (left-offset :initform *default-left-offset* :initarg :left-offset :accessor left-offset)
551 (left-margin :initform *default-left-margin* :initarg :left-margin :accessor left-margin)))
552
553 (defun set-buffer-of-staves (buffer)
554 (loop for staff in (staves buffer)
555 do (setf (buffer staff) buffer)))
556
557 (defmethod (setf staves) :after (staves (buffer buffer))
558 (declare (ignore staves))
559 (set-buffer-of-staves buffer))
560
561 (defmethod initialize-instance :after ((b buffer) &rest args)
562 (declare (ignore args))
563 (set-buffer-of-staves b)
564 (with-slots (segments) b
565 (when (null segments)
566 (add-segment (make-instance 'segment :staff (car (staves b))) b 0))
567 (loop for segment in segments
568 do (setf (buffer segment) b))))
569
570 (defmethod slots-to-be-saved append ((b buffer))
571 '(min-width spacing-style right-edge left-offset left-margin staves segments))
572
573 (defun read-buffer-v3 (stream char n)
574 (declare (ignore char n))
575 (apply #'make-instance 'buffer (read-delimited-list #\] stream t)))
576
577 (set-dispatch-macro-character #\[ #\B
578 #'read-buffer-v3
579 *gsharp-readtable-v3*)
580
581 (defmethod nb-segments ((buffer buffer))
582 (length (segments buffer)))
583
584 (defmethod segmentno ((buffer buffer) position)
585 (elt (segments buffer) position))
586
587 (define-condition segment-already-in-a-buffer (gsharp-condition)
588 ()
589 (:report
590 (lambda (condition stream)
591 (declare (ignore condition))
592 (format stream "Attempt to add a segment already in some buffer"))))
593
594 (defmethod add-segment ((segment segment) (buf buffer) position)
595 (with-slots (buffer) segment
596 (assert (not buffer) () 'segment-already-in-a-buffer)
597 (with-slots (segments) buf
598 (setf segments (ninsert-element segment segments position)))
599 (setf buffer buf)))
600
601 (define-condition segment-not-in-buffer (gsharp-condition)
602 ()
603 (:report
604 (lambda (condition stream)
605 (declare (ignore condition))
606 (format stream "Attempt to delete a segment which is not in a buffer"))))
607
608 (defmethod remove-segment ((segment segment))
609 (with-slots (buffer) segment
610 (assert buffer () 'segment-not-in-buffer)
611 (with-slots (segments) buffer
612 (setf segments (delete segment segments :test #'eq))
613 ;; make sure there is one segment left
614 (unless segments
615 (add-segment (make-instance 'segment :staff (car (staves buffer))) buffer 0)))
616 (setf buffer nil)))
617
618 (define-condition staff-already-in-buffer (gsharp-condition) ()
619 (:report
620 (lambda (condition stream)
621 (declare (ignore condition))
622 (format stream "A staff with that name is already in the buffer"))))
623
624 (define-condition staff-not-in-buffer (gsharp-condition) ()
625 (:report
626 (lambda (condition stream)
627 (declare (ignore condition))
628 (format stream "No staff with that name in the buffer"))))
629
630 (defmethod find-staff (staff-name (buffer buffer) &optional (errorp t))
631 (let ((staff (find staff-name (staves buffer) :key #'name :test #'string=)))
632 (when errorp (assert staff () 'staff-not-in-buffer))
633 staff))
634
635 (defun add-staff-before (newstaff staff staves)
636 (assert (not (null staves)))
637 (if (eq staff (car staves))
638 (cons newstaff staves)
639 (cons (car staves) (add-staff-before newstaff staff (cdr staves)))))
640
641 (defmethod add-staff-before-staff (staff newstaff (buffer buffer))
642 (setf (staves buffer)
643 (add-staff-before newstaff staff (staves buffer))))
644
645 (defun add-staff-after (newstaff staff staves)
646 (assert (not (null staves)))
647 (if (eq staff (car staves))
648 (push newstaff (cdr staves))
649 (add-staff-after newstaff staff (cdr staves)))
650 staves)
651
652 (defmethod add-staff-after-staff (staff newstaff (buffer buffer))
653 (setf (staves buffer)
654 (add-staff-after newstaff staff (staves buffer))))
655
656 (defmethod rename-staff (staff-name (staff staff) (buffer buffer))
657 (assert (not (find-staff staff-name buffer nil)) () 'staff-already-in-buffer)
658 (setf (name staff) staff-name))
659
660 (define-condition staff-in-use (gsharp-condition) ()
661 (:report
662 (lambda (condition stream)
663 (declare (ignore condition))
664 (format stream "Staff in use"))))
665
666 (defmethod remove-staff-from-buffer (staff (buffer buffer))
667 (assert (notany (lambda (segment)
668 (some (lambda (layer)
669 (member staff (staves layer)))
670 (layers segment)))
671 (segments buffer))
672 () 'staff-in-use)
673 (setf (staves buffer)
674 (delete staff (staves buffer) :test #'eq)))
675
676 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
677 ;;;
678 ;;; Reading and writing files
679
680 (define-condition file-does-not-exist (gsharp-condition) ()
681 (:report
682 (lambda (condition stream)
683 (declare (ignore condition))
684 (format stream "File does not exist"))))
685
686 (define-condition unknown-file-version (gsharp-condition) ()
687 (:report
688 (lambda (condition stream)
689 (declare (ignore condition))
690 (format stream "Unknown file version"))))
691
692 (defparameter *readtables*
693 `(("G#V3" . ,*gsharp-readtable-v3*)
694 ("G#V4" . ,*gsharp-readtable-v4*)))
695
696 (defun read-everything (filename)
697 (assert (probe-file filename) () 'file-does-not-exist)
698 (with-open-file (stream filename :direction :input)
699 (let* ((version (read-line stream))
700 (readtable (cdr (assoc version *readtables* :test #'string=))))
701 (assert readtable () 'unknown-file-version)
702 (let ((*read-eval* nil)
703 (*readtable* readtable))
704 (read stream)))))
705
706 (defun read-buffer-from-stream (stream)
707 (let* ((version (read-line stream))
708 (readtable (cdr (assoc version *readtables* :test #'string=))))
709 (assert readtable () 'unknown-file-version)
710 (let ((*read-eval* nil)
711 (*readtable* readtable))
712 (read stream))))
713
714 (defmethod frame-save-buffer-to-stream (application-frame (buffer buffer) stream)
715 (let ((*print-circle* t)
716 (*package* (find-package :keyword)))
717 ;; (format stream "G#V3~%")
718 (format stream "G#V4~%")
719 (pprint buffer stream)
720 (terpri stream)
721 (finish-output stream)))

  ViewVC Help
Powered by ViewVC 1.1.5