1 (in-package :gsharp-cursor
)
3 (defmacro defcclass
(name base slots
)
5 (define-stealth-mixin ,name
() ,base
6 ((cursors :initform
'() :accessor cursors
)
9 ;;; For easy access, we hang the cursor in it bar (it is always in
10 ;;; some bar), in the slice of the bar, in the layer of the slice, and
11 ;;; in the segment of the layer.
13 (defclass gsharp-cursor
()
14 ((bar :initarg
:bar
:accessor bar
)
15 (pos :initarg
:pos
:accessor pos
)))
17 (defun make-cursor (bar pos
)
18 (let ((result (make-instance 'gsharp-cursor
:bar bar
:pos pos
)))
19 (set-cursor result bar pos
)
22 ;;; Set the cursor to the particular position in the bar.
23 ;;; The cursor is assumed not to be inserted on any item above
24 ;;; the bar, so it has to be inserted there.
25 (defgeneric set-cursor
(cursor bar position
))
27 ;;; Remove the cursor from the list of cursors of all the items above
29 (defgeneric unset-cursor
(cursor))
31 (defmethod set-cursor ((cursor gsharp-cursor
) (bar bar
) position
)
32 (let* ((slice (slice bar
))
34 (segment (segment layer
)))
35 (setf (bar cursor
) bar
36 (pos cursor
) position
)
37 (push cursor
(cursors bar
))
38 (push cursor
(cursors slice
))
39 (push cursor
(cursors layer
))
40 (push cursor
(cursors segment
))))
42 (defmethod unset-cursor ((cursor gsharp-cursor
))
43 (let* ((bar (bar cursor
))
46 (segment (segment layer
)))
47 (setf (cursors bar
) (delete cursor
(cursors bar
) :test
#'eq
)
48 (cursors slice
) (delete cursor
(cursors slice
) :test
#'eq
)
49 (cursors layer
) (delete cursor
(cursors layer
) :test
#'eq
)
50 (cursors segment
) (delete cursor
(cursors segment
) :test
#'eq
)
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 (defgeneric end-of-bar-p
(cursor))
59 (defgeneric beginning-of-bar-p
(cursor))
61 (defgeneric forward-element
(cursor))
63 (defgeneric backward-element
(cursor))
65 (defmethod end-of-bar-p ((cursor gsharp-cursor
))
67 (nb-elements (bar cursor
))))
69 (defmethod beginning-of-bar-p ((cursor gsharp-cursor
))
72 (defmethod forward-element ((cursor gsharp-cursor
))
73 (if (= (pos cursor
) (nb-elements (bar cursor
)))
77 (defmethod backward-element ((cursor gsharp-cursor
))
78 (if (zerop (pos cursor
))
82 (defmethod cursor-element ((cursor gsharp-cursor
))
83 (with-accessors ((bar bar
) (pos pos
)) cursor
84 (when (< pos
(nb-elements bar
))
85 (elementno bar pos
))))
87 (define-condition not-on-a-cluster
(gsharp-condition) ()
89 (lambda (condition stream
)
90 (declare (ignore condition
))
91 (format stream
"No current cluster"))))
93 (defmethod current-cluster ((cursor gsharp-cursor
))
94 (assert (not (beginning-of-bar-p cursor
)) () 'not-on-a-cluster
)
95 (with-accessors ((bar bar
) (pos pos
)) cursor
96 (let ((element (elementno bar
(1- pos
))))
97 (assert (and element
(typep element
'cluster
)) () 'not-on-a-cluster
)
100 (define-condition not-on-an-element
(gsharp-condition) ()
102 (lambda (condition stream
)
103 (declare (ignore condition
))
104 (format stream
"No current element"))))
106 (defmethod current-element ((cursor gsharp-cursor
))
107 (assert (not (beginning-of-bar-p cursor
)) () 'not-on-an-element
)
108 (with-accessors ((bar bar
) (pos pos
)) cursor
109 (let ((element (elementno bar
(1- pos
))))
110 (assert (and element
(typep element
'element
)) () 'not-on-an-element
)
113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
117 (defgeneric last-bar-p
(cursor))
119 (defgeneric first-bar-p
(cursor))
121 (defgeneric forward-bar
(cursor))
123 (defgeneric backward-bar
(cursor))
125 (defgeneric insert-element
(element cursor
))
127 (defgeneric delete-element
(cursor))
129 (defmethod last-bar-p ((cursor gsharp-cursor
))
130 (let ((bar (bar cursor
)))
131 (eq bar
(car (last (bars (slice bar
)))))))
133 (defmethod first-bar-p ((cursor gsharp-cursor
))
134 (let ((bar (bar cursor
)))
135 (eq bar
(car (bars (slice bar
))))))
137 (define-condition in-last-bar
(gsharp-condition) ()
139 (lambda (condition stream
)
140 (declare (ignore condition
))
141 (format stream
"In last bar"))))
143 (defmethod forward-bar ((cursor gsharp-cursor
))
144 (assert (not (last-bar-p cursor
)) () 'in-last-bar
)
145 (let ((newbar (barno (slice (bar cursor
)) (1+ (number (bar cursor
))))))
146 (unset-cursor cursor
)
147 (set-cursor cursor newbar
0)))
149 (define-condition in-first-bar
(gsharp-condition) ()
151 (lambda (condition stream
)
152 (declare (ignore condition
))
153 (format stream
"In first bar"))))
155 (defmethod backward-bar ((cursor gsharp-cursor
))
156 (assert (not (first-bar-p cursor
)) () 'in-first-bar
)
157 (let ((newbar (barno (slice (bar cursor
)) (1- (number (bar cursor
))))))
158 (unset-cursor cursor
)
159 (set-cursor cursor newbar
(nb-elements newbar
))))
164 (defmethod add-element :after
((element element
) (bar cbar
) position
)
165 (loop for cursor in
(cursors bar
) do
166 (when (> (pos cursor
) position
)
167 (incf (pos cursor
)))))
169 (defmethod add-element :after
((element staffwise-element
) bar position
)
170 (let ((staff (staff element
)))
171 (setf (staffwise-elements staff
)
172 (merge 'list
(list element
) (staffwise-elements staff
)
173 (lambda (x y
) (gsharp::starts-before-p x
(bar y
) y
))))))
175 (defmethod remove-element :before
((element element
) (bar cbar
))
176 (let ((elemno (number element
)))
177 (loop for cursor in
(cursors bar
) do
178 (when (> (pos cursor
) elemno
)
179 (decf (pos cursor
))))))
181 (defmethod insert-element ((element element
) (cursor gsharp-cursor
))
182 (add-element element
(bar cursor
) (pos cursor
)))
184 (define-condition end-of-bar
(gsharp-condition) ()
186 (lambda (condition stream
)
187 (declare (ignore condition
))
188 (format stream
"End of bar"))))
190 (define-condition beginning-of-bar
(gsharp-condition) ()
192 (lambda (condition stream
)
193 (declare (ignore condition
))
194 (format stream
"Beginning of bar"))))
196 (defmethod delete-element ((cursor gsharp-cursor
))
197 (assert (not (end-of-bar-p cursor
)) () 'end-of-bar
)
198 (let ((bar (bar cursor
)))
199 (remove-element (elementno bar
(pos cursor
)) bar
)))
201 (defmethod cursor-bar ((cursor gsharp-cursor
))
204 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208 (defmethod slice ((cursor gsharp-cursor
))
209 (slice (bar cursor
)))
211 (defgeneric first-slice-p
(cursor))
213 (defgeneric last-slice-p
(cursor))
215 (defgeneric forward-slice
(cursor))
217 (defgeneric backward-slice
(cursor))
219 (defgeneric head-slice
(cursor))
221 (defgeneric body-slice
(cursor))
223 (defgeneric tail-slice
(cursor))
225 (defgeneric insert-bar-before
(bar cursor
))
227 (defgeneric insert-bar-after
(bar cursor
))
229 (defgeneric delete-bar
(cursor))
231 (defmethod first-slice-p ((cursor gsharp-cursor
))
232 (let ((slice (slice (bar cursor
))))
233 (eq slice
(head (layer slice
)))))
235 (defmethod last-slice-p ((cursor gsharp-cursor
))
236 (let ((slice (slice (bar cursor
))))
237 (eq slice
(tail (layer slice
)))))
239 (define-condition in-last-slice
(gsharp-condition) ()
241 (lambda (condition stream
)
242 (declare (ignore condition
))
243 (format stream
"Attempt to go forward from last slice"))))
245 (defmethod forward-slice ((cursor gsharp-cursor
))
246 (assert (not (last-slice-p cursor
)) () 'in-last-slice
)
247 (let* ((oldslice (slice (bar cursor
)))
248 (oldsliceno (number oldslice
))
249 (newslice (sliceno (layer oldslice
) (1+ oldsliceno
)))
250 (newbar (barno newslice
0)))
251 (unset-cursor cursor
)
252 (set-cursor cursor newbar
0)))
254 (define-condition in-first-slice
(gsharp-condition) ()
256 (lambda (condition stream
)
257 (declare (ignore condition
))
258 (format stream
"Attempt to go backward from first slice"))))
260 (defmethod backward-slice ((cursor gsharp-cursor
))
261 (assert (not (first-slice-p cursor
)) () 'in-first-slice
)
262 (let* ((oldslice (slice (bar cursor
)))
263 (oldsliceno (number oldslice
))
264 (newslice (sliceno (layer oldslice
) (1- oldsliceno
)))
265 (newbar (barno newslice
(1- (nb-bars newslice
))))
266 (newpos (nb-elements newbar
)))
267 (unset-cursor cursor
)
268 (set-cursor cursor newbar newpos
)))
270 (defmethod head-slice ((cursor gsharp-cursor
))
271 (let* ((oldslice (slice (bar cursor
)))
272 (newslice (head (layer oldslice
)))
273 (newbar (barno newslice
0)))
274 (unset-cursor cursor
)
275 (set-cursor cursor newbar
0)))
277 (defmethod body-slice ((cursor gsharp-cursor
))
278 (let* ((oldslice (slice (bar cursor
)))
279 (newslice (body (layer oldslice
)))
280 (newbar (barno newslice
0)))
281 (unset-cursor cursor
)
282 (set-cursor cursor newbar
0)))
284 (defmethod tail-slice ((cursor gsharp-cursor
))
285 (let* ((oldslice (slice (bar cursor
)))
286 (newslice (tail (layer oldslice
)))
287 (newbar (barno newslice
0)))
288 (unset-cursor cursor
)
289 (set-cursor cursor newbar
0)))
291 (defcclass cslice slice
294 (defmethod remove-bar :around
((bar cbar
))
295 (let* ((cursors (cursors bar
))
298 (nb-bars (nb-bars slice
)))
300 (flet ((set-cursors (bar position
)
301 (loop for cursor in cursors do
302 (setf (bar cursor
) bar
303 (pos cursor
) position
))
304 (setf (cursors bar
) (append cursors
(cursors bar
)))))
305 (if (> nb-bars
(1+ barno
))
306 (set-cursors (barno slice barno
) 0)
307 (let ((bar (barno slice
(1- barno
))))
308 (set-cursors bar
(nb-elements bar
)))))))
310 (defmethod insert-bar-before ((bar bar
) (cursor gsharp-cursor
))
311 (let ((cursor-bar (bar cursor
)))
312 (add-bar bar
(slice cursor-bar
) (number cursor-bar
))))
314 (defmethod insert-bar-after ((bar bar
) (cursor gsharp-cursor
))
315 (let ((cursor-bar (bar cursor
)))
316 (add-bar bar
(slice cursor-bar
) (1+ (number cursor-bar
)))))
318 (defmethod delete-bar ((cursor gsharp-cursor
))
319 (assert (not (last-bar-p cursor
)) () 'in-last-bar
)
320 (remove-bar (bar cursor
)))
322 (defmethod cursor-slice ((cursor gsharp-cursor
))
323 (slice (bar cursor
)))
325 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
329 (defmethod layer ((cursor gsharp-cursor
))
330 (layer (slice cursor
)))
332 (defgeneric select-layer
(cursor new-layer
))
334 (defmethod select-layer ((cursor gsharp-cursor
) (new-layer layer
))
335 (let* ((oldbar (bar cursor
))
336 (oldbarno (number oldbar
))
337 (oldslice (slice oldbar
))
338 (oldsliceno (number oldslice
))
339 (newslice (sliceno new-layer oldsliceno
))
340 (newbarno (min (1- (nb-bars newslice
)) oldbarno
))
341 (newbar (barno newslice newbarno
)))
342 (unset-cursor cursor
)
343 (set-cursor cursor newbar
(nb-elements newbar
))))
345 (defcclass clayer layer
348 (defmethod cursor-layer ((cursor gsharp-cursor
))
349 (layer (cursor-slice cursor
)))
351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
355 (defmethod segment ((cursor gsharp-cursor
))
356 (segment (layer cursor
)))
358 (defgeneric delete-layer
(cursor))
360 (defcclass csegment segment
363 (defmethod remove-layer :around
((layer clayer
))
364 (let* ((layerno (number layer
))
365 (cursors (cursors layer
))
366 (segment (segment layer
))
367 (nb-layers (nb-layers segment
))
370 (flet ((set-cursor (cursor)
371 (push cursor
(cursors newlayer
))
372 (let* ((slice (sliceno newlayer
(number (slice (bar cursor
)))))
373 (barno (min (1- (nb-bars slice
)) (number (bar cursor
))))
374 (bar (barno slice barno
)))
375 (push cursor
(cursors slice
))
376 (push cursor
(cursors bar
))
377 (setf (bar cursor
) bar
)
378 (setf (pos cursor
) 0))))
379 (setf newlayer
(layerno segment
(if (> nb-layers
(1+ layerno
))
382 (mapc #'set-cursor cursors
))))
384 (defmethod delete-layer ((cursor gsharp-cursor
))
385 (remove-layer (cursor-layer cursor
)))
387 (defmethod cursor-segment ((cursor gsharp-cursor
))
388 (segment (cursor-layer cursor
)))
390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
394 (defmethod buffer ((cursor gsharp-cursor
))
395 (buffer (segment cursor
)))
397 (defgeneric first-segment-p
(cursor))
399 (defgeneric last-segment-p
(cursor))
401 (defgeneric forward-segment
(cursor))
403 (defgeneric backward-segment
(cursor))
405 (defgeneric insert-segment-before
(segment cursor
))
407 (defgeneric insert-segment-after
(segment cursor
))
409 (defgeneric delete-segment
(cursor))
411 (defmethod remove-segment :around
((segment csegment
))
412 (let* ((segno (number segment
))
413 (cursors (cursors segment
))
414 (buffer (buffer segment
))
415 (nb-segments (nb-segments buffer
)))
417 (flet ((set-cursors (segment layer slice bar position
)
418 (loop for cursor in cursors do
419 (setf (bar cursor
) bar
420 (pos cursor
) position
))
421 (setf (cursors segment
) (append cursors
(cursors segment
))
422 (cursors layer
) (append cursors
(cursors layer
))
423 (cursors slice
) (append cursors
(cursors slice
))
424 (cursors bar
) (append cursors
(cursors bar
)))))
425 (if (or (> nb-segments
(1+ segno
)) (zerop segno
))
426 (let* ((segment (segmentno buffer segno
))
427 (layer (car (layers segment
)))
429 (bar (car (bars slice
))))
430 (set-cursors segment layer slice bar
0))
431 (let* ((segment (segmentno buffer
(1- segno
)))
432 (layer (car (layers segment
)))
434 (bar (car (last (bars slice
))))
435 (position (nb-elements bar
)))
436 (set-cursors segment layer slice bar position
))))))
438 (defmethod first-segment-p ((cursor gsharp-cursor
))
439 (let ((segment (cursor-segment cursor
)))
440 (eq segment
(car (segments (buffer segment
))))))
442 (defmethod last-segment-p ((cursor gsharp-cursor
))
443 (let ((segment (cursor-segment cursor
)))
444 (eq segment
(car (last (segments (buffer segment
)))))))
446 (define-condition in-last-segment
(gsharp-condition) ()
448 (lambda (condition stream
)
449 (declare (ignore condition
))
450 (format stream
"Attempt to go forward from last segment"))))
452 (defmethod forward-segment ((cursor gsharp-cursor
))
453 (assert (not (last-segment-p cursor
)) () 'in-last-segment
)
454 (let* ((oldsegment (segment (layer (slice (bar cursor
)))))
455 (oldsegmentno (number oldsegment
))
456 (buffer (buffer oldsegment
))
457 (newsegmentno (1+ oldsegmentno
))
458 (newsegment (segmentno buffer newsegmentno
))
459 (newlayer (layerno newsegment
0))
460 (newslice (body newlayer
))
461 (newbar (barno newslice
0)))
462 (unset-cursor cursor
)
463 (set-cursor cursor newbar
0)))
465 (define-condition in-first-segment
(gsharp-condition) ()
467 (lambda (condition stream
)
468 (declare (ignore condition
))
469 (format stream
"Attempt to go backward from first segment"))))
471 (defmethod backward-segment ((cursor gsharp-cursor
))
472 (assert (not (first-segment-p cursor
)) () 'in-first-segment
)
473 (let* ((oldsegment (segment (layer (slice (bar cursor
)))))
474 (oldsegmentno (number oldsegment
))
475 (buffer (buffer oldsegment
))
476 (newsegmentno (1- oldsegmentno
))
477 (newsegment (segmentno buffer newsegmentno
))
478 (newlayer (layerno newsegment
0))
479 (newslice (body newlayer
))
480 (newbarno (1- (nb-bars newslice
)))
481 (newbar (barno newslice newbarno
))
482 (newpos (nb-elements newbar
)))
483 (unset-cursor cursor
)
484 (set-cursor cursor newbar newpos
)))
486 (defmethod insert-segment-before ((segment segment
) (cursor gsharp-cursor
))
487 (let ((cursor-seg (cursor-segment cursor
)))
488 (add-segment segment
(buffer cursor-seg
) (number cursor-seg
))))
490 (defmethod insert-segment-after ((segment segment
) (cursor gsharp-cursor
))
491 (let ((cursor-seg (cursor-segment cursor
)))
492 (add-segment segment
(buffer cursor-seg
) (1+ (number cursor-seg
)))))
494 (defmethod delete-segment ((cursor gsharp-cursor
))
495 (remove-segment (cursor-segment cursor
)))
497 (defmethod cursor-buffer ((cursor gsharp-cursor
))
498 (buffer (cursor-segment cursor
)))