gsharp-cvs

gsharp-cvs@common-lisp.net

396 discussions

[gsharp-cvs] CVS gsharp
by rstrandh 14 Jun '06

14 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv31679 Modified Files: packages.lisp score-pane.lisp gui.lisp Log Message: Display page numbers in the info pane. --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/13 19:39:56 1.56 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/14 03:38:56 1.57 @@ -47,7 +47,7 @@ #:with-suspended-note-offset #:with-notehead-left-offsets #:with-light-glyphs #:score-pane #:clef #:staff #:fiveline-staff #:lyrics-staff #:notehead - #:score-view)) + #:score-view #:number-of-pages #:current-page-number)) (defpackage :gsharp-buffer (:use :common-lisp :gsharp-utilities :esa-buffer) --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/08 18:54:47 1.35 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/14 03:38:56 1.36 @@ -1,6 +1,8 @@ (in-package :score-pane) -(defclass score-view (view) ()) +(defclass score-view (view) + ((%number-of-pages :initform "-" :accessor number-of-pages) + (%current-page-number :initform "-" :accessor current-page-number))) (defclass score-pane (esa-pane-mixin application-pane) ()) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/13 19:39:56 1.65 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/14 03:38:56 1.66 @@ -54,6 +54,11 @@ (princ " " pane) (with-text-face (pane :bold) (format pane "~25A" (name buffer))) + (princ " " pane) + (format pane "[~a/~a]" + (score-pane:current-page-number view) + (score-pane:number-of-pages view)) + (princ " " pane) (with-text-family (pane :sans-serif) (princ (if (recordingp *application-frame*) "Def" @@ -109,7 +114,9 @@ (:top-level (esa-top-level))) (defmethod buffers ((application-frame gsharp)) - (remove-duplicates (mapcar #'buffer (views application-frame)) :test #'eq)) + (remove-duplicates (mapcar (lambda (window) (buffer (view window))) + (windows application-frame)) + :test #'eq)) (defmethod current-buffer ((application-frame gsharp)) (buffer (view (car (windows application-frame))))) @@ -161,9 +168,28 @@ for dx from (+ right 5) by 5 do (score-pane:draw-dot pane (+ xpos dx) 4))))))))) +(defun update-page-numbers (frame) + (loop for window in (windows frame) + do (let ((page-number 0) + (view (view window))) + (gsharp-measure::new-map-over-obseq-subsequences + (lambda (all-measures) + (incf page-number) + (when (member-if (lambda (measure) (member (bar (cursor view)) + (measure-bars measure) + :test #'eq)) + all-measures) + (setf (score-pane:current-page-number view) page-number))) + (buffer view)) + (setf (score-pane:number-of-pages view) page-number)))) + +(defmethod redisplay-frame-panes :before ((frame gsharp) &key force-p) + (declare (ignore force-p)) + (mapc #'recompute-measures (buffers frame)) + (update-page-numbers frame)) + (defmethod display-score ((frame gsharp) pane) (let* ((buffer (buffer (view pane)))) - (recompute-measures buffer) (score-pane:with-score-pane pane (draw-buffer pane buffer (current-cursor) (left-margin buffer) 100)

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 13 Jun '06

