- gsharp-cvs@common-lisp.net - mailman3.common-lisp.net

[gsharp-cvs] CVS update: gsharp/drawing.lisp
by rstrandh＠common-lisp.net 18 Nov '05

18 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv18752 Modified Files: drawing.lisp Log Message: mostly renaming Date: Fri Nov 18 20:41:44 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.25 gsharp/drawing.lisp:1.26 --- gsharp/drawing.lisp:1.25 Fri Nov 18 18:53:40 2005 +++ gsharp/drawing.lisp Fri Nov 18 20:41:44 2005 @@ -66,14 +66,14 @@ ;;; computed from the x offset of the cluster of the note and the ;;; relative x offset of the note with respect to the cluster. (defun final-absolute-note-xoffset (note) - (+ (element-xpos (cluster note)) (final-relative-note-xoffset note))) + (+ (final-absolute-element-xoffset (cluster note)) (final-relative-note-xoffset note))) ;;; Return the final absolute x offset of the accidental of a note. ;;; This value is computed from the x offset of the cluster of the ;;; note and the relative x offset of the accidental of the note with ;;; respect to the cluster. (defun final-absolute-accidental-xoffset (note) - (+ (element-xpos (cluster note)) (final-relative-accidental-xoffset note))) + (+ (final-absolute-element-xoffset (cluster note)) (final-relative-accidental-xoffset note))) (defun line-cost (measures method) (reduce (lambda (x y) (combine-cost method x y)) measures :initial-value nil)) @@ -199,10 +199,10 @@ ;; the yoffset of the staff that contains the bottom note of ;; the element (bot-note-staff-yoffset :accessor bot-note-staff-yoffset) - (xpos :accessor element-xpos))) + (final-absolute-xoffset :accessor final-absolute-element-xoffset))) (define-added-mixin welement () lyrics-element - ((xpos :accessor element-xpos))) + ((final-absolute-xoffset :accessor final-absolute-element-xoffset))) ;;; given a list of notes, return the one that is at the top (defun top-note (notes) @@ -263,7 +263,7 @@ ;;; Compute and store the final stem direction of an element that is ;;; not beamed together with any other elements. -(defun compute-stem-direction (element) +(defun compute-final-stem-direction (element) (setf (final-stem-direction element) (if (or (eq (stem-direction element) :up) (eq (stem-direction element) :down)) (stem-direction element) @@ -327,7 +327,7 @@ (let (;;(time-alist (time-alist bar)) (start-time 0)) (mapc (lambda (element) - (setf (element-xpos element) + (setf (final-absolute-element-xoffset element) (round (+ x (score-pane:staff-step (xoffset element)) (cdr (assoc start-time time-alist))))) @@ -336,7 +336,7 @@ ;;; Compute and store the final stem directions of all the elements of ;;; a beam group with at least two elements in it. -(defun compute-stem-directions (elements) +(defun compute-final-stem-directions (elements) (let ((stem-direction (if (not (eq (stem-direction (car elements)) :auto)) (stem-direction (car elements)) (let ((top-note-pos (reduce #'max elements :key #'top-note-pos)) @@ -375,8 +375,8 @@ (let ((element (car elements))) (when (or (typep element 'rest) (notes element)) (when (typep element 'cluster) - (compute-stem-direction element)))) - (compute-stem-directions elements))) + (compute-final-stem-direction element)))) + (compute-final-stem-directions elements))) (defun draw-beam-group (pane elements) (mapc #'compute-top-bot-yoffset elements) @@ -384,9 +384,9 @@ (let ((element (car elements))) (when (or (typep element 'rest) (notes element)) (when (typep element 'cluster) - (compute-stem-direction element) + (compute-final-stem-direction element) (compute-stem-length element)) - (draw-element pane element (element-xpos element)))) + (draw-element pane element (final-absolute-element-xoffset element)))) (let* ((stem-direction (final-stem-direction (car elements))) (dominating-notes (mapcar (lambda (e) (dominating-note (notes e) stem-direction)) @@ -399,24 +399,24 @@ (if (eq stem-direction :up) -1000 1000))) dominating-notes)) (x-positions (mapcar (lambda (element) - (/ (element-xpos element) (score-pane:staff-step 1))) + (/ (final-absolute-element-xoffset element) (score-pane:staff-step 1))) elements)) (beaming (beaming-single (mapcar #'list positions x-positions) stem-direction))) (destructuring-bind ((ss1 . offset1) (ss2 . offset2)) beaming (let* ((y1 (+ ss1 (* 1/2 offset1))) (y2 (+ ss2 (* 1/2 offset2))) - (x1 (element-xpos (car elements))) - (x2 (element-xpos (car (last elements)))) + (x1 (final-absolute-element-xoffset (car elements))) + (x2 (final-absolute-element-xoffset (car (last elements)))) (slope (/ (- y2 y1) (- x2 x1)))) (if (eq stem-direction :up) (loop for element in elements do (setf (final-stem-position element) - (+ y1 (* slope (- (element-xpos element) x1)))) + (+ y1 (* slope (- (final-absolute-element-xoffset element) x1)))) (setf (final-stem-yoffset element) (staff-yoffset dominating-staff))) (loop for element in elements do (setf (final-stem-position element) - (+ y1 (* slope (- (element-xpos element) x1)))) + (+ y1 (* slope (- (final-absolute-element-xoffset element) x1)))) (setf (final-stem-yoffset element) (staff-yoffset dominating-staff))))) (score-pane:with-vertical-score-position (pane (staff-yoffset dominating-staff)) @@ -424,15 +424,15 @@ (score-pane:with-notehead-right-offsets (right up) (declare (ignore up)) (score-pane:draw-beam pane - (+ (element-xpos (car elements)) right) ss1 offset1 - (+ (element-xpos (car (last elements))) right) ss2 offset2)) + (+ (final-absolute-element-xoffset (car elements)) right) ss1 offset1 + (+ (final-absolute-element-xoffset (car (last elements))) right) ss2 offset2)) (score-pane:with-notehead-left-offsets (left down) (declare (ignore down)) (score-pane:draw-beam pane - (+ (element-xpos (car elements)) left) ss1 offset1 - (+ (element-xpos (car (last elements))) left) ss2 offset2)))) + (+ (final-absolute-element-xoffset (car elements)) left) ss1 offset1 + (+ (final-absolute-element-xoffset (car (last elements))) left) ss2 offset2)))) (loop for element in elements do - (draw-element pane element (element-xpos element) nil)))))) + (draw-element pane element (final-absolute-element-xoffset element) nil)))))) (defun draw-cursor (pane x) (draw-line* pane x (- (score-pane:staff-step -4)) x (- (score-pane:staff-step 12)) :ink +red+)) @@ -461,28 +461,28 @@ (if (null (cursor-element *cursor*)) (funcall draw-cursor (/ (+ (if (null elements) x - (element-xpos (car (last elements)))) + (final-absolute-element-xoffset (car (last elements)))) x width) 2)) (loop for element in elements - and xx = x then (element-xpos element) do + and xx = x then (final-absolute-element-xoffset element) do (when (eq (cursor-element *cursor*) element) - (funcall draw-cursor (/ (+ xx (element-xpos element)) 2)))))))) + (funcall draw-cursor (/ (+ xx (final-absolute-element-xoffset element)) 2)))))))) (defmethod draw-bar (pane (bar lyrics-bar) x width time-alist draw-cursor) (compute-element-x-positions bar x time-alist) (let ((elements (elements bar))) (loop for element in elements - do (draw-element pane element (element-xpos element))) + do (draw-element pane element (final-absolute-element-xoffset element))) (when (eq (cursor-bar *cursor*) bar) (if (null (cursor-element *cursor*)) (funcall draw-cursor (/ (+ (if (null elements) x - (element-xpos (car (last elements)))) + (final-absolute-element-xoffset (car (last elements)))) x width) 2)) (loop for element in elements - and xx = x then (element-xpos element) do + and xx = x then (final-absolute-element-xoffset element) do (when (eq (cursor-element *cursor*) element) - (funcall draw-cursor (/ (+ xx (element-xpos element)) 2)))))))) + (funcall draw-cursor (/ (+ xx (final-absolute-element-xoffset element)) 2)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp
by rstrandh＠common-lisp.net 18 Nov '05

18 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv11018 Modified Files: drawing.lisp Log Message: Accidentals are now placed relative to the cluster. Also, more renaming to improve maintainability. Date: Fri Nov 18 18:53:41 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.24 gsharp/drawing.lisp:1.25 --- gsharp/drawing.lisp:1.24 Fri Nov 18 18:36:36 2005 +++ gsharp/drawing.lisp Fri Nov 18 18:53:40 2005 @@ -5,10 +5,13 @@ (define-added-mixin dnote () note (;; the relative x offset of the note with respect to the cluster - (final-relative-xoffset :accessor final-relative-xoffset) + (final-relative-note-xoffset :accessor final-relative-note-xoffset) (final-accidental :initform nil :accessor final-accidental) - ;; nil indicates that accidental has not been placed yet - (accidental-position :initform nil :accessor accidental-position))) + ;; The relative x offset of the accidental of the note with respect + ;; to the cluster. A value of nil indicates that accidental has + ;; not been placed yet + (final-relative-accidental-xoffset :initform nil + :accessor final-relative-accidental-xoffset))) (define-presentation-method present (object (type score-pane:clef) stream (view textual-view) &key) @@ -59,18 +62,18 @@ :x1 ,x1 :x2 ,x2) :stream pane)) -;;; Return the final x offset of a note. This value is computed from -;;; the x offset of the cluster of the note and the relative x offset -;;; of the note with respect to the cluster. -(defun final-note-xoffset (note) - (+ (element-xpos (cluster note)) (final-relative-xoffset note))) - -;;; Return the final x offset of the accidental of a note. This value -;;; is computed from the x offset of the cluster of the note and the -;;; relative x offset of the accidental of the note with respect to -;;; the cluster. -(defun final-accidental-xoffset (note) - (+ (element-xpos (cluster note)) (accidental-position note))) +;;; Return the final absolute x offset of a note. This value is +;;; computed from the x offset of the cluster of the note and the +;;; relative x offset of the note with respect to the cluster. +(defun final-absolute-note-xoffset (note) + (+ (element-xpos (cluster note)) (final-relative-note-xoffset note))) + +;;; Return the final absolute x offset of the accidental of a note. +;;; This value is computed from the x offset of the cluster of the +;;; note and the relative x offset of the accidental of the note with +;;; respect to the cluster. +(defun final-absolute-accidental-xoffset (note) + (+ (element-xpos (cluster note)) (final-relative-accidental-xoffset note))) (defun line-cost (measures method) (reduce (lambda (x y) (combine-cost method x y)) measures :initial-value nil)) @@ -528,12 +531,12 @@ (score-pane:with-vertical-score-position (pane (staff-yoffset (staff note))) (score-pane:draw-notehead pane notehead x pos) (when (final-accidental note) - (score-pane:draw-accidental pane (final-accidental note) (accidental-position note) pos)) + (score-pane:draw-accidental pane (final-accidental note) (final-absolute-accidental-xoffset note) pos)) (draw-dots pane nb-dots x pos))) (defun draw-notes (pane notes dots notehead) (loop for note in notes do - (draw-note pane note notehead dots (final-note-xoffset note) (note-position note)))) + (draw-note pane note notehead dots (final-absolute-note-xoffset note) (note-position note)))) ;;; given a group of notes (i.e. a list of notes, all displayed on the ;;; same staff, compute their final x offsets. This is a question of @@ -541,14 +544,14 @@ ;;; the stem. The head-note of the stem goes to the left of an ;;; up-stem and to the right of a down-stem. The x offset of a cluster ;;; gives the x position of the head-note. -(defun compute-final-relative-xoffsets (group direction) +(defun compute-final-relative-note-xoffsets (group direction) (setf group (sort (copy-list group) (if (eq direction :up) (lambda (x y) (< (note-position x) (note-position y))) (lambda (x y) (> (note-position x) (note-position y)))))) (score-pane:with-suspended-note-offset offset ;; the first element of the group is the head-note - (setf (final-relative-xoffset (car group)) 0) + (setf (final-relative-note-xoffset (car group)) 0) ;; OFFSET is a positive quantity that determines the ;; absolute difference between the x offset of a suspended ;; note and that of a normally positioned note. @@ -560,7 +563,7 @@ ;; if adjacent notes are just one staff step apart, ;; then one must be suspended. (dx (if (= (abs (- pos old-pos)) 1) offset 0))) - (setf (final-relative-xoffset note) dx) + (setf (final-relative-note-xoffset note) dx) ;; go back to ordinary offset (when (= (abs (- pos old-pos)) 1) (setf note old-note)))))) @@ -577,7 +580,7 @@ (accidentals note))))) (defun element-has-suspended-notes (element) - (not (apply #'= (mapcar #'final-relative-xoffset (notes element))))) + (not (apply #'= (mapcar #'final-relative-note-xoffset (notes element))))) ;;; table of x offsets (in staff steps) of accendentals. ;;; The first index represents a notehead or a type of accidental. @@ -653,16 +656,16 @@ ;;; of the accidental of the first note. If the second note has ;;; an accidental, but that has not been given a final x offset, then ;;; use the x offset of the notehead instead. -(defun accidental-xoffset (note1 note2 staff-step) +(defun accidental-relative-xoffset (note1 note2 staff-step) (let* ((acc1 (final-accidental note1)) (pos1 (note-position note1)) (acc2 (if (and (final-accidental note2) - (accidental-position note2)) + (final-relative-accidental-xoffset note2)) (final-accidental note2) :notehead)) (pos2 (note-position note2)) - (xpos2 (or (accidental-position note2) - (final-note-xoffset note2)))) + (xpos2 (or (final-relative-accidental-xoffset note2) + (final-relative-note-xoffset note2)))) (- xpos2 (* staff-step (accidental-distance acc1 pos1 acc2 pos2))))) ;;; given a note and a list of notes, compute x offset of the accidental @@ -670,7 +673,7 @@ ;;; for the accidental of the note not to overlap any of the others, ;;; we must use the minimum of all the x offsets thus computed. (defun accidental-min-xoffset (note1 notes staff-step) - (reduce #'min notes :key (lambda (note) (accidental-xoffset note1 note staff-step)))) + (reduce #'min notes :key (lambda (note) (accidental-relative-xoffset note1 note staff-step)))) ;;; given a list of notes that have accidentals to place, and a list of ;;; notes that either have no accidentals or with already-placed accidentals, @@ -684,32 +687,32 @@ notes-with-accidentals)) ;;; for each note in a list of notes, if it has an accidental, compute -;;; the position of that accidental and store it in the note. -(defun compute-final-accidental-positions (notes x final-stem-direction) +;;; the final relative x offset of that accidental and store it in the note. +(defun compute-final-relative-accidental-xoffset (notes x final-stem-direction) (let* ((staff-step (score-pane:staff-step 1)) ;; sort the notes from top to bottom (notes (sort (copy-list notes) (lambda (x y) (> (note-position x) (note-position y))))) (notes-with-accidentals (remove-if-not #'final-accidental notes))) ;; initially, no accidental has been placed - (loop for note in notes do (setf (accidental-position note) nil)) + (loop for note in notes do (setf (final-relative-accidental-xoffset note) nil)) (when (eq final-stem-direction :up) ;; when the stem direction is :up and there is a suspended note ;; i.e., one to the right of the stem, then the accidental of the topmost ;; suspended note is placed first. (let ((first-suspended-note - (find x notes-with-accidentals :test #'/= :key #'final-relative-xoffset))) + (find x notes-with-accidentals :test #'/= :key #'final-relative-note-xoffset))) (when first-suspended-note (setf notes-with-accidentals (remove first-suspended-note notes-with-accidentals)) - (setf (accidental-position first-suspended-note) + (setf (final-relative-accidental-xoffset first-suspended-note) (accidental-min-xoffset first-suspended-note notes staff-step))))) ;; place remaining accidentals (loop while notes-with-accidentals do (let ((choice (best-accidental notes-with-accidentals notes staff-step))) (setf notes-with-accidentals (remove choice notes-with-accidentals)) - (setf (accidental-position choice) + (setf (final-relative-accidental-xoffset choice) (accidental-min-xoffset choice notes staff-step)))))) ;;; given a list of notes, group them so that every note in the group @@ -741,9 +744,9 @@ (score-pane:with-vertical-score-position (pane stem-yoffset) (draw-flags pane element x direction stem-pos))) (loop for group in groups do - (compute-final-relative-xoffsets group direction) + (compute-final-relative-note-xoffsets group direction) (compute-final-accidentals group) - (compute-final-accidental-positions group x direction) + (compute-final-relative-accidental-xoffset group x direction) (draw-notes pane group (dots element) (notehead element)) (draw-ledger-lines pane x group)) (unless (eq (notehead element) :whole)

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp
by rstrandh＠common-lisp.net 18 Nov '05

18 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv9841 Modified Files: drawing.lisp Log Message: renaming, mostly. Date: Fri Nov 18 18:36:37 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.23 gsharp/drawing.lisp:1.24 --- gsharp/drawing.lisp:1.23 Fri Nov 18 17:59:53 2005 +++ gsharp/drawing.lisp Fri Nov 18 18:36:36 2005 @@ -62,9 +62,16 @@ ;;; Return the final x offset of a note. This value is computed from ;;; the x offset of the cluster of the note and the relative x offset ;;; of the note with respect to the cluster. -(defun final-xoffset (note) +(defun final-note-xoffset (note) (+ (element-xpos (cluster note)) (final-relative-xoffset note))) +;;; Return the final x offset of the accidental of a note. This value +;;; is computed from the x offset of the cluster of the note and the +;;; relative x offset of the accidental of the note with respect to +;;; the cluster. +(defun final-accidental-xoffset (note) + (+ (element-xpos (cluster note)) (accidental-position note))) + (defun line-cost (measures method) (reduce (lambda (x y) (combine-cost method x y)) measures :initial-value nil)) @@ -526,7 +533,7 @@ (defun draw-notes (pane notes dots notehead) (loop for note in notes do - (draw-note pane note notehead dots (final-xoffset note) (note-position note)))) + (draw-note pane note notehead dots (final-note-xoffset note) (note-position note)))) ;;; given a group of notes (i.e. a list of notes, all displayed on the ;;; same staff, compute their final x offsets. This is a question of @@ -646,8 +653,7 @@ ;;; of the accidental of the first note. If the second note has ;;; an accidental, but that has not been given a final x offset, then ;;; use the x offset of the notehead instead. -;;; (this funtction should probably be renamed accidental-xoffset) -(defun accidental-xpos (note1 note2 staff-step) +(defun accidental-xoffset (note1 note2 staff-step) (let* ((acc1 (final-accidental note1)) (pos1 (note-position note1)) (acc2 (if (and (final-accidental note2) @@ -656,24 +662,23 @@ :notehead)) (pos2 (note-position note2)) (xpos2 (or (accidental-position note2) - (final-xoffset note2)))) + (final-note-xoffset note2)))) (- xpos2 (* staff-step (accidental-distance acc1 pos1 acc2 pos2))))) ;;; given a note and a list of notes, compute x offset of the accidental ;;; of the note as required by each of the notes in the list. In order ;;; for the accidental of the note not to overlap any of the others, ;;; we must use the minimum of all the x offsets thus computed. -;;; (this function shoudl probably be renamed accidental-min-xoffset) -(defun accidental-min-xpos (note1 notes staff-step) - (reduce #'min notes :key (lambda (note) (accidental-xpos note1 note staff-step)))) +(defun accidental-min-xoffset (note1 notes staff-step) + (reduce #'min notes :key (lambda (note) (accidental-xoffset note1 note staff-step)))) ;;; given a list of notes that have accidentals to place, and a list of ;;; notes that either have no accidentals or with already-placed accidentals, ;;; compute the note in the first list that can be placed as far to the right ;;; as possible. (defun best-accidental (notes-with-accidentals notes staff-step) - (reduce (lambda (note1 note2) (if (>= (accidental-min-xpos note1 notes staff-step) - (accidental-min-xpos note2 notes staff-step)) + (reduce (lambda (note1 note2) (if (>= (accidental-min-xoffset note1 notes staff-step) + (accidental-min-xoffset note2 notes staff-step)) note1 note2)) notes-with-accidentals)) @@ -698,14 +703,14 @@ (setf notes-with-accidentals (remove first-suspended-note notes-with-accidentals)) (setf (accidental-position first-suspended-note) - (accidental-min-xpos first-suspended-note notes staff-step))))) + (accidental-min-xoffset first-suspended-note notes staff-step))))) ;; place remaining accidentals (loop while notes-with-accidentals do (let ((choice (best-accidental notes-with-accidentals notes staff-step))) (setf notes-with-accidentals (remove choice notes-with-accidentals)) (setf (accidental-position choice) - (accidental-min-xpos choice notes staff-step)))))) + (accidental-min-xoffset choice notes staff-step)))))) ;;; given a list of notes, group them so that every note in the group ;;; is displayed on the same staff. Return the list of groups.

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp
by rstrandh＠common-lisp.net 18 Nov '05

18 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv6081 Modified Files: drawing.lisp Log Message: Pursue the effort to separate the current drawing phase into two phases. Now, the x offset of a note is relative to that of the cluster, so that the relative x offset can be computed before the x offset of the cluster is known, i.e., before line breaking. Date: Fri Nov 18 17:59:53 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.22 gsharp/drawing.lisp:1.23 --- gsharp/drawing.lisp:1.22 Fri Nov 18 03:49:43 2005 +++ gsharp/drawing.lisp Fri Nov 18 17:59:53 2005 @@ -4,7 +4,8 @@ ((yoffset :initform 0 :accessor staff-yoffset))) (define-added-mixin dnote () note - ((final-xposition :accessor final-xposition) + (;; the relative x offset of the note with respect to the cluster + (final-relative-xoffset :accessor final-relative-xoffset) (final-accidental :initform nil :accessor final-accidental) ;; nil indicates that accidental has not been placed yet (accidental-position :initform nil :accessor accidental-position))) @@ -58,6 +59,12 @@ :x1 ,x1 :x2 ,x2) :stream pane)) +;;; Return the final x offset of a note. This value is computed from +;;; the x offset of the cluster of the note and the relative x offset +;;; of the note with respect to the cluster. +(defun final-xoffset (note) + (+ (element-xpos (cluster note)) (final-relative-xoffset note))) + (defun line-cost (measures method) (reduce (lambda (x y) (combine-cost method x y)) measures :initial-value nil)) @@ -519,7 +526,7 @@ (defun draw-notes (pane notes dots notehead) (loop for note in notes do - (draw-note pane note notehead dots (final-xposition note) (note-position note)))) + (draw-note pane note notehead dots (final-xoffset note) (note-position note)))) ;;; given a group of notes (i.e. a list of notes, all displayed on the ;;; same staff, compute their final x offsets. This is a question of @@ -527,14 +534,14 @@ ;;; the stem. The head-note of the stem goes to the left of an ;;; up-stem and to the right of a down-stem. The x offset of a cluster ;;; gives the x position of the head-note. -(defun compute-final-xpositions (group x direction) +(defun compute-final-relative-xoffsets (group direction) (setf group (sort (copy-list group) (if (eq direction :up) (lambda (x y) (< (note-position x) (note-position y))) (lambda (x y) (> (note-position x) (note-position y)))))) (score-pane:with-suspended-note-offset offset ;; the first element of the group is the head-note - (setf (final-xposition (car group)) x) + (setf (final-relative-xoffset (car group)) 0) ;; OFFSET is a positive quantity that determines the ;; absolute difference between the x offset of a suspended ;; note and that of a normally positioned note. @@ -546,7 +553,7 @@ ;; if adjacent notes are just one staff step apart, ;; then one must be suspended. (dx (if (= (abs (- pos old-pos)) 1) offset 0))) - (setf (final-xposition note) (+ x dx)) + (setf (final-relative-xoffset note) dx) ;; go back to ordinary offset (when (= (abs (- pos old-pos)) 1) (setf note old-note)))))) @@ -563,7 +570,7 @@ (accidentals note))))) (defun element-has-suspended-notes (element) - (not (apply #'= (mapcar #'final-xposition (notes element))))) + (not (apply #'= (mapcar #'final-relative-xoffset (notes element))))) ;;; table of x offsets (in staff steps) of accendentals. ;;; The first index represents a notehead or a type of accidental. @@ -649,7 +656,7 @@ :notehead)) (pos2 (note-position note2)) (xpos2 (or (accidental-position note2) - (final-xposition note2)))) + (final-xoffset note2)))) (- xpos2 (* staff-step (accidental-distance acc1 pos1 acc2 pos2))))) ;;; given a note and a list of notes, compute x offset of the accidental @@ -686,7 +693,7 @@ ;; i.e., one to the right of the stem, then the accidental of the topmost ;; suspended note is placed first. (let ((first-suspended-note - (find x notes-with-accidentals :test #'/= :key #'final-xposition))) + (find x notes-with-accidentals :test #'/= :key #'final-relative-xoffset))) (when first-suspended-note (setf notes-with-accidentals (remove first-suspended-note notes-with-accidentals)) @@ -729,7 +736,7 @@ (score-pane:with-vertical-score-position (pane stem-yoffset) (draw-flags pane element x direction stem-pos))) (loop for group in groups do - (compute-final-xpositions group x direction) + (compute-final-relative-xoffsets group direction) (compute-final-accidentals group) (compute-final-accidental-positions group x direction) (draw-notes pane group (dots element) (notehead element))

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp
by rstrandh＠common-lisp.net 17 Nov '05

17 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv8113 Modified Files: drawing.lisp Log Message: continue the restructuring of drawing.lisp Date: Fri Nov 18 03:49:43 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.21 gsharp/drawing.lisp:1.22 --- gsharp/drawing.lisp:1.21 Fri Nov 18 02:59:27 2005 +++ gsharp/drawing.lisp Fri Nov 18 03:49:43 2005 @@ -217,7 +217,7 @@ (t n2))) notes)) -;;; compute and store several important pieces of information +;;; Compute and store several important pieces of information ;;; about an element: ;;; * the position, in staff steps of the top note. ;;; * the position, in staff steps of the bottom note. @@ -230,7 +230,7 @@ (setf (top-note-pos element) 4 (bot-note-pos element) 4))) -;;; compute and store several important pieces of information +;;; Compute and store several important pieces of information ;;; about an element: ;;; * the y-offset of the staff containing the top note. ;;; * the y-offset of the staff containing the bottom note. @@ -244,6 +244,8 @@ (top-note-staff-yoffset element) 0 (bot-note-staff-yoffset element) 0))) +;;; Compute and store the final stem direction of an element that is +;;; not beamed together with any other elements. (defun compute-stem-direction (element) (setf (final-stem-direction element) (if (or (eq (stem-direction element) :up) (eq (stem-direction element) :down)) @@ -304,11 +306,6 @@ (+ top-note-pos length) (- bot-note-pos length))))) -(defun compute-appearance (element) - (when (typep element 'cluster) - (compute-stem-direction element) - (compute-stem-length element))) - (defun compute-element-x-positions (bar x time-alist) (let (;;(time-alist (time-alist bar)) (start-time 0)) @@ -320,12 +317,16 @@ (incf start-time (duration element))) (elements bar)))) +;;; Compute and store the final stem directions of all the elements of +;;; a beam group with at least two elements in it. (defun compute-stem-directions (elements) - (if (not (eq (stem-direction (car elements)) :auto)) - (stem-direction (car elements)) - (let ((top-note-pos (reduce #'max elements :key #'top-note-pos)) - (bot-note-pos (reduce #'min elements :key #'bot-note-pos))) - (if (>= (- top-note-pos 4) (- 4 bot-note-pos)) :down :up)))) + (let ((stem-direction (if (not (eq (stem-direction (car elements)) :auto)) + (stem-direction (car elements)) + (let ((top-note-pos (reduce #'max elements :key #'top-note-pos)) + (bot-note-pos (reduce #'min elements :key #'bot-note-pos))) + (if (>= (- top-note-pos 4) (- 4 bot-note-pos)) :down :up))))) + (loop for element in elements + do (setf (final-stem-direction element) stem-direction)))) ;;; the dominating note among a bunch of notes is the ;;; one that is closest to the beam, i.e. the one @@ -348,14 +349,28 @@ (if (< (pitch n1) (pitch n2)) n1 n2)))))) notes)) -(defun draw-beam-group (pane elements) +;;; Given a list of elements to be beamed together, for each element, +;;; compute the top and bottom note position, and the final stem +;;; direction. +(defun compute-positions-and-stem-direction (elements) (mapc #'compute-top-bot-pos elements) + (if (null (cdr elements)) + (let ((element (car elements))) + (when (or (typep element 'rest) (notes element)) + (when (typep element 'cluster) + (compute-stem-direction element)))) + (compute-stem-directions elements))) + +(defun draw-beam-group (pane elements) (mapc #'compute-top-bot-yoffset elements) (if (null (cdr elements)) - (when (or (typep (car elements) 'rest) (notes (car elements))) - (compute-appearance (car elements)) - (draw-element pane (car elements) (element-xpos (car elements)))) - (let* ((stem-direction (compute-stem-directions elements)) + (let ((element (car elements))) + (when (or (typep element 'rest) (notes element)) + (when (typep element 'cluster) + (compute-stem-direction element) + (compute-stem-length element)) + (draw-element pane element (element-xpos element)))) + (let* ((stem-direction (final-stem-direction (car elements))) (dominating-notes (mapcar (lambda (e) (dominating-note (notes e) stem-direction)) elements)) @@ -370,8 +385,6 @@ (/ (element-xpos element) (score-pane:staff-step 1))) elements)) (beaming (beaming-single (mapcar #'list positions x-positions) stem-direction))) - (loop for element in elements do - (setf (final-stem-direction element) stem-direction)) (destructuring-bind ((ss1 . offset1) (ss2 . offset2)) beaming (let* ((y1 (+ ss1 (* 1/2 offset1))) (y2 (+ ss2 (* 1/2 offset2))) @@ -424,7 +437,8 @@ (defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor) (compute-element-x-positions bar x time-alist) (loop for group in (beam-groups (elements bar)) - do (draw-beam-group pane group)) + do (compute-positions-and-stem-direction group) + (draw-beam-group pane group)) (when (eq (cursor-bar *cursor*) bar) (let ((elements (elements bar))) (if (null (cursor-element *cursor*)) @@ -537,6 +551,9 @@ (when (= (abs (- pos old-pos)) 1) (setf note old-note)))))) +;;; Given a list of notes to be displayed on the same staff line, for +;;; each note, compute the accidental to be displayed as a function of +;;; the accidentals of the note and the key signature of the staff. (defun compute-final-accidentals (group) (loop for note in group do (setf (final-accidental note)

1 0

[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/measure.lisp
by rstrandh＠common-lisp.net 17 Nov '05

17 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv3504 Modified Files: drawing.lisp measure.lisp Log Message: Prepare for a separation of the functionality in drawing.lisp into two parts: 1. A part that computes stem directions and x offsets of notes and accidentals relative to the x offset of the element. These computations will be used to determine physical widths of elements. 2. A part that computes exact x and y positions, beam slants, etc. for the final drawing phase. The first part will precede the line-breaking phase, so that the line-breaking algorithm can take physical widths into account. Date: Fri Nov 18 02:59:27 2005 Author: rstrandh Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.20 gsharp/drawing.lisp:1.21 --- gsharp/drawing.lisp:1.20 Tue Nov 15 19:49:52 2005 +++ gsharp/drawing.lisp Fri Nov 18 02:59:27 2005 @@ -221,19 +221,26 @@ ;;; about an element: ;;; * the position, in staff steps of the top note. ;;; * the position, in staff steps of the bottom note. +(defun compute-top-bot-pos (element) + (if (and (typep element 'cluster) (notes element)) + (let ((top-note (top-note (notes element))) + (bot-note (bot-note (notes element)))) + (setf (top-note-pos element) (note-position top-note) + (bot-note-pos element) (note-position bot-note))) + (setf (top-note-pos element) 4 + (bot-note-pos element) 4))) + +;;; compute and store several important pieces of information +;;; about an element: ;;; * the y-offset of the staff containing the top note. ;;; * the y-offset of the staff containing the bottom note. -(defun compute-top-bot-pos-yoffset (element) +(defun compute-top-bot-yoffset (element) (if (and (typep element 'cluster) (notes element)) (let ((top-note (top-note (notes element))) (bot-note (bot-note (notes element)))) - (setf (top-note-pos element) (note-position top-note) - (bot-note-pos element) (note-position bot-note) - (bot-note-staff-yoffset element) (staff-yoffset (staff bot-note)) + (setf (bot-note-staff-yoffset element) (staff-yoffset (staff bot-note)) (top-note-staff-yoffset element) (staff-yoffset (staff top-note)))) - (setf (top-note-pos element) 4 - (bot-note-pos element) 4 - ;; clearly wrong. should be taken from element or layer. + (setf ;; clearly wrong. should be taken from element or layer. (top-note-staff-yoffset element) 0 (bot-note-staff-yoffset element) 0))) @@ -342,7 +349,8 @@ notes)) (defun draw-beam-group (pane elements) - (mapc #'compute-top-bot-pos-yoffset elements) + (mapc #'compute-top-bot-pos elements) + (mapc #'compute-top-bot-yoffset elements) (if (null (cdr elements)) (when (or (typep (car elements) 'rest) (notes (car elements))) (compute-appearance (car elements)) @@ -399,10 +407,11 @@ (defun draw-cursor (pane x) (draw-line* pane x (- (score-pane:staff-step -4)) x (- (score-pane:staff-step 12)) :ink +red+)) -(defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor) - (compute-element-x-positions bar x time-alist) - (let ((elements (elements bar)) - (group '())) +;;; Given a list of the elements of a bar, return a list of beam +;;; groups, where each beam group is a list of elements that are +;;; beamed together +(defun beam-groups (elements) + (let ((group '())) (loop while (not (null elements)) do (setf group '()) (push (pop elements) group) @@ -410,7 +419,12 @@ (> (rbeams (car group)) 0) (> (lbeams (car elements)) 0)) do (push (pop elements) group)) - (draw-beam-group pane (nreverse group)))) + collect (nreverse group)))) + +(defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor) + (compute-element-x-positions bar x time-alist) + (loop for group in (beam-groups (elements bar)) + do (draw-beam-group pane group)) (when (eq (cursor-bar *cursor*) bar) (let ((elements (elements bar))) (if (null (cursor-element *cursor*)) Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.7 gsharp/measure.lisp:1.8 --- gsharp/measure.lisp:1.7 Thu Nov 17 01:42:42 2005 +++ gsharp/measure.lisp Fri Nov 18 02:59:27 2005 @@ -28,13 +28,13 @@ (defmethod duration :around ((element relement)) (with-slots (duration) element - (when (or (modified-p element) (null duration)) - (setf duration (call-next-method)) - (setf (modified-p element) nil)) + (when (null duration) + (setf duration (call-next-method))) duration)) (defmethod mark-modified ((element relement)) - (setf (modified-p element) t) + (setf (modified-p element) t + (slot-value element 'duration) nil) (when (bar element) (mark-modified (bar element))))

1 0

[gsharp-cvs] CVS update: gsharp/Fonts/whole_rest.mf
by crhodes＠common-lisp.net 17 Nov '05

17 Nov '05

Update of /project/gsharp/cvsroot/gsharp/Fonts In directory common-lisp.net:/tmp/cvs-serv25553/Fonts Modified Files: whole_rest.mf Log Message: make the whole (semibreve) rest hang from the second-line down. Date: Thu Nov 17 17:27:35 2005 Author: crhodes Index: gsharp/Fonts/whole_rest.mf diff -u gsharp/Fonts/whole_rest.mf:1.1.1.1 gsharp/Fonts/whole_rest.mf:1.2 --- gsharp/Fonts/whole_rest.mf:1.1.1.1 Mon Feb 16 16:46:36 2004 +++ gsharp/Fonts/whole_rest.mf Thu Nov 17 17:27:35 2005 @@ -2,9 +2,10 @@ begin_character(whole_rest) - fill unitsquare shifted (-0.5, -1) + fill unitsquare shifted (-0.5, 0) xscaled notehead_width yscaled (0.5 * staff_line_distance) + shifted (0, 0.5 * staff_line_distance) shifted (xoffset, yoffset) scaled magnification; @@ -12,9 +13,10 @@ begin_character(whole_rest_light) - fill unitsquare shifted (-0.5, -1) + fill unitsquare shifted (-0.5, 0) xscaled notehead_width yscaled (0.5 * staff_line_distance) + shifted (0, 0.5 * staff_line_distance) shifted (xoffset, yoffset) scaled magnification;

1 0

[gsharp-cvs] CVS update: gsharp/measure.lisp
by rstrandh＠common-lisp.net 16 Nov '05

16 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv21978 Modified Files: measure.lisp Log Message: Finished (?) adding comments to measure.lisp. Date: Thu Nov 17 01:42:42 2005 Author: rstrandh Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.6 gsharp/measure.lisp:1.7 --- gsharp/measure.lisp:1.6 Wed Nov 16 20:44:52 2005 +++ gsharp/measure.lisp Thu Nov 17 01:42:42 2005 @@ -349,14 +349,19 @@ (mark-modified (buffer segment)))) ;;; temporary stuff +;;; call fun on every list of measures (which make up a line) +;;; in the buffer (defun new-map-over-obseq-subsequences (fun buf) (loop with m = (obseq-interval buf (buffer-pos buf 0 0)) while m do (multiple-value-bind (left right) + ;; find the end points of the interval that contains m (obseq-interval buf m) (funcall fun (loop for mm = left then (obseq-next buf mm) collect mm until (eq mm right))) + ;; move to the next measure after the rightmost one + ;; in the current line (setf m (obseq-next buf right))))) (defun buffer-cost-method (buffer) @@ -364,6 +369,7 @@ (defmethod recompute-measures ((buffer rbuffer)) (when (modified-p buffer) + ;; for now, invalidate everything (mapc #'adjust-lowpos-highpos (segments buffer)) ;; initialize cost method from buffer-specific style parameters (setf (obseq-cost-method buffer) @@ -377,6 +383,8 @@ ;;; ;;; Cost functions +;;; As required by the obseq library, define a cost method +;;; that is passed to the cost-comparison methods. (defclass measure-cost-method (cost-method) (;; the min width is taken from the min width of the buffer (min-width :initarg :min-width :reader min-width) @@ -391,11 +399,15 @@ :spacing-style spacing-style :line-width line-width)) +;;; As required by the obseq library, define a sequence cost, i.e., in +;;; this case the cost of a sequece of measures. (defclass measure-seq-cost (seq-cost) ((min-dist :initarg :min-dist :reader min-dist) (coeff :initarg :coeff :reader coeff) (nb-measures :initarg :nb-measures :reader nb-measures))) +;;; As required by the obseq library, define a total cost, i.e., in +;;; this case the cost of a sequece of sequences of measures. (defclass measure-total-cost (total-cost) ((cost :initarg :cost :reader measure-total-cost))) @@ -406,6 +418,15 @@ (print-unreadable-object (obj stream :identity t :type t) (format stream "~D" (measure-total-cost obj)))) +;;; As required by the obseq library, this method computes the +;;; combined cost of a sequence of measures by taking the existing +;;; cost of all but the last measures and combining it with the +;;; characteristics of the last measure. The result is a sequence +;;; cost that has the sum of the coefficients of each measure in the +;;; sequence, the min of the min-dists of each measure in the +;;; sequence, and the total number of measures in the sequence. +;;; As far as Gsharp is concerned, this cost computation is +;;; commutable, so rely on Obseq to supply the symmetric method. (defmethod combine-cost ((method measure-cost-method) (seq-cost measure-seq-cost) (elem measure)) @@ -414,6 +435,17 @@ :min-dist (min (min-dist seq-cost) (measure-min-dist elem)) :nb-measures (1+ (nb-measures seq-cost)))) +;;; As required by the obseq library, this method computes the +;;; combined cost of a sequence of sequences of measures by taking the +;;; existing cost of all but the last sequences of measures and +;;; combining it with the sequence cost of the last sequence of +;;; measures. The result is a total cost that has the max of the cost +;;; of each individual sequence of measures. The reason for using the +;;; max is that we do not want for a good line to be able to +;;; compensate for the badness of another. We thus compute the score +;;; that minimizes the maximum of the badness of each line. As far as +;;; Gsharp is concerned, this cost computation is commutable, so rely +;;; on Obseq to supply the symmetric method. (defmethod combine-cost ((method measure-cost-method) (tcost measure-total-cost) (seq-cost measure-seq-cost)) @@ -428,6 +460,8 @@ :cost (measure-seq-cost method seq-cost))) +;;; As required by the obseq library, this method computes the +;;; sequence cost of a singleton sequence. (defmethod combine-cost ((method measure-cost-method) (elem measure) (whatever (eql nil))) @@ -436,11 +470,21 @@ :min-dist (measure-min-dist elem) :nb-measures 1)) +;;; As required by the obseq library, this method computes the +;;; sequence cost of a singleton sequence. (defmethod combine-cost ((method measure-cost-method) (whatever (eql nil)) (elem measure)) (combine-cost method elem nil)) +;;; The reduced width of a sequence of measures is the sum of the +;;; widths of the measures in the sequence, but ignoring the space +;;; before first timeline. If the min-dist is 0 (which I think is the +;;; case if each measure has no timelines), then the reduced width is +;;; 0, otherwise we obtain the reduced width by multiplying the sum of +;;; the coefficients of each mesure in the sequence, the min-width to +;;; use for the display, and (1/d_min)^k, where d_min is the duration +;;; of the shortest timeline, and k is the spacing style. (defmethod reduced-width ((method measure-cost-method) (seq-cost measure-seq-cost)) (if (zerop (min-dist seq-cost)) @@ -448,42 +492,54 @@ (* (coeff seq-cost) (min-width method) (expt (/ (min-dist seq-cost)) (spacing-style method))))) +;;; The natural width of a sequence of mesures is like the reduced +;;; width, except that we do not ignore the space before the first +;;; timeline in each measure. That space might be necessary to +;;; parameterize one day, but for now we just use the w_min. (defmethod natural-width ((method measure-cost-method) (seq-cost measure-seq-cost)) (+ (reduced-width method seq-cost) (* (nb-measures seq-cost) (min-width method)))) +;;; The compress factor indicates how by how much a sequence of +;;; measures must be compressed in order to fit the line width at our +;;; disposal. Values > 1 indicate that the sequence of mesures must +;;; be stretched instead of compressed. (defmethod compress-factor ((method measure-cost-method) (seq-cost measure-seq-cost)) (/ (natural-width method seq-cost) (line-width method))) +;;; As far as Gsharp is concerned, we define the cost of a sequence of +;;; measures as the max of the compress factor and its inverse. In +;;; other words, we consider it as bad to have to stretch a line by x% +;;; as it is to have to compress it by x%, and the more we have to +;;; compress or expand it, the worse it is. This way of doing it is +;;; not great. At some point, we need to severely penalize compressed +;;; lines that become too short to display without overlaps, unless +;;; the line contains a single measure, of course. (defmethod measure-seq-cost ((method measure-cost-method) (seq-cost measure-seq-cost)) (let ((c (compress-factor method seq-cost))) (max c (/ c)))) +;;; As required by the obseq library, we define a method that +;;; determines whether we can prove that adding another measure to an +;;; existing sequence is guaranteed to make the cost of the sequence +;;; higher. The obseq library uses this to radically diminish the +;;; complexity of the computation. (defmethod seq-cost-cannot-decrease ((method measure-cost-method) (seq-cost measure-seq-cost)) (>= (natural-width method seq-cost) (line-width method))) +;;; Compare the cost of two sequences of measures (defmethod cost-less ((method measure-cost-method) (c1 measure-seq-cost) (c2 measure-seq-cost)) (< (measure-seq-cost method c1) (measure-seq-cost method c2))) +;;; Compare the cost of two sequences of sequences of measures (defmethod cost-less ((method measure-cost-method) (c1 measure-total-cost) (c2 measure-total-cost)) (< (measure-total-cost c1) (measure-total-cost c2))) - -(defmethod cost-less ((method measure-cost-method) - (c1 measure-seq-cost) - (c2 measure-seq-cost)) - (< (measure-seq-cost method c1) (measure-seq-cost method c2))) - -(defmethod cost-less ((method measure-cost-method) - (c1 measure-total-cost) - (c2 measure-total-cost)) - (< (measure-total-cost c1) (measure-total-cost c2))) -

1 0

[gsharp-cvs] CVS update: gsharp/measure.lisp
by rstrandh＠common-lisp.net 16 Nov '05

16 Nov '05

Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv32077 Modified Files: measure.lisp Log Message: More comments to improve maintainability. Date: Wed Nov 16 20:44:52 2005 Author: rstrandh Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.5 gsharp/measure.lisp:1.6 --- gsharp/measure.lisp:1.5 Wed Nov 16 02:27:34 2005 +++ gsharp/measure.lisp Wed Nov 16 20:44:52 2005 @@ -125,26 +125,30 @@ ;;; ;;; Measure -;;; A measure represents the set of simultaneous bars. -;;; Define a TIMELINE of a measure to be the set of all -;;; simultaneous elements of the bars of the measure. -;;; The DURATION of a timeline is either the distance to -;;; the next closest timeline following it, or, in case -;;; it is the last timeline of the measure, the duration -;;; of the longest element of the timeline. +;;; A measure represents the set of simultaneous bars. Define a +;;; TIMELINE of a measure to be the set of all simultaneous elements +;;; of the bars of the measure. The DURATION of a timeline is either +;;; the temporal distance to the next closest timeline following it, +;;; or, in case it is the last timeline of the measure, the duration +;;; of the longest element of the timeline. (defclass measure (obseq-elem) - (;; the smallest temporal distance between either two adjacent - ;; timelines in the measure or between the last timeline - ;; and the end of the mesure. The temporal distance between - ;; the last timeline and the end of the measure is the same - ;; as the duration of the longest element of the last timeline. + (;; the smallest duration of any timeline in the measure (min-dist :initarg :min-dist :reader measure-min-dist) - ;; the coefficient of a measure is the sum of + ;; the coefficient of a measure is the sum of d_i^k where d_i + ;; is the duration of the i:th timeline, and k is the spacing style (coeff :initarg :coeff :reader measure-coeff) + ;; a list of unique rational numbers, sorted by increasing numeric value, + ;; of the start time of the time lines of the measure (start-times :initarg :start-times :reader measure-start-times) + ;; the position of a measure in the sequence of measures + ;; of a buffer is indicated by two numbers, the position + ;; of the segment to which the measure belongs within the + ;; sequence of segments of the buffer, and the position of + ;; the bars within that segment. (seg-pos :initarg :seg-pos :reader measure-seg-pos) (bar-pos :initarg :bar-pos :reader measure-bar-pos) + ;; a list of the bars that make up this measure (bars :initarg :bars :reader measure-bars))) (defun make-measure (min-dist coeff start-times seg-pos bar-pos bars) @@ -179,6 +183,8 @@ (defun adjust-lowpos-highpos (segment) (when (modified-p segment) (let ((buffer (buffer segment))) + ;; Do this better. Now, we essentially tell the obseq library + ;; that every measure in the entire buffer has been damaged. (obseq-first-undamaged-element buffer nil) (obseq-last-undamaged-element buffer nil)))) @@ -190,34 +196,63 @@ (defmethod nb-measures ((segment rsegment)) (length (measures segment))) +;;; Given a segment and a position, return the measure in that +;;; position in the sequence of measures in the segment. (defmethod measureno ((segment rsegment) position) (elt (measures segment) position)) -;;; convert a list of durations to a list of start times +;;; Convert a list of durations to a list of start times +;;; by accumulating values starting at zero. +;;; The list returned has the same length as the one passed +;;; as argument, which we obtain by treating the first element +;;; as the initial start time. Doing so makes it possible to compute +;;; the inverse of this transformation. (defun rel-abs (list) (loop with acc = 0 for elem in list collect (incf acc elem))) -;;; convert a list of start times to a list of durations +;;; Convert a list of start times to a list of durations +;;; by computing the differences beteen adjacent elements. +;;; The list returned has the same length as the one passed +;;; as argument, which we obtain by including the first +;;; element unchanged. Doing so makes it possible to compute +;;; the inverse of this transformation. (defun abs-rel (list) (loop with prev = 0 for elem in list collect (- elem prev) do (setf prev elem))) +;;; Compute the start times of the elements of the bar. The last +;;; element is the "start time" of the end of the bar. Currently, we +;;; do not handle zero-duration bars very well. For that reason, when +;;; there are no elements in the bar, we return the list of a single +;;; number 1. This is clearly wrong, so we need to figure out a +;;; better way of doing that. (defun start-times (bar) (let ((elements (elements bar))) (if elements (rel-abs (mapcar #'duration elements)) '(1)))) -;;; treat the last start time (which is really the duration of the +;;; Combine the list of start times of two bars into a single list +;;; of start times. Don't worry about duplicated elements which will +;;; be removed ultimately. +;;; Treat the last start time (which is really the duration of the ;;; bar) specially and only keep the largest one (defun combine-bars (bar1 bar2) (append (merge 'list (butlast bar1) (butlast bar2) #'<) (list (max (car (last bar1)) (car (last bar2)))))) +;;; From a list of simultaneous bars (and some other stuff), create a +;;; measure. The `other stuff' is the spacing style, which is neded +;;; in order to compute the coefficient of the measure, the position +;;; of the segment to which the bars belong in the sequence of +;;; segments of the buffer, and the position of the bars in the +;;; sequence of bars within that segment. The last two items are used +;;; to indicate the position of the measure in the sequence of all +;;; measures of the buffer. (defun compute-measure (bars spacing-style seg-pos bar-pos) (let* ((start-times (remove-duplicates (reduce #'combine-bars @@ -228,6 +263,8 @@ sum (expt duration spacing-style)))) (make-measure min-dist coeff start-times seg-pos bar-pos bars))) +;;; Compute all the measures of a segment by stepping through all the +;;; bars in parallel as long as there is at least one simultaneous bar. (defun compute-measures (segment spacing-style) (setf (slot-value segment 'measures) (loop for all-bars on (mapcar (lambda (layer) (bars (body layer))) @@ -246,11 +283,21 @@ (define-added-mixin rbuffer (obseq) buffer ((modified-p :initform t :accessor modified-p))) +;;; Given a buffer, a position of a segment in the sequence of +;;; segments of the buffer, and a position of a measure within that +;;; segment, return the corresponding measure. (defmethod buffer-pos ((buffer rbuffer) seg-pos bar-pos) (if (or (<= seg-pos -1) (>= seg-pos (nb-segments buffer))) nil (measureno (segmentno buffer seg-pos) bar-pos))) +;;; as required by the obseq library, we supply a method on this +;;; generic function. When we are given a measure other than the last +;;; one in the segment, return the next one in the segment. When we +;;; are given the last measure in a segment which is not the last one, +;;; return the first measure in the following segment. When we are +;;; given the last measure of the last segment, return nil as required +;;; by the obseq library. (defmethod obseq-next ((buf buffer) (measure measure)) (let ((seg-pos (measure-seg-pos measure)) (bar-pos (measure-bar-pos measure))) @@ -260,9 +307,19 @@ (buffer-pos buf (1+ seg-pos) 0)) (t nil)))) +;;; as required by the obseq library, we supply a method on this +;;; generic function specialized on NIL, for which the first measure +;;; of the first segment is returned. (defmethod obseq-next ((buf buffer) (measure (eql nil))) (measureno (segmentno buf 0) 0)) +;;; as required by the obseq library, we supply a method on this +;;; generic function. When we are given a measure other than the first +;;; one in the segment, return the previous one in the segment. When we +;;; are given the first measure in a segment which is not the first one, +;;; return the last measure in the preceding segment. When we are +;;; given the first measure of the first segment, return nil as required +;;; by the obseq library. (defmethod obseq-prev ((buf buffer) (measure measure)) (let ((seg-pos (measure-seg-pos measure)) (bar-pos (measure-bar-pos measure))) @@ -272,6 +329,9 @@ (1- (nb-measures (segmentno buf (1- seg-pos)))))) (t nil)))) +;;; as required by the obseq library, we supply a method on this +;;; generic function specialized on NIL, for which the last measure +;;; of the last segment is returned. (defmethod obseq-prev ((buf buffer) (measure (eql nil))) (buffer-pos buf (1- (nb-segments buf))

1 0

[gsharp-cvs] CVS update: gsharp/Flexichain/flexichain.lisp
by rstrandh＠common-lisp.net 16 Nov '05

16 Nov '05

Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv27532 Modified Files: flexichain.lisp Log Message: Fixed a bug that made :initial-contents not work properly. Date: Wed Nov 16 19:33:10 2005 Author: rstrandh Index: gsharp/Flexichain/flexichain.lisp diff -u gsharp/Flexichain/flexichain.lisp:1.7 gsharp/Flexichain/flexichain.lisp:1.8 --- gsharp/Flexichain/flexichain.lisp:1.7 Wed Nov 16 04:06:59 2005 +++ gsharp/Flexichain/flexichain.lisp Wed Nov 16 19:33:10 2005 @@ -176,7 +176,7 @@ initial-contents fill-list))))) (with-slots (gap-start gap-end data-start) chain - (setf gap-start 2 + (setf gap-start (+ 2 (length initial-contents)) gap-end 0 data-start 1)))

1 0