[gsharp-cvs] CVS gsharp
rstrandh
rstrandh at common-lisp.net
Mon Jun 12 18:25:32 UTC 2006
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv17945
Modified Files:
drawing.lisp measure.lisp packages.lisp
Log Message:
Page break modifications.
--- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/03/26 19:28:17 1.67
+++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/12 18:25:32 1.68
@@ -352,55 +352,148 @@
(loop for measure in measures do
(draw-measure pane measure))))
+(defun draw-staves (pane staves x y right-edge)
+ (loop for staff in staves do
+ (score-pane:with-vertical-score-position
+ (pane (+ y (staff-yoffset staff)))
+ (if (member staff (staves (layer (slice (bar *cursor*)))))
+ (draw-staff-and-clef pane staff x right-edge)
+ (score-pane:with-light-glyphs pane
+ (draw-staff-and-clef pane staff x right-edge))))))
+
+
+(defun compute-and-draw-system (pane buffer staves measures method x y timesig-offset right-edge)
+ (compute-elasticities measures method)
+ (compute-gaps measures method pane)
+ (let* ((e-fun (compute-elasticity-functions measures method pane))
+ ;; FIXME: it would be much better to compress the system
+ ;; proportionally, so that every smallest gap gets shrunk
+ ;; by the same percentage
+ (force (if (> (zero-force-size e-fun) (line-width method))
+ 0
+ (force-at-size e-fun (line-width method)))))
+ (compute-system-coordinates measures
+ (+ x (left-offset buffer) timesig-offset) y
+ force))
+ (draw-system pane measures)
+ (score-pane:draw-bar-line pane x
+ (+ y (- (score-pane:staff-step 8)))
+ (+ y (staff-yoffset (car (last staves)))))
+ (draw-staves pane staves x y right-edge))
+
+(defun compute-timesig-offset (staves)
+ (max (* (score-pane:staff-step 2)
+ (loop for staff in staves
+ maximize
+ (if (typep staff 'fiveline-staff)
+ (count :flat (alterations (keysig staff)))
+ 0)))
+ (* (score-pane:staff-step 2.5)
+ (loop for staff in staves
+ maximize
+ (if (typep staff 'fiveline-staff)
+ (count :sharp (alterations (keysig staff)))
+ 0)))))
+
+(defun split (sequence n method)
+ (labels ((sequence-size (start end)
+ (natural-width method
+ (reduce (lambda (seq-cost element)
+ (combine-cost method seq-cost element))
+ sequence :start start :end end
+ :initial-value nil)))
+ (split-aux (sequence start end n)
+ (if (= n 1)
+ (let ((width (sequence-size start end)))
+ (values (list (subseq sequence start end)) width width))
+ (let* ((nn (floor n 2))
+ (m (floor (* (- end start) nn) n)))
+ (multiple-value-bind (best-left minl maxl)
+ (split-aux sequence start (+ start m) nn)
+ (multiple-value-bind (best-right minr maxr)
+ (split-aux sequence (+ start m) end (- n nn))
+ (let* ((best-min (min minl minr))
+ (best-max (max maxl maxr))
+ (best-cost (/ (- best-max best-min) 2))
+ (best-splits (append best-left best-right)))
+ (cond ((and (< minl minr)
+ (< maxl maxr))
+ (loop do (incf m)
+ while (and (< minl minr)
+ (< maxl maxr)
+ (< m (- end start)))
+ do (multiple-value-bind (left new-minl new-maxl)
+ (split-aux sequence start (+ start m) nn)
+ (multiple-value-bind (right new-minr new-maxr)
+ (split-aux sequence (+ start m) end (- n nn))
+ (setf minl new-minl
+ maxl new-maxl
+ minr new-minr
+ maxr new-maxr)
+ (let ((cost (/ (- (max maxl maxr) (min minl minr)) 2)))
+ (when (< cost best-cost)
+ (setf best-min (min minl minr)
+ best-max (max maxl maxr)
+ best-cost cost
+ best-splits (append left right))))))))
+ ((and (> minl minr)
+ (> maxl maxr))
+ (loop do (decf m)
+ while (and (> minl minr)
+ (> maxl maxr)
+ (> m 0))
+ do (multiple-value-bind (left new-minl new-maxl)
+ (split-aux sequence start (+ start m) nn)
+ (multiple-value-bind (right new-minr new-maxr)
+ (split-aux sequence (+ start m) end (- n nn))
+ (setf minl new-minl
+ maxl new-maxl
+ minr new-minr
+ maxr new-maxr)
+ (let ((cost (/ (- (max maxl maxr) (min minl minr)) 2)))
+ (when (< cost best-cost)
+ (setf best-min (min minl minr)
+ best-max (max maxl maxr)
+ best-cost cost
+ best-splits (append left right)))))))))
+ (values best-splits best-min best-max))))))))
+ (split-aux sequence 0 (length sequence) n)))
+
+
+
+
+
+(defun layout-page (measures n method)
+ (if (<= (length measures) n)
+ (mapcar #'list measures)
+ (split measures n method)))
+
(defmethod draw-buffer (pane (buffer buffer) *cursor* x y)
(score-pane:with-staff-size 6
(let* ((staves (staves buffer))
- (timesig-offset (max (* (score-pane:staff-step 2)
- (loop for staff in staves
- maximize
- (if (typep staff 'fiveline-staff)
- (count :flat (alterations (keysig staff)))
- 0)))
- (* (score-pane:staff-step 2.5)
- (loop for staff in staves
- maximize
- (if (typep staff 'fiveline-staff)
- (count :sharp (alterations (keysig staff)))
- 0)))))
+ (timesig-offset (compute-timesig-offset staves))
(method (let ((old-method (buffer-cost-method buffer)))
(make-measure-cost-method (min-width old-method)
(spacing-style old-method)
- (- (line-width old-method) timesig-offset))))
- (right-edge (right-edge buffer)))
+ (- (line-width old-method) timesig-offset)
+ (lines-per-page old-method))))
+ (right-edge (right-edge buffer))
+ (systems-per-page (max 1 (floor 12 (length staves)))))
(loop for staff in staves
for offset from 0 by 90 do
(setf (staff-yoffset staff) offset))
(let ((yy y))
(gsharp-measure::new-map-over-obseq-subsequences
- (lambda (measures)
- (compute-elasticities measures method)
- (compute-gaps measures method pane)
- (let* ((e-fun (compute-elasticity-functions measures method pane))
- ;; FIXME: it would be much better to compress the system
- ;; proportionally, so that every smallest gap gets shrunk
- ;; by the same percentage
- (force (if (> (zero-force-size e-fun) (line-width method))
- 0
- (force-at-size e-fun (line-width method)))))
- (compute-system-coordinates measures
- (+ x (left-offset buffer) timesig-offset) yy
- force))
- (draw-system pane measures)
- (score-pane:draw-bar-line pane x
- (+ yy (- (score-pane:staff-step 8)))
- (+ yy (staff-yoffset (car (last staves)))))
- (loop for staff in staves do
- (score-pane:with-vertical-score-position (pane yy)
- (if (member staff (staves (layer (slice (bar *cursor*)))))
- (draw-staff-and-clef pane staff x right-edge)
- (score-pane:with-light-glyphs pane
- (draw-staff-and-clef pane staff x right-edge))))
- (incf yy 90)))
+ (lambda (all-measures)
+ (when (member-if (lambda (measure) (member (bar *cursor*)
+ (measure-bars measure)
+ :test #'eq))
+ all-measures)
+ (let ((measure-seqs (layout-page all-measures systems-per-page method)))
+ (loop for measures in measure-seqs do
+ (compute-and-draw-system pane buffer staves measures
+ method x yy timesig-offset right-edge)
+ (incf yy (* 90 (length staves)))))))
buffer)))))
(define-added-mixin velement () melody-element
--- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/03/02 09:21:34 1.28
+++ /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/12 18:25:32 1.29
@@ -808,7 +808,8 @@
(setf (obseq-cost-method buffer)
(make-measure-cost-method
(min-width buffer) (spacing-style buffer)
- (- (right-edge buffer) (left-margin buffer) (left-offset buffer))))
+ (- (right-edge buffer) (left-margin buffer) (left-offset buffer))
+ (floor 12 (length (staves buffer)))))
(obseq-solve buffer)
(setf (modified-p buffer) nil)))
@@ -824,13 +825,16 @@
;; the spaceing style is taken from the spacing style of the buffer
(spacing-style :initarg :spacing-style :reader spacing-style)
;; the amount of horizontal space available to music material
- (line-width :initarg :line-width :reader line-width)))
+ (line-width :initarg :line-width :reader line-width)
+ ;; number of lines that will fit on a page
+ (lines-per-page :initarg :lines-per-page :reader lines-per-page)))
-(defun make-measure-cost-method (min-width spacing-style line-width)
+(defun make-measure-cost-method (min-width spacing-style line-width lines-per-page)
(make-instance 'measure-cost-method
:min-width min-width
:spacing-style spacing-style
- :line-width line-width))
+ :line-width line-width
+ :lines-per-page lines-per-page))
;;; As required by the obseq library, define a sequence cost, i.e., in
;;; this case the cost of a sequece of measures.
@@ -935,21 +939,22 @@
(* (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
+;;; measures must be compressed in order to fit the 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)))
+ (/ (natural-width method seq-cost)
+ (* (line-width method) (lines-per-page 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%
+;;; other words, we consider it as bad to have to stretch a sequence 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.
+;;; sequences that become too short to display without overlaps, unless
+;;; the sequence 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)))
--- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/05 00:53:40 1.54
+++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/12 18:25:32 1.55
@@ -90,7 +90,8 @@
#:keysig #:staff-pos #:xoffset #:read-everything
#:read-buffer-from-stream
#:key-signature #:alterations #:more-sharps #:more-flats
- #:line-width #:min-width #:spacing-style #:right-edge #:left-offset
+ #:line-width #:lines-per-page #:min-width #:spacing-style
+ #:right-edge #:left-offset
#:left-margin #:text #:append-char #:erase-char
#:tie-right #:tie-left
#:needs-saving))
More information about the Gsharp-cvs
mailing list