13 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv31399 Modified Files: gui.lisp modes.lisp packages.lisp Log Message: Implemented commands to go to the beginning and to the end of the score, bound to M-< and M-> respectively. --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/01 04:57:10 1.64 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/13 19:39:56 1.65 @@ -855,6 +855,26 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; motion by entire score + +(define-gsharp-command com-end-of-score () + (loop until (last-segment-p (current-cursor)) + do (forward-segment (current-cursor))) + (loop until (last-bar-p (current-cursor)) + do (forward-bar (current-cursor))) + (loop until (end-of-bar-p (current-cursor)) + do (forward-element (current-cursor)))) + +(define-gsharp-command com-beginning-of-score () + (loop until (first-segment-p (current-cursor)) + do (backward-segment (current-cursor))) + (loop until (first-bar-p (current-cursor)) + do (backward-bar (current-cursor))) + (loop until (beginning-of-bar-p (current-cursor)) + do (backward-element (current-cursor)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; delete commands (defun go-to-beginning-of-bar (cursor) --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/05 10:06:58 1.15 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/13 19:39:56 1.16 @@ -12,6 +12,9 @@ (set-key 'com-insert-measure-bar 'global-gsharp-table '(#\|)) +(set-key 'com-end-of-score 'global-gsharp-table '((#\> :shift :meta))) +(set-key 'com-beginning-of-score 'global-gsharp-table '((#\< :shift :meta))) + ;;; FIXME where are the corresponding commands? (set-key 'com-left 'global-gsharp-table '((#\l :meta))) (set-key 'com-right 'global-gsharp-table '((#\r :meta))) --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/12 18:25:32 1.55 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/13 19:39:56 1.56 @@ -150,6 +150,7 @@ #:head-slice #:body-slice #:tail-slice #:in-last-slice #:in-first-slice #:select-layer #:delete-layer + #:first-segment-p #:last-segment-p #:forward-segment #:backward-segment #:insert-segment-before #:insert-segment-after #:delete-segment

1 0

[gsharp-cvs] CVS gsharp/Scores
by rstrandh 13 Jun '06

13 Jun '06

Update of /project/gsharp/cvsroot/gsharp/Scores In directory clnet:/tmp/cvs-serv976 Added Files: bach-suite-iv-prelude.gsh Log Message: The beginning of English suite number 4 (prelude) by J.S. Bach. This score should eventually be around 7 pages, so it is a reasonable test for multi paging. --- /project/gsharp/cvsroot/gsharp/Scores/bach-suite-iv-prelude.gsh 2006/06/13 04:21:50 NONE +++ /project/gsharp/cvsroot/gsharp/Scores/bach-suite-iv-prelude.gsh 2006/06/13 04:21:50 1.1 G#V4 [GSHARP-BUFFER:BUFFER :min-width 17 :spacing-style 0.4 :right-edge 700 :left-offset 30 :left-margin 20 :staves (#1=[GSHARP-BUFFER:FIVELINE-STAFF :name "treble" :clef [GSHARP-BUFFER:CLEF :name :TREBLE :lineno 2 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #1# :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :FLAT) ] ] #2=[GSHARP-BUFFER:FIVELINE-STAFF :name "bass" :clef [GSHARP-BUFFER:CLEF :name :BASS :lineno 6 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #2# :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :FLAT) ] ]) :segments ([GSHARP-BUFFER:SEGMENT :layers ([GSHARP-BUFFER:MELODY-LAYER :name "bass" :staves (#2#) :head [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:MELODY-BAR :elements COMMON-LISP:NIL ]) ] :body [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #2# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 0 :dots 0 :staff #2# :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 21 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 22 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 23 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 24 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 25 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 26 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 24 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 27 :staff #2# :head :FILLED :accidentals :FLAT :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 27 :staff #2# :head :FILLED :accidentals :FLAT :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 26 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 25 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 27 :staff #2# :head :FILLED :accidentals :FLAT :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 26 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 1 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 24 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 31 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 31 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 31 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 32 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 1 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 26 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 29 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 29 :staff #2# [7397 lines skipped]

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 13 Jun '06

13 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv8603 Modified Files: drawing.lisp measure.lisp Log Message: Fixed a bug in the page breaking algorithm that made the page way to sparse. Fixed a bug in the page layout algorithm that made Gsharp attempt to divide the measures of a page into more lines than there are measures. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/12 18:25:32 1.68 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/13 01:18:10 1.69 @@ -421,7 +421,7 @@ (loop do (incf m) while (and (< minl minr) (< maxl maxr) - (< m (- end start))) + (>= (- end start m) (- n nn))) do (multiple-value-bind (left new-minl new-maxl) (split-aux sequence start (+ start m) nn) (multiple-value-bind (right new-minr new-maxr) @@ -441,7 +441,7 @@ (loop do (decf m) while (and (> minl minr) (> maxl maxr) - (> m 0)) + (>= m nn)) do (multiple-value-bind (left new-minl new-maxl) (split-aux sequence start (+ start m) nn) (multiple-value-bind (right new-minr new-maxr) --- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/12 18:25:32 1.29 +++ /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/13 01:18:10 1.30 @@ -968,7 +968,7 @@ (defmethod seq-cost-cannot-decrease ((method measure-cost-method) (seq-cost measure-seq-cost)) (>= (natural-width method seq-cost) - (line-width method))) + (* (line-width method) (lines-per-page method)))) ;;; Compare the cost of two sequences of measures (defmethod cost-less ((method measure-cost-method)

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 12 Jun '06

12 Jun '06

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))

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 08 Jun '06

08 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv13576 Modified Files: score-pane.lisp Log Message: Removed code that is no longer necessary because of the new font-rendering system. The class `score-pane' should probably be moved to gui.lisp, and the :score-pane package and the score-pane.lisp file should probably be renamed. Alternatively, the code could be moved elsewhere. --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 22:40:26 1.34 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/08 18:54:47 1.35 @@ -2,29 +2,15 @@ (defclass score-view (view) ()) -(defclass score-pane (esa-pane-mixin application-pane) - ((darker-gray-progressions :initform (make-array 10 :initial-element nil :adjustable t) - :reader darker-gray-progressions) - (lighter-gray-progressions :initform (make-array 10 :initial-element nil :adjustable t) - :reader lighter-gray-progressions))) +(defclass score-pane (esa-pane-mixin application-pane) ()) (defmethod initialize-instance :after ((pane score-pane) &rest args) (declare (ignore args)) (setf (stream-default-view pane) (make-instance 'score-view))) -(defparameter *light-glyph* nil) (defparameter *font* nil) (defparameter *fonts* (make-array 100 :initial-element nil)) -;;; Map integer levels of white, represented by the number of white pixels in -;;; a 4x4 pixel grid, to CLIM inks. -(defparameter *gray-levels* - (loop with result = (make-array '(17)) - for i from 0 to 16 do - (setf (aref result i) (make-gray-color (/ i 16))) - finally (return result))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; output recording @@ -384,89 +370,6 @@ (multiple-value-bind (down up) (beam-offsets *font*) (draw-rectangle* medium x1 (+ y up) x2 (+ y down)))) -(defvar *darker-gray-progressions*) -(defvar *lighter-gray-progressions*) - -;;; don't delete this yet, since I don't know how the other one will work out. -;; (defun ensure-gray-progressions (index) -;; (unless (aref *darker-gray-progressions* index) -;; (setf (aref *darker-gray-progressions* index) -;; (with-output-to-pixmap (medium *pane* :height 1 :width index) -;; (loop for i from 0 below index -;; for gray-level from 16 by (- (/ 16 index)) do -;; (draw-point* medium i 0 :ink (aref *gray-levels* (ceiling gray-level))))))) -;; (unless (aref *lighter-gray-progressions* index) -;; (setf (aref *lighter-gray-progressions* index) -;; (with-output-to-pixmap (medium *pane* :height 1 :width index) -;; (loop for i from 0 below index -;; for gray-level from 0 by (/ 16 index) do -;; (draw-point* medium i 0 :ink (aref *gray-levels* (floor gray-level)))))))) - -;;; this version should be faster for long beam segments. It is also -;;; more correct in its colors, but the visual impession is no better. -(defun ensure-gray-progressions (pane-medium index) - (when (< (length *darker-gray-progressions*) (1+ index)) - (adjust-array *darker-gray-progressions* (1+ index) :initial-element nil)) - (unless (aref *darker-gray-progressions* index) - (setf (aref *darker-gray-progressions* index) - (with-output-to-pixmap (medium (medium-sheet pane-medium) :height 1 :width index) - ;; start by filling it with black - (draw-rectangle* medium 0 0 index 1 :ink (aref *gray-levels* 0)) - (loop for start = 0 then end - for end from (- (/ index 32) 1/2) by (/ index 16) - for gray-level from 16 above 0 - do (unless (= start end) - (draw-rectangle* medium start 0 end 1 - :ink (aref *gray-levels* gray-level))))))) - (when (< (length *lighter-gray-progressions*) (1+ index)) - (adjust-array *lighter-gray-progressions* (1+ index) :initial-element nil)) - (unless (aref *lighter-gray-progressions* index) - (setf (aref *lighter-gray-progressions* index) - (with-output-to-pixmap (medium (medium-sheet pane-medium) :height 1 :width index) - ;; start by filling it with white - (draw-rectangle* medium 0 0 index 1 :ink (aref *gray-levels* 16)) - (loop for start = 0 then end - for end from (- (/ index 32) 1/2) by (/ index 16) - for gray-level from 0 below 16 - do (unless (= start end) - (draw-rectangle* medium start 0 end 1 - :ink (aref *gray-levels* gray-level)))))))) - -(defun draw-segment (medium x1 y x2 thickness progression1 progression2) - ;; make it a bit thicker to cover either the upper or the lower pixmap - (let ((extra (if *light-glyph* (- x2 x1) 0))) - (medium-draw-rectangle* medium x1 y x2 (- y thickness) t) - (ensure-gray-progressions medium (+ extra (- x2 x1))) - (copy-from-pixmap (aref progression1 (+ extra (- x2 x1))) - (if (eq progression1 *lighter-gray-progressions*) extra 0) - 0 - (- x2 x1) 1 - medium x1 y) - (copy-from-pixmap (aref progression2 (+ extra (- x2 x1))) - (if (eq progression2 *lighter-gray-progressions*) extra 0) - 0 - (- x2 x1) 1 - medium x1 (- y thickness)))) - -(defun draw-downward-beam-segment (medium x1 y x2 thickness) - (draw-segment medium x1 (1+ y) x2 thickness - *darker-gray-progressions* *lighter-gray-progressions*)) - -(defun draw-upward-beam-segment (medium x1 y x2 thickness) - (draw-segment medium x1 y x2 thickness - *lighter-gray-progressions* *darker-gray-progressions*)) - -(defun draw-downward-beam (medium x1 y1 y2 thickness inverse-slope) - (loop for y from y1 below y2 - for x from x1 by inverse-slope do - (draw-downward-beam-segment medium (round x) y - (round (+ x inverse-slope)) thickness))) - -(defun draw-upward-beam (medium x1 y1 y2 thickness inverse-slope) - (loop for y from y1 above y2 - for x from x1 by inverse-slope do - (draw-upward-beam-segment medium (round x) y - (round (+ x inverse-slope)) thickness))) (defclass downward-beam-output-record (beam-output-record) ()) @@ -671,12 +574,9 @@ ,@body)) (defmacro with-score-pane (pane &body body) - (let ((n-pane (gensym "PANE"))) - `(let* ((,n-pane ,pane) - (*lighter-gray-progressions* (lighter-gray-progressions ,n-pane)) - (*darker-gray-progressions* (darker-gray-progressions ,n-pane))) - (clear-output-record (stream-output-history pane)) - ,@body))) + `(progn + (clear-output-record (stream-output-history ,pane)) + ,@body)) (defmacro with-vertical-score-position ((pane yref) &body body) `(with-translation (,pane 0 ,yref) @@ -692,6 +592,5 @@ ,@body)))) (defmacro with-light-glyphs (pane &body body) - `(let ((*light-glyph* t)) - (with-drawing-options (,pane :ink +gray50+) - ,@body))) + `(with-drawing-options (,pane :ink +gray50+) + ,@body))

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 07 Jun '06

07 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv17676 Modified Files: score-pane.lisp sdl.lisp Log Message: Fixed the +-1 problems with beam drawing. --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 14:27:27 1.33 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 22:40:26 1.34 @@ -476,9 +476,9 @@ (loop for y from y1 below y2 for x from x1 by inverse-slope do (let ((upper (sdl::ensure-beam-segment-design :down :upper (- (round (+ x inverse-slope)) (round x)))) - (upper-tr (make-translation-transformation (round x) (1+ y))) ; don't know why the 1 is neccesary + (upper-tr (make-translation-transformation (round x) y)) (lower (sdl::ensure-beam-segment-design :down :lower (- (round (+ x inverse-slope)) (round x)))) - (lower-tr (make-translation-transformation (round x) (+ y thickness 1)))) ; don't know why the 1 is neccesary + (lower-tr (make-translation-transformation (round x) (+ y thickness)))) (climi::medium-draw-bezier-design* medium (transform-region upper-tr upper)) (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower)) (medium-draw-rectangle* medium (round x) (1+ y) (round (+ x inverse-slope)) (+ y thickness) t))))) @@ -492,9 +492,9 @@ (loop for y from y1 above y2 for x from x1 by inverse-slope do (let ((upper (sdl::ensure-beam-segment-design :up :upper (- (round (+ x inverse-slope)) (round x)))) - (upper-tr (make-translation-transformation (round x) (1- y))) ; don't know why the -1 is necessary + (upper-tr (make-translation-transformation (round x) y)) (lower (sdl::ensure-beam-segment-design :up :lower (- (round (+ x inverse-slope)) (round x)))) - (lower-tr (make-translation-transformation (round x) (+ y thickness)))) ; don't know why +1 is not neccesary + (lower-tr (make-translation-transformation (round x) (+ y thickness -1)))) (climi::medium-draw-bezier-design* medium (transform-region upper-tr upper)) (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower)) (medium-draw-rectangle* medium (round x) y (round (+ x inverse-slope)) (1- (+ y thickness)) t))))) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 20:07:12 1.30 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 22:40:26 1.31 @@ -307,11 +307,11 @@ (climi::close-path (if (eq direction :down) (if (eq position :upper) - (mf #c(0 0) -- (complex width -1) -- (complex 0 -1) -- #c(0 0)) - (mf #c(0 0) -- (complex width 0) -- (complex width -1) -- #c(0 0))) + (mf #c(0 0) -- (complex width 1) -- (complex 0 1) -- #c(0 0)) + (mf #c(0 0) -- (complex width 0) -- (complex width 1) -- #c(0 0))) (if (eq position :upper) - (mf #c(0 0) -- (complex width 1) -- (complex width 0) -- #c(0 0)) - (mf #c(0 0) -- (complex width 0) -- (complex 0 -1) -- #c(0 0))))))))) + (mf #c(0 0) -- (complex width -1) -- (complex width 0) -- #c(0 0)) + (mf #c(0 0) -- (complex width 0) -- (complex 0 1) -- #c(0 0))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 07 Jun '06

07 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv28871 Modified Files: sdl.lisp Log Message: Fixed the height of the noteheads --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 04:55:07 1.29 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 20:07:12 1.30 @@ -650,12 +650,12 @@ ;;; Noteheads (defparameter *filled-path* - (mf #c(-0.75 -0.25) up ++ #c(0.33 0.58) right ++ - #c(0.75 0.25) down ++ #c(-0.33 -0.58) left ++ cycle)) + (mf #c(-0.75 -0.25) up ++ #c(0.33 0.53) right ++ + #c(0.75 0.25) down ++ #c(-0.33 -0.53) left ++ cycle)) (defparameter *half-path* - (mf #c(-0.75 -0.25) up (tension 0.8) #c(0.33 0.58) right ++ - #c(0.75 0.25) down (tension 0.8) #c(-0.33 -0.58) left ++ cycle)) + (mf #c(-0.75 -0.25) up (tension 0.8) #c(0.33 0.53) right ++ + #c(0.75 0.25) down (tension 0.8) #c(-0.33 -0.53) left ++ cycle)) (defmethod compute-design ((font font) (shape (eql :filled-notehead))) (with-slots (xoffset yoffset staff-line-distance) font @@ -664,11 +664,11 @@ (defmethod compute-design ((font font) (shape (eql :whole-notehead))) (with-slots (xoffset yoffset (sld staff-line-distance)) font - (let ((op (scale (superellipse #c(0.75 0.0) #c(0.0 0.58) - #c(-0.75 0.0) #c(0.0 -0.58) 0.7) + (let ((op (scale (superellipse #c(0.75 0.0) #c(0.0 0.53) + #c(-0.75 0.0) #c(0.0 -0.53) 0.7) sld)) - (ip (scale (slant (superellipse #c(0.3 0.0) #c(0.0 0.35) - #c(-0.3 0.0) #c(0.0 -0.35) 0.8) + (ip (scale (slant (superellipse #c(0.3 0.0) #c(0.0 0.32) + #c(-0.3 0.0) #c(0.0 -0.32) 0.8) -0.3) sld))) (translate (clim:region-difference op (climi::reverse-path ip))

1 0

[gsharp-cvs] CVS gsharp
by crhodes 07 Jun '06

07 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv16244 Modified Files: score-pane.lisp Log Message: Make with-score-pane usable without warnings Store the transformed clipping region in the beam output record. --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 09:37:26 1.32 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 14:27:27 1.33 @@ -560,7 +560,7 @@ (make-instance 'downward-beam-output-record :x1 xx1 :y1 (+ yy1 yu) :x2 xx2 :y2 (+ yy2 yd) :thickness yt :ink (medium-ink medium) - :clipping-region (medium-clipping-region medium))))) + :clipping-region (transform-region transformation (medium-clipping-region medium)))))) (when (stream-drawing-p (medium-sheet medium)) (medium-draw-downward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness))) (t @@ -573,9 +573,9 @@ (make-instance 'upward-beam-output-record :x1 xx1 :y1 (+ yy2 yu) :x2 xx2 :y2 (+ yy1 yd) :thickness yt :ink (medium-ink medium) - :clipping-region (medium-clipping-region medium))))) + :clipping-region (transform-region transformation (medium-clipping-region medium)))))) (when (stream-drawing-p (medium-sheet medium)) - (medium-draw-upward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness)))))))) + (medium-draw-upward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness))))))) ;;; an offset of -1 means hang, 0 means straddle and 1 means sit (defun draw-beam (pane x1 staff-step-1 offset1 x2 staff-step-2 offset2) @@ -671,10 +671,12 @@ ,@body)) (defmacro with-score-pane (pane &body body) - `(let* ((*lighter-gray-progressions* (lighter-gray-progressions pane)) - (*darker-gray-progressions* (darker-gray-progressions pane))) - (clear-output-record (stream-output-history pane)) - ,@body)) + (let ((n-pane (gensym "PANE"))) + `(let* ((,n-pane ,pane) + (*lighter-gray-progressions* (lighter-gray-progressions ,n-pane)) + (*darker-gray-progressions* (darker-gray-progressions ,n-pane))) + (clear-output-record (stream-output-history pane)) + ,@body))) (defmacro with-vertical-score-position ((pane yref) &body body) `(with-translation (,pane 0 ,yref)

1 0

[gsharp-cvs] CVS gsharp
by crhodes 07 Jun '06

07 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv15360 Modified Files: score-pane.lisp Log Message: Postscript beam drawing. *PANE* is now dead, so remove it and replace references to it with (medium-sheet medium). --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 04:55:07 1.31 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 09:37:26 1.32 @@ -12,7 +12,6 @@ (declare (ignore args)) (setf (stream-default-view pane) (make-instance 'score-view))) -(defparameter *pane* nil) (defparameter *light-glyph* nil) (defparameter *font* nil) (defparameter *fonts* (make-array 100 :initial-element nil)) @@ -472,7 +471,7 @@ (defclass downward-beam-output-record (beam-output-record) ()) -(defun medium-draw-downward-beam* (medium x1 y1 x2 y2 thickness) +(defmethod medium-draw-downward-beam* (medium x1 y1 x2 y2 thickness) (let ((inverse-slope (abs (/ (- x2 x1) (- y2 y1))))) (loop for y from y1 below y2 for x from x1 by inverse-slope do @@ -484,7 +483,11 @@ (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower)) (medium-draw-rectangle* medium (round x) (1+ y) (round (+ x inverse-slope)) (+ y thickness) t))))) -(defun medium-draw-upward-beam* (medium x1 y1 x2 y2 thickness) +(defmethod medium-draw-downward-beam* + ((medium clim-postscript::postscript-medium) x1 y1 x2 y2 thickness) + (draw-polygon* (medium-sheet medium) `(,x1 ,y1 ,x1 ,(+ y1 thickness) ,x2 ,(+ y2 thickness) ,x2 ,y2) :closed t :filled t)) + +(defmethod medium-draw-upward-beam* (medium x1 y1 x2 y2 thickness) (let ((inverse-slope (abs (/ (- x2 x1) (- y2 y1))))) (loop for y from y1 above y2 for x from x1 by inverse-slope do @@ -496,7 +499,11 @@ (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower)) (medium-draw-rectangle* medium (round x) y (round (+ x inverse-slope)) (1- (+ y thickness)) t))))) -(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane) +(defmethod medium-draw-upward-beam* + ((medium clim-postscript::postscript-medium) x1 y1 x2 y2 thickness) + (draw-polygon* (medium-sheet medium) `(,x1 ,y1 ,x1 ,(+ y1 thickness) ,x2 ,(+ y2 thickness) ,x2 ,y2) :closed t :filled t)) + +(defmethod replay-output-record ((record downward-beam-output-record) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -510,7 +517,7 @@ (defclass upward-beam-output-record (beam-output-record) ()) -(defmethod replay-output-record ((record upward-beam-output-record) (stream score-pane) +(defmethod replay-output-record ((record upward-beam-output-record) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -521,39 +528,54 @@ (medium :ink ink :clipping-region clipping-region) (medium-draw-upward-beam* medium x1 (- y2 thickness) x2 y1 thickness)))))) +(defun transform-beam-attributes (transformation x1 y1 x2 y2 down up thickness) + (multiple-value-bind (xx1 yy1) + (transform-position transformation x1 y1) + (multiple-value-bind (xx2 yy2) + (transform-position transformation x2 y2) + (multiple-value-bind (xd yd) + (transform-distance transformation 0 down) + (declare (ignore xd)) + (multiple-value-bind (xu yu) + (transform-distance transformation 0 up) + (declare (ignore xu)) + (multiple-value-bind (xt yt) + (transform-distance transformation 0 thickness) + (declare (ignore xt)) + (values xx1 yy1 xx2 yy2 yd yu yt))))))) + ;;; draw a sloped beam. The vertical reference points ;;; of the two end points are indicated by y1 and y2. (defun draw-sloped-beam (medium x1 y1 x2 y2) (multiple-value-bind (down up) (beam-offsets *font*) - (let ((transformation (medium-transformation *pane*)) + (let ((transformation (medium-transformation (medium-sheet medium))) (thickness (- down up))) (cond ((< y1 y2) - (when (stream-recording-p *pane*) - (multiple-value-bind (xx1 yy1) - (transform-position transformation x1 y1) - (multiple-value-bind (xx2 yy2) - (transform-position transformation x2 y2) - (stream-add-output-record - *pane* (make-instance 'downward-beam-output-record - :x1 xx1 :y1 (+ yy1 up) :x2 xx2 :y2 (+ yy2 down) - :thickness thickness :ink (medium-ink medium) - :clipping-region (medium-clipping-region medium)))))) - (when (stream-drawing-p *pane*) + (when (stream-recording-p (medium-sheet medium)) + (multiple-value-bind (xx1 yy1 xx2 yy2 yd yu yt) + (transform-beam-attributes transformation x1 y1 x2 y2 + down up thickness) + (stream-add-output-record + (medium-sheet medium) + (make-instance 'downward-beam-output-record + :x1 xx1 :y1 (+ yy1 yu) :x2 xx2 :y2 (+ yy2 yd) + :thickness yt :ink (medium-ink medium) + :clipping-region (medium-clipping-region medium))))) + (when (stream-drawing-p (medium-sheet medium)) (medium-draw-downward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness))) (t - (when (stream-recording-p *pane*) - (multiple-value-bind (xx1 yy1) - (transform-position transformation x1 y1) - (multiple-value-bind (xx2 yy2) - (transform-position transformation x2 y2) - (stream-add-output-record - *pane* (make-instance 'upward-beam-output-record - :x1 xx1 :y1 (+ yy2 up) :x2 xx2 :y2 (+ yy1 down) - :thickness thickness - :ink (medium-ink medium) - :clipping-region (medium-clipping-region medium)))))) - (when (stream-drawing-p *pane*) - (medium-draw-upward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness))))))) + (when (stream-recording-p (medium-sheet medium)) + (multiple-value-bind (xx1 yy1 xx2 yy2 yd yu yt) + (transform-beam-attributes transformation x1 y1 x2 y2 + down up thickness) + (stream-add-output-record + (medium-sheet medium) + (make-instance 'upward-beam-output-record + :x1 xx1 :y1 (+ yy2 yu) :x2 xx2 :y2 (+ yy1 yd) + :thickness yt :ink (medium-ink medium) + :clipping-region (medium-clipping-region medium))))) + (when (stream-drawing-p (medium-sheet medium)) + (medium-draw-upward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness)))))))) ;;; an offset of -1 means hang, 0 means straddle and 1 means sit (defun draw-beam (pane x1 staff-step-1 offset1 x2 staff-step-2 offset2) @@ -649,10 +671,9 @@ ,@body)) (defmacro with-score-pane (pane &body body) - `(let* ((*pane* ,pane) - (*lighter-gray-progressions* (lighter-gray-progressions pane)) + `(let* ((*lighter-gray-progressions* (lighter-gray-progressions pane)) (*darker-gray-progressions* (darker-gray-progressions pane))) - (clear-output-record (stream-output-history *pane*)) + (clear-output-record (stream-output-history pane)) ,@body)) (defmacro with-vertical-score-position ((pane yref) &body body)

1 0

← Newer
1
...
9
10
11
12
13
14
15
...
40
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

gsharp-cvs