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

[gsharp-cvs] CVS gsharp/Scores
by crhodes 26 Jun '06

26 Jun '06

Update of /project/gsharp/cvsroot/gsharp/Scores In directory clnet:/tmp/cvs-serv11922/Scores Added Files: K387-4.gsh Log Message: Commit the first section of Mozart's string quartet K387, movement 4. An exceedingly nice fughetta. Current deficiencies that this illustrates: * accidentals in bars being drawn even when a previous accidental would imply it; * ties at ends and beginnings of lines; * need for pagewise movement commands. --- /project/gsharp/cvsroot/gsharp/Scores/K387-4.gsh 2006/06/26 16:40:33 NONE +++ /project/gsharp/cvsroot/gsharp/Scores/K387-4.gsh 2006/06/26 16:40:33 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 "default staff" :clef [GSHARP-BUFFER:CLEF :name :TREBLE :lineno 2 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #1# :alterations #(:NATURAL :NATURAL :NATURAL :SHARP :NATURAL :NATURAL :NATURAL) ] ] #2=[GSHARP-BUFFER:FIVELINE-STAFF :name "2do" :clef [GSHARP-BUFFER:CLEF :name :TREBLE :lineno 2 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #2# :alterations #(:NATURAL :NATURAL :NATURAL :SHARP :NATURAL :NATURAL :NATURAL) ] ] #3=[GSHARP-BUFFER:FIVELINE-STAFF :name "viola" :clef [GSHARP-BUFFER:CLEF :name :C :lineno 4 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #3# :alterations #(:NATURAL :NATURAL :NATURAL :SHARP :NATURAL :NATURAL :NATURAL) ] ] #4=[GSHARP-BUFFER:FIVELINE-STAFF :name "cello" :clef [GSHARP-BUFFER:CLEF :name :BASS :lineno 6 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #4# :alterations #(:NATURAL :NATURAL :NATURAL :SHARP :NATURAL :NATURAL :NATURAL) ] ]) :segments ([GSHARP-BUFFER:SEGMENT :layers ([GSHARP-BUFFER:MELODY-LAYER :name "cello" :staves (#4#) :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 #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 25 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 27 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :WHOLE :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #4# :head :FILLED :accidentals :SHARP :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 29 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:REST :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 29 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-right COMMON-LISP:T ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 29 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-left COMMON-LISP:T ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:REST :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 27 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-right COMMON-LISP:T ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 27 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-left COMMON-LISP:T ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 26 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:REST :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-right COMMON-LISP:T ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-left COMMON-LISP:T ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 29 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:REST :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-right COMMON-LISP:T ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 :tie-left COMMON-LISP:T ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 27 :staff #4# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:REST :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :staff #4# :staff-pos 4 ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:REST [19162 lines skipped]

1 0

[gsharp-cvs] CVS gsharp/Scores
by crhodes 26 Jun '06

26 Jun '06

Update of /project/gsharp/cvsroot/gsharp/Scores In directory clnet:/tmp/cvs-serv11794/Scores Modified Files: dots.gsh Log Message: MORE DOTS Well, actually, fix the dots that we already have. Rests have dots too, but fortunately the computation for their dot's offset is slightly easier. --- /project/gsharp/cvsroot/gsharp/Scores/dots.gsh 2006/06/21 16:31:54 1.1 +++ /project/gsharp/cvsroot/gsharp/Scores/dots.gsh 2006/06/26 16:37:43 1.2 @@ -56,6 +56,14 @@ :head :FILLED :accidentals :NATURAL :dots 0 ]) ] + [GSHARP-BUFFER:REST + :xoffset 0 + :notehead :FILLED + :rbeams 0 + :lbeams 0 + :dots 1 + :staff #1# + :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED @@ -81,6 +89,14 @@ :head :FILLED :accidentals :NATURAL :dots 0 ]) ] + [GSHARP-BUFFER:REST + :xoffset 0 + :notehead :FILLED + :rbeams 1 + :lbeams 0 + :dots 1 + :staff #1# + :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED @@ -106,6 +122,14 @@ :head :FILLED :accidentals :NATURAL :dots 0 ]) ] + [GSHARP-BUFFER:REST + :xoffset 0 + :notehead :HALF + :rbeams 0 + :lbeams 0 + :dots 1 + :staff #1# + :staff-pos 4 ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED @@ -493,7 +517,16 @@ :staff #1# :head :FILLED :accidentals :NATURAL - :dots 0 ]) ]) ]) ] + :dots 0 ]) ]) ] + [GSHARP-BUFFER:MELODY-BAR + :elements ([GSHARP-BUFFER:REST + :xoffset 0 + :notehead :WHOLE + :rbeams 0 + :lbeams 0 + :dots 3 + :staff #1# + :staff-pos 4 ]) ]) ] :tail [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:MELODY-BAR :elements COMMON-LISP:NIL ]) ] ])

1 0

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

26 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv11794 Modified Files: drawing.lisp Log Message: MORE DOTS Well, actually, fix the dots that we already have. Rests have dots too, but fortunately the computation for their dot's offset is slightly easier. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/21 16:31:54 1.72 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/26 16:37:43 1.73 @@ -917,7 +917,7 @@ (let ((x (final-absolute-element-xoffset element))) (score-pane:with-vertical-score-position (pane (staff-yoffset (staff element))) (score-pane:draw-rest pane (undotted-duration element) x (staff-pos element)) - (draw-dots pane (dots element) x (1+ (staff-pos element)))))) + (draw-dots pane (dots element) x (+ x (score-pane:staff-step 2)) (1+ (staff-pos element)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

21 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv21067 Modified Files: drawing.lisp measure.lisp packages.lisp Log Message: Dots! Specifically, augmentation dots. Get their x- and y- positions more right, which sometimes entails not drawing a dot at all, sometimes adjusting the position for a dot downwards, and (when a flag is drawn or there is a suspended note in a flag-up situation) involves shifting the entire column of dots rightwards. Add an example score full of things we got wrong. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/19 17:40:34 1.71 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/21 16:31:54 1.72 @@ -76,6 +76,9 @@ (defun final-absolute-accidental-xoffset (note) (+ (final-absolute-element-xoffset (cluster note)) (final-relative-accidental-xoffset note))) +(defun final-absolute-dot-xoffset (cluster) + (+ (final-absolute-element-xoffset cluster) (score-pane:staff-step (final-relative-dot-xoffset cluster)))) + (defvar *cursor* nil) ;;; Compute the elasticity of each timeline in each measure of the @@ -832,9 +835,13 @@ (loop for pos from -2 downto bot-note-pos by 2 do (score-pane:draw-ledger-line pane x pos))))) -(defun draw-flags (pane element x direction pos) +(defun flags-drawn-p (element) (let ((nb (max (rbeams element) (lbeams element)))) - (when (and (> nb 0) (eq (notehead element) :filled)) + (and (> nb 0) (eq (notehead element) :filled) nb))) + +(defun draw-flags (pane element x direction pos) + (let ((nb (flags-drawn-p element))) + (when nb (if (eq direction :up) (score-pane:with-notehead-right-offsets (right up) (declare (ignore up)) @@ -843,23 +850,23 @@ (declare (ignore down)) (score-pane:draw-flags-up pane nb (+ x left) pos)))))) -(defun draw-dots (pane nb-dots x pos) - (let ((staff-step (score-pane:staff-step 1))) - (loop with dotpos = (if (evenp pos) (1+ pos) pos) - repeat nb-dots - for xx from (+ x (* 2 staff-step)) by staff-step do - (score-pane:draw-dot pane xx dotpos)))) +(defun draw-dots (pane nb-dots x dot-xoffset dot-pos) + (when dot-pos + (let ((staff-step (score-pane:staff-step 1))) + (loop repeat nb-dots + for xx from dot-xoffset by staff-step do + (score-pane:draw-dot pane xx dot-pos))))) -(defun draw-note (pane note notehead nb-dots x pos) +(defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos) (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) (final-absolute-accidental-xoffset note) pos)) - (draw-dots pane nb-dots x pos))) + (draw-dots pane nb-dots x dot-xoffset dot-pos))) -(defun draw-notes (pane notes dots notehead) +(defun draw-notes (pane notes dots notehead dot-xoffset) (loop for note in notes do - (draw-note pane note notehead dots (final-absolute-note-xoffset note) (note-position note)))) + (draw-note pane note notehead dots (final-absolute-note-xoffset note) (note-position note) dot-xoffset (final-absolute-dot-ypos note)))) (defun element-has-suspended-notes (element) (not (apply #'= (mapcar #'final-relative-note-xoffset (notes element))))) @@ -873,17 +880,23 @@ (defmethod draw-element (pane (element cluster) &optional (flags t)) (with-new-output-record (pane) (unless (null (notes element)) - (let ((direction (final-stem-direction element)) - (stem-pos (final-stem-position element)) - (stem-yoffset (final-stem-yoffset element)) - (groups (group-notes-by-staff (notes element))) - (x (final-absolute-element-xoffset element))) + (let* ((direction (final-stem-direction element)) + (stem-pos (final-stem-position element)) + (stem-yoffset (final-stem-yoffset element)) + (groups (group-notes-by-staff (notes element))) + (x (final-absolute-element-xoffset element)) + (dot-xoffset + (let ((basic-xoffset (+ (score-pane:staff-step 2) + (reduce #'max (mapcar #'final-absolute-note-xoffset (notes element)))))) + (if (and flags (eq direction :up) (flags-drawn-p element)) + (max basic-xoffset (+ (score-pane:staff-step 4) x)) + basic-xoffset)))) (when flags (score-pane:with-vertical-score-position (pane stem-yoffset) (draw-flags pane element x direction stem-pos))) - (loop for group in groups do - (draw-notes pane group (dots element) (notehead element)) - (draw-ledger-lines pane x group)) + (loop for group in groups do + (draw-notes pane group (dots element) (notehead element) dot-xoffset) + (draw-ledger-lines pane x group)) (unless (eq (notehead element) :whole) (if (eq direction :up) (score-pane:draw-right-stem --- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/19 17:40:34 1.31 +++ /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/21 16:31:54 1.32 @@ -56,7 +56,11 @@ :accessor final-relative-accidental-xoffset) (final-accidental :initform nil :accessor final-accidental) ;; the relative x offset of the note with respect to the cluster - (final-relative-note-xoffset :accessor final-relative-note-xoffset))) + (final-relative-note-xoffset :accessor final-relative-note-xoffset) + ;; the absolute y position of any dot, or NIL if dots should not be + ;; drawn + (final-absolute-dot-ypos :accessor final-absolute-dot-ypos :initform nil) +)) ;;; 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. @@ -158,7 +162,7 @@ (define-added-mixin rcluster () cluster ((final-stem-direction :accessor final-stem-direction) - ;; the position, in staff steps, of the top not in the element. + ;; the position, in staff steps, of the top note in the element. (top-note-pos :accessor top-note-pos) ;; the position, in staff steps, of the bottom note in the element. (bot-note-pos :accessor bot-note-pos))) @@ -217,6 +221,22 @@ when (non-empty-cluster-p element) do (setf (final-stem-direction element) stem-direction)))) +(defun compute-final-dot-positions (group) + (setf group (sort (copy-list group) #'> :key #'note-position)) + (let ((so-far nil)) + (dolist (note group) + (let* ((position (note-position note)) + (ideal (if (oddp position) position (1+ position)))) + (cond + ;; if there's no dot at our ideal position, use that + ((not (member ideal so-far)) (push (setf (final-absolute-dot-ypos note) ideal) so-far)) + ;; if the note in question is on a line and we haven't + ;; got a dot in the space underneath, use that + ((and (evenp position) (not (member (- ideal 2) so-far))) + (push (setf (final-absolute-dot-ypos note) (- ideal 2)) so-far)) + ;; otherwise, give up for this note + (t (setf (final-absolute-dot-ypos note) nil))))))) + ;;; 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. @@ -550,6 +570,7 @@ (defun compute-staff-group-parameters (staff-group stem-direction) (compute-final-relative-note-xoffsets staff-group stem-direction) + (compute-final-dot-positions staff-group) (compute-final-accidentals staff-group) (compute-final-relative-accidental-xoffset staff-group stem-direction)) @@ -622,7 +643,7 @@ (defmethod compute-bar-parameters ((bar melody-bar)) (loop for group in (beam-groups (elements bar)) - do (compute-beam-group-parameters group))) + do (compute-beam-group-parameters group))) ;;; From a list of simultaneous bars (and some other stuff), create a ;;; measure. The `other stuff' is the spacing style, which is needed --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/14 03:38:56 1.57 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/21 16:31:54 1.58 @@ -128,6 +128,7 @@ #:beam-groups #:final-stem-direction #:group-notes-by-staff #:final-relative-note-xoffset #:final-accidental #:final-relative-accidental-xoffset + #:final-relative-dot-xoffset #:final-absolute-dot-ypos #:timeline #:timelines #:elasticity #:smallest-gap #:elasticity-function))

1 0

[gsharp-cvs] CVS gsharp/Scores
by crhodes 21 Jun '06

21 Jun '06

Update of /project/gsharp/cvsroot/gsharp/Scores In directory clnet:/tmp/cvs-serv21067/Scores Added Files: dots.gsh Log Message: Dots! Specifically, augmentation dots. Get their x- and y- positions more right, which sometimes entails not drawing a dot at all, sometimes adjusting the position for a dot downwards, and (when a flag is drawn or there is a suspended note in a flag-up situation) involves shifting the entire column of dots rightwards. Add an example score full of things we got wrong. --- /project/gsharp/cvsroot/gsharp/Scores/dots.gsh 2006/06/21 16:31:54 NONE +++ /project/gsharp/cvsroot/gsharp/Scores/dots.gsh 2006/06/21 16:31:54 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 "default staff" :clef [GSHARP-BUFFER:CLEF :name :TREBLE :lineno 2 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #1# :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL) ] ] #2=[GSHARP-BUFFER:FIVELINE-STAFF :name "foo" :clef [GSHARP-BUFFER:CLEF :name :BASS :lineno 4 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #2# :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL) ] ]) :segments ([GSHARP-BUFFER:SEGMENT :layers ([GSHARP-BUFFER:MELODY-LAYER :name "default layer" :staves (#1# #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:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 35 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 36 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 37 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 36 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 37 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 38 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 31 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 32 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 31 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 32 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 33 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 35 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 36 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 37 :staff #1# :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 36 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 37 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 38 :staff #1# :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 #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 31 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 32 :staff #1# :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 #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 32 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 33 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #1# :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 29 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 30 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 31 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 32 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 33 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 34 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 35 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 :staff #1# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 29 :staff #1# :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 #1# :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 21 :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 28 :staff #2# :head :FILLED :accidentals :NATURAL [100 lines skipped]

1 0

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

19 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv11337 Modified Files: buffer.lisp cursor.lisp drawing.lisp gui.lisp measure.lisp modes.lisp Log Message: Merge keysigN patch, with all its attendant horribleness. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/03/02 09:29:44 1.37 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/06/19 17:40:34 1.38 @@ -115,7 +115,8 @@ ((print-character :allocation :class :initform #\=) (clef :accessor clef :initarg :clef :initform (make-clef :treble)) (%keysig :accessor keysig :initarg :keysig - :initform (make-array 7 :initial-element :natural)))) + :initform (make-array 7 :initial-element :natural)) + (key-signatures :accessor key-signatures :initform nil))) (defmethod initialize-instance :after ((obj fiveline-staff) &rest args) (declare (ignore args)) --- /project/gsharp/cvsroot/gsharp/cursor.lisp 2004/07/23 16:51:16 1.2 +++ /project/gsharp/cvsroot/gsharp/cursor.lisp 2006/06/19 17:40:34 1.3 @@ -166,6 +166,12 @@ (when (> (pos cursor) position) (incf (pos cursor))))) +(defmethod add-element :after + ((keysig gsharp-buffer::key-signature) bar position) + (setf (gsharp-buffer::key-signatures (staff keysig)) + ;; FIXME: unordered + (cons keysig (gsharp-buffer::key-signatures (staff keysig))))) + (defmethod remove-element :before ((element element)) (let ((elemno (number element))) (loop for cursor in (cursors (bar element)) do --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/14 05:03:14 1.70 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/19 17:40:34 1.71 @@ -150,6 +150,31 @@ (score-pane:staff-step 5) (score-pane:staff-step 2))) +(defmethod right-bulge ((keysig gsharp-buffer::key-signature) pane) + ;; FIXME: shares much code with DRAW-ELEMENT (KEY-SIGNATURE). + (let ((old-keysig (keysig keysig))) + (let ((bulge 0)) + (loop with advance = 0 + for pitch in '(6 2 5 1 4 0 3) + when (and (eq (aref (alterations old-keysig) pitch) :flat) + (not (eq (aref (alterations keysig) pitch) + :flat))) + do (incf advance (score-pane:staff-step 2)) + finally (incf bulge (if (= advance 0) 0 (+ advance (score-pane:staff-step 2))))) + (loop with advance = 0 + for pitch in '(3 0 4 1 5 2 6) + when (and (eq (aref (alterations old-keysig) pitch) :sharp) + (not (eq (aref (alterations keysig) pitch) :sharp))) + do (incf advance (score-pane:staff-step 2)) + finally (incf bulge (if (= advance 0) 0 (+ advance (score-pane:staff-step 2))))) + (loop for pitch in '(6 2 5 1 4 0 3) + while (eq (aref (alterations keysig) pitch) :flat) + do (incf bulge (score-pane:staff-step 2))) + (loop for pitch in '(3 0 4 1 5 2 6) + while (eq (aref (alterations keysig) pitch) :sharp) + do (incf bulge (score-pane:staff-step 2.5))) + bulge))) + ;;; As it turns out, the spacing algorithm would be very complicated ;;; if we were to take into account exactly how elements with ;;; arbitrarily many timelines between them might influence the @@ -496,6 +521,9 @@ (incf yy (+ 20 (* 70 (length staves)))))))) buffer))))) +(define-added-mixin xelement () element + ((final-absolute-xoffset :accessor final-absolute-element-xoffset))) + (define-added-mixin velement () melody-element (;; the position, in staff steps, of the end of the stem ;; that is not attached to a note, independent of the @@ -509,11 +537,10 @@ (top-note-staff-yoffset :accessor top-note-staff-yoffset) ;; the yoffset of the staff that contains the bottom note of ;; the element - (bot-note-staff-yoffset :accessor bot-note-staff-yoffset) - (final-absolute-xoffset :accessor final-absolute-element-xoffset))) + (bot-note-staff-yoffset :accessor bot-note-staff-yoffset))) (define-added-mixin welement () lyrics-element - ((final-absolute-xoffset :accessor final-absolute-element-xoffset))) + ()) ;;; Compute and store several important pieces of information ;;; about an element: @@ -600,6 +627,11 @@ notes)) (defun draw-beam-group (pane elements) + (let ((e (car elements))) + (when (typep e 'gsharp-buffer::key-signature) + (assert (null (cdr elements))) + (return-from draw-beam-group + (draw-element pane e (final-absolute-element-xoffset e))))) (mapc #'compute-top-bot-yoffset elements) (if (null (cdr elements)) (let ((element (car elements))) @@ -885,3 +917,46 @@ (with-text-family (pane :serif) (draw-text* pane (map 'string 'code-char (text element)) x 0 :align-x :center))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Key signature element + +(defmethod draw-element (pane (keysig key-signature) &optional flags) + (let ((staff (staff keysig)) + (old-keysig (keysig keysig)) + (x (final-absolute-element-xoffset keysig))) + (score-pane:with-vertical-score-position (pane (staff-yoffset staff)) + (let ((yoffset (b-position (clef staff)))) + (loop with advance = 0 + for pitch in '(6 2 5 1 4 0 3) + for line in '(0 3 -1 2 -2 1 -3) + when (and (eq (aref (alterations old-keysig) pitch) :flat) + (not (eq (aref (alterations keysig) pitch) + :flat))) + do (score-pane:draw-accidental + pane :natural (+ x advance) (+ line yoffset)) + and do (incf advance (score-pane:staff-step 2)) + finally (incf x (if (= advance 0) 0 (+ advance (score-pane:staff-step 2)))))) + (let ((yoffset (f-position (clef staff)))) + (loop with advance = 0 + for pitch in '(3 0 4 1 5 2 6) + for line in '(0 -3 1 -2 -5 -1 -4) + when (and (eq (aref (alterations old-keysig) pitch) :sharp) + (not (eq (aref (alterations keysig) pitch) :sharp))) + do (score-pane:draw-accidental pane :natural (+ x advance) (+ line yoffset)) + and do (incf advance (score-pane:staff-step 2)) + finally (incf x (if (= advance 0) 0 (+ advance (score-pane:staff-step 2)))))) + + (let ((yoffset (b-position (clef staff)))) + (loop for pitch in '(6 2 5 1 4 0 3) + for line in '(0 3 -1 2 -2 1 -3) + for x from x by (score-pane:staff-step 2) + while (eq (aref (alterations keysig) pitch) :flat) + do (score-pane:draw-accidental pane :flat x (+ line yoffset)))) + (let ((yoffset (f-position (clef staff)))) + (loop for pitch in '(3 0 4 1 5 2 6) + for line in '(0 -3 1 -2 -5 -1 -4) + for x from x by (score-pane:staff-step 2.5) + while (eq (aref (alterations keysig) pitch) :sharp) + do (score-pane:draw-accidental pane :sharp x (+ line yoffset))))))) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/17 19:15:02 1.68 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/19 17:40:34 1.69 @@ -591,7 +591,7 @@ (staff (car (staves (layer (slice (bar cluster)))))) (note (make-note pitch staff :head (notehead state) - :accidentals (aref (alterations (keysig staff)) (mod pitch 7)) + :accidentals (aref (alterations (keysig (current-cursor))) (mod pitch 7)) :dots (dots state)))) (setf *current-cluster* cluster *current-note* note) @@ -858,6 +858,92 @@ (unless *current-note* (com-erase-element 1))))) +(defun insert-keysig () + (let* ((state (input-state *application-frame*)) + (cursor (current-cursor)) + (staff (car (staves (layer cursor)))) + (keysig (if (keysig cursor) + (gsharp-buffer::make-key-signature + staff :alterations (copy-seq (alterations (keysig cursor)))) + (gsharp-buffer::make-key-signature staff)))) + ;; FIXME: should only invalidate elements temporally after the + ;; cursor. + (gsharp-measure::invalidate-everything-using-staff (current-buffer *application-frame*) staff) + (insert-element keysig cursor) + (forward-element cursor) + keysig)) + +(define-gsharp-command com-insert-keysig () + (insert-keysig)) + +(defmethod remove-element :before ((keysig gsharp-buffer::key-signature)) + (let ((staff (staff keysig))) + (setf (gsharp-buffer::key-signatures staff) + (remove keysig (gsharp-buffer::key-signatures staff))) + (gsharp-measure::invalidate-everything-using-staff (current-buffer *application-frame*) staff))) + +;;; FIXME: this function does not work for finding a key signature in +;;; a different layer (but on the same staff). This will bite in +;;; polyphonic music with key signature changes (e.g. Piano music) +(defun %keysig (staff key-signatures bar bars element-or-nil) + ;; common case + (when (null key-signatures) + (return-from %keysig (keysig staff))) + ;; earlier in the same bar? + (let ((k nil)) + (dolist (e (elements bar) (when k (return-from %keysig k))) + (when (eq e element-or-nil) + (if k + (return-from %keysig k) + (return nil))) + (when (and (typep e 'gsharp-buffer::key-signature) + (eq (staff e) staff)) + (setq k e)))) + ;; must be an earlier bar. + (let ((bars (nreverse (loop for b in bars until (eq b bar) collect b)))) + (dolist (b bars (keysig staff)) + (when (find b key-signatures :key #'bar) + (dolist (e (reverse (elements b)) (error "inconsistency")) + (when (and (typep e 'key-signature) + (eq (staff e) staff)) + (return-from %keysig e))))))) + +(defmethod keysig ((cursor gsharp-cursor)) + ;; FIXME: not just a cursor but _the_ cursor (i.e. in a given staff) + ;; otherwise the operation for getting the staff [(CAR (STAVES + ;; (LAYER CURSOR)))] need not return the staff that we're interested + ;; in. + (assert (eq cursor (current-cursor))) + (let* ((staff (car (staves (layer cursor)))) + (key-signatures (gsharp-buffer::key-signatures staff)) + (bar (bar cursor)) + (slice (slice bar)) + (bars (bars slice)) + (element-or-nil (cursor-element cursor))) + (%keysig staff key-signatures bar bars element-or-nil))) + +(defmethod keysig ((note note)) + (let* ((staff (staff note)) + (key-signatures (gsharp-buffer::key-signatures staff)) + (bar (bar (cluster note))) + (slice (slice bar)) + (bars (bars slice)) + (element-or-nil (cluster note))) + (%keysig staff key-signatures bar bars element-or-nil))) + +(defmethod keysig ((cluster cluster)) + (error "Called ~S (a staff-scope operation) on an element with no ~ + associated staff: ~S" + 'keysig cluster)) + +(defmethod keysig ((element element)) + (let* ((staff (staff element)) + (key-signatures (gsharp-buffer::key-signatures staff)) + (bar (bar element)) + (slice (slice bar)) + (bars (bars slice))) + (%keysig staff key-signatures bar bars element))) + (define-gsharp-command com-tie-note-left () (let ((note (cur-note))) (when note @@ -1188,10 +1274,10 @@ (remove-staff-from-layer staff layer))) (define-gsharp-command com-more-sharps () - (more-sharps (keysig (car (staves (layer (current-cursor))))))) + (more-sharps (keysig (current-cursor)))) (define-gsharp-command com-more-flats () - (more-flats (keysig (car (staves (layer (current-cursor))))))) + (more-flats (keysig (current-cursor)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/13 01:18:10 1.30 +++ /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/19 17:40:34 1.31 @@ -224,7 +224,7 @@ (loop for note in group do (setf (final-accidental note) (if (eq (accidentals note) - (aref (alterations (keysig (staff note))) (mod (pitch note) 7))) + (aref (alterations (keysig note)) (mod (pitch note) 7))) nil (accidentals note))))) --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/14 19:20:41 1.18 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/19 17:40:34 1.19 @@ -44,6 +44,8 @@ (set-key 'com-insert-note-g 'melody-table '(#\g)) (set-key 'com-insert-rest 'melody-table '((#\,))) (set-key 'com-insert-empty-cluster 'melody-table '((#\Space))) +(set-key 'com-insert-keysig 'melody-table '(#\K)) + (set-key 'com-more-sharps 'melody-table '((#\# :meta))) (set-key 'com-more-sharps 'melody-table '((#\# :meta :shift))) (set-key 'com-more-flats 'melody-table '((#\@ :meta :shift)))

1 0

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

17 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv3865 Modified Files: gui.lisp Log Message: Recompute measures in a :before method on redisplay-frame-pane as opposed to redisplay-frame-panes. This turns out to be necessary because redisplay-frame-panes is not always called. In particular redisplay-frame-pane is called from adopt-frame without going through redisplay-frame-panes, and adopt-frame is called when Gsharp is started from the CLIM desktop. --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/14 19:20:41 1.67 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/17 19:15:02 1.68 @@ -25,13 +25,17 @@ ((cursor :initarg :cursor :reader cursor) (buffer :initarg :buffer :reader buffer))) -(defclass gsharp-pane (score-pane:score-pane) +;;; exists for the sole purpose of a :before method that updates the +;;; measures of each modified buffer. +(defclass gsharp-pane-mixin () ()) + +(defclass gsharp-pane (score-pane:score-pane gsharp-pane-mixin) ((view :initarg :view :accessor view))) (defvar *info-bg-color* +gray85+) (defvar *info-fg-color* +black+) -(defclass gsharp-info-pane (info-pane) +(defclass gsharp-info-pane (info-pane gsharp-pane-mixin) () (:default-initargs :height 20 :max-height 20 :min-height 20 @@ -183,8 +187,11 @@ (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)) +;;; I tried making this a :before method on redisplay-frame-panes, +;;; but it turns out that McCLIM calls redisplay-frame-pane from +;;; places other than redisplay-frame-panes. +(defmethod redisplay-frame-pane :before ((frame gsharp) (pane gsharp-pane-mixin) &key force-p) + (declare (ignore pane force-p)) (mapc #'recompute-measures (buffers frame)) (update-page-numbers frame))

1 0

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

14 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv31881 Modified Files: gui.lisp modes.lisp Log Message: New commands: com-octave-up and com-octave-down that work for clusters, bound to Meta-U and Meta-D. They move the current note up/down by an entire octave. These commands are useful when the automatic pitch follower gets it wrong. --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/14 03:38:56 1.66 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/14 19:20:41 1.67 @@ -784,6 +784,28 @@ cursor) (forward-element cursor))))) +(define-gsharp-command com-octave-down () + (let ((element (cur-element))) + (let* ((note (cur-note)) + (new-note (make-note (- (pitch note) 7) (staff note) + :head (head note) + :accidentals (accidentals note) + :dots (dots note)))) + (remove-note note) + (add-note element new-note) + (setf *current-note* new-note)))) + +(define-gsharp-command com-octave-up () + (let ((element (cur-element))) + (let* ((note (cur-note)) + (new-note (make-note (+ (pitch note) 7) (staff note) + :head (head note) + :accidentals (accidentals note) + :dots (dots note)))) + (remove-note note) + (add-note element new-note) + (setf *current-note* new-note)))) + (define-gsharp-command com-sharper () (let* ((cluster (cur-cluster)) (note (cur-note)) --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/14 19:06:55 1.17 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/14 19:20:41 1.18 @@ -85,6 +85,8 @@ (set-key 'com-rotate-stem-direction 'cluster-table '((#\s :meta))) (set-key 'com-current-increment 'cluster-table '((#\p))) (set-key 'com-current-decrement 'cluster-table '((#\n))) +(set-key 'com-octave-up 'cluster-table '((#\U :shift :meta))) +(set-key 'com-octave-down 'cluster-table '((#\D :shift :meta))) ;;; lyrics mode table

1 0

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

14 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv30173 Modified Files: modes.lisp Log Message: Make com-up and com-down work for rests as well. --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/13 19:39:56 1.16 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/14 19:06:55 1.17 @@ -60,6 +60,8 @@ (set-key 'com-fewer-rbeams 'rhythmic-table '((#\x) (#\]))) (set-key 'com-rotate-notehead 'rhythmic-table '((#\h :meta))) (set-key 'com-rotate-notehead 'rhythmic-table '((#\r :control))) ; why this one too? +(set-key 'com-up 'rhythmic-table '((#\u :meta))) +(set-key 'com-down 'rhythmic-table '((#\d :meta))) ;;; the cluster table contains commands that are specific to ;;; clusters @@ -76,8 +78,6 @@ (set-key 'com-add-note-g 'cluster-table '(#\G)) (set-key 'com-add-note-a 'cluster-table '(#\A)) (set-key 'com-add-note-b 'cluster-table '(#\B)) -(set-key 'com-up 'cluster-table '((#\u :meta))) -(set-key 'com-down 'cluster-table '((#\d :meta))) (set-key 'com-tie-note-left 'cluster-table '((#\{))) (set-key 'com-tie-note-right 'cluster-table '((#\}))) (set-key 'com-untie-note-left 'cluster-table '((#\x) (#\{)))

1 0

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

14 Jun '06

Update of /project/gsharp/cvsroot/gsharp/Scores In directory clnet:/tmp/cvs-serv24264 Modified Files: bach-suite-iv-prelude.gsh Log Message: Typed a few more bars. Now I need to know how to change the key signature in the middle of a staff. --- /project/gsharp/cvsroot/gsharp/Scores/bach-suite-iv-prelude.gsh 2006/06/14 05:01:31 1.2 +++ /project/gsharp/cvsroot/gsharp/Scores/bach-suite-iv-prelude.gsh 2006/06/14 18:24:08 1.3 @@ -4051,62 +4051,57 @@ :staff #2# :head :FILLED :accidentals :NATURAL - :dots 0 ]) ]) ]) ] - :tail [GSHARP-BUFFER:SLICE - :bars ([GSHARP-BUFFER:MELODY-BAR - :elements COMMON-LISP:NIL ]) ] ] - [GSHARP-BUFFER:MELODY-LAYER - :name "treble" - :staves (#1#) - :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 + :dots 0 ]) ]) ] + [GSHARP-BUFFER:MELODY-BAR + :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 2 + :rbeams 1 :lbeams 0 - :dots 0 - :staff #1# - :staff-pos 4 ] + :dots 1 + :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 0 + :rbeams 1 + :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 28 - :staff #1# + :pitch 22 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 2 - :lbeams 2 - :dots 0 + :rbeams 1 + :lbeams 0 + :dots 1 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 29 - :staff #1# + :pitch 20 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 2 + :rbeams 1 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 30 - :staff #1# + :pitch 21 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4118,8 +4113,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 31 - :staff #1# + :pitch 21 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4131,8 +4126,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 32 - :staff #1# + :pitch 18 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4144,8 +4139,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 33 - :staff #1# + :pitch 19 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4157,10 +4152,10 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 31 - :staff #1# + :pitch 20 + :staff #2# :head :FILLED - :accidentals :NATURAL + :accidentals :FLAT :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 @@ -4168,12 +4163,12 @@ :rbeams 2 :lbeams 0 :dots 0 - :stem-direction :UP + :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 34 - :staff #1# + :pitch 21 + :staff #2# :head :FILLED - :accidentals :FLAT + :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 @@ -4183,8 +4178,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 35 - :staff #1# + :pitch 22 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4196,10 +4191,10 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 34 - :staff #1# + :pitch 23 + :staff #2# :head :FILLED - :accidentals :FLAT + :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 @@ -4209,12 +4204,13 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 33 - :staff #1# + :pitch 21 + :staff #2# :head :FILLED :accidentals :NATURAL - :dots 0 ]) ] - [GSHARP-BUFFER:CLUSTER + :dots 0 ]) ]) ] + [GSHARP-BUFFER:MELODY-BAR + :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 @@ -4222,8 +4218,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 32 - :staff #1# + :pitch 24 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4235,8 +4231,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 35 - :staff #1# + :pitch 25 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4248,10 +4244,10 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 34 - :staff #1# + :pitch 24 + :staff #2# :head :FILLED - :accidentals :FLAT + :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 @@ -4261,118 +4257,116 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 35 - :staff #1# + :pitch 23 + :staff #2# :head :FILLED :accidentals :NATURAL - :dots 0 ]) ]) ] - [GSHARP-BUFFER:MELODY-BAR - :elements ([GSHARP-BUFFER:CLUSTER + :dots 0 ]) ] + [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 33 - :staff #1# + :pitch 22 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 - :lbeams 1 + :rbeams 2 + :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 31 - :staff #1# + :pitch 25 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 - :lbeams 0 - :dots 1 + :rbeams 2 + :lbeams 2 + :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 24 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 25 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 0 - :dots 1 + :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 23 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 39 - :staff #1# + :pitch 25 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 - :lbeams 0 - :dots 1 + :rbeams 2 + :lbeams 2 + :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 37 - :staff #1# + :pitch 26 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 27 + :staff #2# :head :FILLED :accidentals :NATURAL - :dots 0 ]) ]) ] - [GSHARP-BUFFER:MELODY-BAR - :elements ([GSHARP-BUFFER:CLUSTER + :dots 0 ]) ] + [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 @@ -4380,8 +4374,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -4393,8 +4387,8 @@ :dots 0 [8965 lines skipped]

1 0

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

14 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv13091 Modified Files: drawing.lisp Log Message: Modify distances between systems and staves to fit a printed A4 better. Constants are still hardcoded, though. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/13 01:18:10 1.69 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/14 05:03:14 1.70 @@ -480,7 +480,7 @@ (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 + for offset from 0 by 70 do (setf (staff-yoffset staff) offset)) (let ((yy y)) (gsharp-measure::new-map-over-obseq-subsequences @@ -493,7 +493,7 @@ (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))))))) + (incf yy (+ 20 (* 70 (length staves)))))))) buffer))))) (define-added-mixin velement () melody-element

1 0

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

14 Jun '06

Update of /project/gsharp/cvsroot/gsharp/Scores In directory clnet:/tmp/cvs-serv13018 Modified Files: bach-suite-iv-prelude.gsh Log Message: Bug fixes and more bars. --- /project/gsharp/cvsroot/gsharp/Scores/bach-suite-iv-prelude.gsh 2006/06/13 04:21:49 1.1 +++ /project/gsharp/cvsroot/gsharp/Scores/bach-suite-iv-prelude.gsh 2006/06/14 05:01:31 1.2 @@ -1,7 +1,7 @@ G#V4 [GSHARP-BUFFER:BUFFER - :min-width 17 + :min-width 12 :spacing-style 0.4 :right-edge 700 :left-offset 30 @@ -3149,6 +3149,14 @@ :head :FILLED :accidentals :NATURAL :dots 0 ]) ] + [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 @@ -3293,36 +3301,29 @@ :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR - :elements COMMON-LISP:NIL ]) ] - :tail [GSHARP-BUFFER:SLICE - :bars ([GSHARP-BUFFER:MELODY-BAR - :elements COMMON-LISP:NIL ]) ] ] - [GSHARP-BUFFER:MELODY-LAYER - :name "treble" - :staves (#1#) - :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 + :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 2 :lbeams 0 :dots 0 - :staff #1# - :staff-pos 4 ] + :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 + :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 28 - :staff #1# + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3334,8 +3335,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 29 - :staff #1# + :pitch 24 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3347,8 +3348,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 30 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3360,8 +3361,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 31 - :staff #1# + :pitch 23 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3373,8 +3374,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 32 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3386,8 +3387,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 33 - :staff #1# + :pitch 22 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3399,8 +3400,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 31 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3410,12 +3411,12 @@ :rbeams 2 :lbeams 0 :dots 0 - :stem-direction :UP + :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 34 - :staff #1# + :pitch 21 + :staff #2# :head :FILLED - :accidentals :FLAT + :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 @@ -3425,8 +3426,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 35 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3438,10 +3439,10 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 34 - :staff #1# + :pitch 22 + :staff #2# :head :FILLED - :accidentals :FLAT + :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 @@ -3451,8 +3452,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 33 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3464,8 +3465,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 32 - :staff #1# + :pitch 23 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3477,8 +3478,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 35 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] @@ -3490,10 +3491,10 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 34 - :staff #1# + :pitch 24 + :staff #2# :head :FILLED - :accidentals :FLAT + :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 @@ -3503,8 +3504,8 @@ :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 35 - :staff #1# + :pitch 28 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] @@ -3512,131 +3513,150 @@ :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 33 - :staff #1# + :pitch 27 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] - [GSHARP-BUFFER:CLUSTER + [GSHARP-BUFFER:REST :xoffset 0 :notehead :FILLED :rbeams 1 - :lbeams 1 + :lbeams 0 + :dots 0 + :staff #2# + :staff-pos 4 ] + [GSHARP-BUFFER:REST + :xoffset 0 + :notehead :FILLED + :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 31 - :staff #1# + :pitch 25 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 - :lbeams 0 - :dots 1 + :rbeams 2 + :lbeams 2 + :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 27 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 29 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 0 - :dots 1 + :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 27 + :staff #2# :head :FILLED - :accidentals :NATURAL + :accidentals :FLAT :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 39 - :staff #1# + :pitch 25 + :staff #2# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 - :lbeams 0 - :dots 1 + :rbeams 2 + :lbeams 2 + :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 37 - :staff #1# + :pitch 27 + :staff #2# :head :FILLED - :accidentals :NATURAL + :accidentals :FLAT :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED - :rbeams 1 + :rbeams 2 :lbeams 2 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE - :pitch 38 - :staff #1# + :pitch 29 + :staff #2# :head :FILLED :accidentals :NATURAL [6341 lines skipped]

1 0

[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

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

07 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv7687 Modified Files: score-pane.lisp sdl.lisp Log Message: Implemented a new beam drawing system. There are still some magic + and - 1s in there that I don't have time to look into right now. However, it should now be possible to draw a beam as a polygon from the output record (the output record was wrong before). --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/06 20:47:42 1.30 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 04:55:07 1.31 @@ -472,20 +472,40 @@ (defclass downward-beam-output-record (beam-output-record) ()) +(defun 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 + (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 + (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 + (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))))) + +(defun 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 + (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 + (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 + (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))))) + (defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane) &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (thickness ink clipping-region light-glyph-p) record + (with-slots (thickness ink clipping-region) record (let ((medium (sheet-medium stream))) - (let ((*light-glyph* light-glyph-p)) - (with-drawing-options - (medium :ink ink :clipping-region clipping-region) - (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) - (*darker-gray-progressions* (darker-gray-progressions stream))) - (draw-downward-beam medium x1 y1 y2 thickness - (/ (- x2 x1) (- y2 y1)))))))))) + (with-drawing-options + (medium :ink ink :clipping-region clipping-region) + (medium-draw-downward-beam* medium x1 y1 x2 (- y2 thickness) thickness)))))) (defclass upward-beam-output-record (beam-output-record) ()) @@ -495,22 +515,17 @@ (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-bounding-rectangle* (x1 y1 x2 y2) record - (with-slots (thickness ink clipping-region light-glyph-p) record + (with-slots (thickness ink clipping-region) record (let ((medium (sheet-medium stream))) - (let ((*light-glyph* light-glyph-p)) - (with-drawing-options - (medium :ink ink :clipping-region clipping-region) - (let ((*lighter-gray-progressions* (lighter-gray-progressions stream)) - (*darker-gray-progressions* (darker-gray-progressions stream))) - (draw-upward-beam medium x1 y2 y1 thickness - (/ (- x2 x1) (- y2 y1)))))))))) + (with-drawing-options + (medium :ink ink :clipping-region clipping-region) + (medium-draw-upward-beam* medium x1 (- y2 thickness) x2 y1 thickness)))))) ;;; 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*)) - (inverse-slope (abs (/ (- x2 x1) (- y2 y1)))) (thickness (- down up))) (cond ((< y1 y2) (when (stream-recording-p *pane*) @@ -520,12 +535,11 @@ (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'downward-beam-output-record - :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2 - :light-glyph-p *light-glyph* + :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*) - (draw-downward-beam medium x1 y1 y2 thickness inverse-slope))) + (medium-draw-downward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness))) (t (when (stream-recording-p *pane*) (multiple-value-bind (xx1 yy1) @@ -534,13 +548,12 @@ (transform-position transformation x2 y2) (stream-add-output-record *pane* (make-instance 'upward-beam-output-record - :x1 xx1 :y1 yy2 :x2 xx2 :y2 yy1 - :light-glyph-p *light-glyph* + :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*) - (draw-upward-beam medium x1 y1 y2 thickness inverse-slope))))))) + (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) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/06 20:52:32 1.28 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 04:55:07 1.29 @@ -108,9 +108,11 @@ (beam-offset-down) (beam-offset-up) (beam-hang-sit-offset :reader beam-hang-sit-offset) - (designs :initform (make-hash-table :test #'eq)) - (beam-designs :initform (make-hash-table :test #'eql)))) + (designs :initform (make-hash-table :test #'eq)))) + +(defparameter *beam-designs* (make-hash-table :test #'equal)) + (defmethod initialize-instance :after ((font font) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (with-slots (staff-line-distance @@ -298,20 +300,18 @@ ;;; ;;; Beams -(defun ensure-beam-segment-design (font direction width) - (with-slots ((sld staff-line-distance)) font - (let* ((key (* (if (eq direction :down) 1 -1) width)) - (thickness (/ sld 2))) - (or (gethash key (slot-value font 'beam-designs)) - (setf (gethash width (slot-value font 'beam-designs)) - (climi::close-path - (if (eq direction :down) - (mf #c(0 0) -- (complex width 1) -- - (complex width (+ thickness 1)) -- - (complex 0 thickness) -- #c(0 0)) - (mf #c(0 0) -- (complex width -1) -- - (complex width (- (- thickness) 1)) -- - (complex 0 (- thickness)) -- #c(0 0))))))))) +(defun ensure-beam-segment-design (direction position width) + (let* ((key (list direction position width))) + (or (gethash key *beam-designs*) + (setf (gethash key *beam-designs*) + (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))) + (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))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1407,3 +1407,18 @@ -1) xoffset)))))) +(defmethod compute-design ((font font) (shape (eql :beam-down-upper))) + (climi::close-path + (mf #c(0 0) -- (complex 16 -1) -- (complex 0 -1) -- #c(0 0)))) + +(defmethod compute-design ((font font) (shape (eql :beam-down-lower))) + (climi::close-path + (mf #c(0 0) -- (complex 16 0) -- (complex 16 -1) -- #c(0 0)))) + +(defmethod compute-design ((font font) (shape (eql :beam-up-upper))) + (climi::close-path + (mf #c(0 0) -- (complex 16 1) -- (complex 16 0) -- #c(0 0)))) + +(defmethod compute-design ((font font) (shape (eql :beam-up-lower))) + (climi::close-path + (mf #c(0 0) -- (complex 16 0) -- (complex 0 -1) -- #c(0 0))))

1 0

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

06 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv5305 Modified Files: sdl.lisp Log Message: Introduced a cache for beam segment designs. This code is not yet used, but it will be I hope. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/05 18:43:56 1.27 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/06 20:52:32 1.28 @@ -108,7 +108,8 @@ (beam-offset-down) (beam-offset-up) (beam-hang-sit-offset :reader beam-hang-sit-offset) - (designs :initform (make-hash-table :test #'eq)))) + (designs :initform (make-hash-table :test #'eq)) + (beam-designs :initform (make-hash-table :test #'eql)))) (defmethod initialize-instance :after ((font font) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) @@ -295,6 +296,25 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Beams + +(defun ensure-beam-segment-design (font direction width) + (with-slots ((sld staff-line-distance)) font + (let* ((key (* (if (eq direction :down) 1 -1) width)) + (thickness (/ sld 2))) + (or (gethash key (slot-value font 'beam-designs)) + (setf (gethash width (slot-value font 'beam-designs)) + (climi::close-path + (if (eq direction :down) + (mf #c(0 0) -- (complex width 1) -- + (complex width (+ thickness 1)) -- + (complex 0 thickness) -- #c(0 0)) + (mf #c(0 0) -- (complex width -1) -- + (complex width (- (- thickness) 1)) -- + (complex 0 (- thickness)) -- #c(0 0))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Clefs ;;; w

1 0

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

06 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv5242 Modified Files: bezier.lisp fontview.lisp Log Message: Cleaned up the bezier rendering a bit, and modified the font viewer accordingly. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 21:49:10 1.6 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/06 20:51:36 1.7 @@ -659,25 +659,41 @@ repeat (nb-lines lines) do (render-scan-lines array pixel-value i (crossings lines i) min-x min-y)))) -(defun render-to-array (positive-areas negative-areas) - (multiple-value-bind (min-x min-y max-x max-y) - (bounding-rectangle-of-areas positive-areas) - (setf min-x (* 4 (floor min-x)) - min-y (* 4 (floor min-y)) - max-x (* 4 (ceiling max-x)) - max-y (* 4 (ceiling max-y))) - (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) - :element-type 'bit :initial-element 1)) - (transformation (make-scaling-transformation* 4 4))) - (loop for area in positive-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 0 min-x min-y))) - (loop for area in negative-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 1 min-x min-y))) - result))) +(defgeneric positive-negative-areas (design)) + +(defmethod positive-negative-areas ((design bezier-area)) + (values (list design) '())) + +(defmethod positive-negative-areas ((design bezier-union)) + (values (areas design) '())) + +(defmethod positive-negative-areas ((design bezier-difference)) + (values (positive-areas design) (negative-areas design))) + +(defmethod positive-negative-areas ((design translated-bezier-design)) + (positive-negative-areas (original-region design))) + +(defun render-to-array (design) + (multiple-value-bind (positive-areas negative-areas) + (positive-negative-areas design) + (multiple-value-bind (min-x min-y max-x max-y) + (bounding-rectangle-of-areas positive-areas) + (setf min-x (* 4 (floor min-x)) + min-y (* 4 (floor min-y)) + max-x (* 4 (ceiling max-x)) + max-y (* 4 (ceiling max-y))) + (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) + :element-type 'bit :initial-element 1)) + (transformation (make-scaling-transformation* 4 4))) + (loop for area in positive-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 0 min-x min-y))) + (loop for area in negative-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 1 min-x min-y))) + result)))) (defparameter *x* 0) (defparameter *y* 0) @@ -697,52 +713,48 @@ (+ (* a 1.0) (* 1-a g)) (+ (* a 1.0) (* 1-a b)))))) -(defun render-through-pixmap (design medium positive-areas negative-areas) +(defgeneric ensure-pixmap (medium design)) + +(defmethod ensure-pixmap (medium design) + (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) + *pixmaps*))) + (when (null pixmap) + (let* ((picture (render-to-array design)) + (height (array-dimension picture 0)) + (width (array-dimension picture 1)) + (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16))) + (loop for l from 0 below height + do (loop for c from 0 below width + do (when (zerop (aref picture l c)) + (decf (aref reduced-picture (floor l 4) (floor c 4)))))) + (setf pixmap + (with-output-to-pixmap (pixmap-medium + (medium-sheet medium) + :width (/ width 4) :height (/ height 4)) + (loop for l from 0 below (/ height 4) + do (loop for c from 0 below (/ width 4) + do (draw-point* + pixmap-medium c l + :ink (make-ink + medium + (aref reduced-picture l c))))))) + (setf (gethash (list (medium-sheet medium) (resolve-ink medium) design) + *pixmaps*) + pixmap))) + pixmap)) + +(defmethod ensure-pixmap (medium (design translated-bezier-design)) + (ensure-pixmap medium (original-region design))) + +(defun render-through-pixmap (design medium) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) (setf min-x (floor min-x) min-y (floor min-y)) - (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) - *pixmaps*))) - (when (null pixmap) - (let* ((picture (render-to-array positive-areas negative-areas)) - (height (array-dimension picture 0)) - (width (array-dimension picture 1)) - (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16))) - (loop for l from 0 below height - do (loop for c from 0 below width - do (when (zerop (aref picture l c)) - (decf (aref reduced-picture (floor l 4) (floor c 4)))))) - (let ((new-pixmap (with-output-to-pixmap (pixmap-medium - (medium-sheet medium) - :width (/ width 4) :height (/ height 4)) - (loop for l from 0 below (/ height 4) - do (loop for c from 0 below (/ width 4) - do (draw-point* - pixmap-medium c l - :ink (make-ink - medium - (aref reduced-picture l c)))))))) - (setf (gethash (list (medium-sheet medium) (resolve-ink medium) design) - *pixmaps*) new-pixmap - pixmap new-pixmap)))) + (let ((pixmap (ensure-pixmap medium design))) (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) (medium-sheet medium) (+ *x* min-x) (+ *y* min-y))))) -(defgeneric render-design-to-array (design)) - -(defmethod render-design-to-array ((design bezier-area)) - (render-to-array (list design) '())) - -(defmethod render-design-to-array ((design bezier-union)) - (render-to-array (areas design) '())) - -(defmethod render-design-to-array ((design bezier-difference)) - (render-to-array (positive-areas design) (negative-areas design))) - -(defmethod render-design-to-array ((design translated-bezier-design)) - (render-design-to-array (original-region design))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Generic drawing @@ -759,16 +771,9 @@ ;;; Drawing bezier designs to screen -;;; Fallback methods (suitable for CLX) -(defmethod medium-draw-bezier-design* (medium (design bezier-area)) - (render-through-pixmap design medium (list design) '())) -(defmethod medium-draw-bezier-design* (medium (design bezier-union)) - (render-through-pixmap design medium (areas design) '())) -(defmethod medium-draw-bezier-design* (medium (design bezier-difference)) - (render-through-pixmap design medium (positive-areas design) (negative-areas design))) -(defmethod medium-draw-bezier-design* (medium (design translated-bezier-design)) - (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) - (medium-draw-bezier-design* medium (original-region design)))) +;;; Fallback method (suitable for CLX) +(defmethod medium-draw-bezier-design* (medium design) + (render-through-pixmap design medium)) ;;; Postscript methods (defmethod medium-draw-bezier-design* --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/02 21:49:10 1.4 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/06 20:51:36 1.5 @@ -49,7 +49,7 @@ min-y (* 4 (floor min-y)) max-x (* 4 (ceiling max-x)) max-y (* 4 (ceiling max-y))) - (let ((array (climi::render-design-to-array design))) + (let ((array (climi::render-to-array design))) (loop for y from min-y below max-y for y-index from 0 do (loop with x0 = nil

1 0

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

06 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv5105 Modified Files: gsharp.asd Log Message: Included the font viewer in the system definition. --- /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/06/05 00:53:40 1.12 +++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/06/06 20:48:53 1.13 @@ -39,4 +39,5 @@ "midi" "modes" "play" - "gui") + "gui" + "fontview")

1 0

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

06 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv5042 Modified Files: score-pane.lisp Log Message: Removed useless code related to the old font-rendering system. --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/05 00:53:41 1.29 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/06 20:47:42 1.30 @@ -3,8 +3,7 @@ (defclass score-view (view) ()) (defclass score-pane (esa-pane-mixin application-pane) - ((pixmaps :initform (make-hash-table :test #'eq) :reader pane-pixmaps) - (darker-gray-progressions :initform (make-array 10 :initial-element nil :adjustable t) + ((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))) @@ -26,23 +25,6 @@ (setf (aref result i) (make-gray-color (/ i 16))) finally (return result))) -;;; Given a pane and a matrix representing a glyph in a font, return a server-side -;;; pixmap that corresponds to that matrix for that pane. Create pixmaps -;;; on demand to avoid initial delays and too many pixmaps in the server. -;;; The elements of the matrix are integers from 0 to 16 inclusive, representing how -;;; many pixels are white in a 4x4 grid. -(defun pane-pixmap (pane matrix) - (or (gethash matrix (pane-pixmaps pane)) - (let* ((dimensions (array-dimensions matrix)) - (height (car dimensions)) - (width (cadr dimensions)) - (pixmap (with-output-to-pixmap (medium pane :height height :width width) - (loop for r from 0 below height do - (loop for c from 0 below width do - (draw-point* medium c r - :ink (aref *gray-levels* - (aref matrix r c)))))))) - (setf (gethash matrix (pane-pixmaps pane)) pixmap)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv22882 Modified Files: sdl.lisp Log Message: Fixed the problem with the C clef. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/05 00:53:41 1.26 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/05 18:43:56 1.27 @@ -492,7 +492,7 @@ ;;; reflected + shifted the thickness of the staff line. (defmethod compute-design ((font font) (shape (eql :c-clef))) - (with-slots ((sld staff-line-distance) staff-line-thickness) font + (with-slots ((sld staff-line-distance) staff-line-thickness yoffset) font (flet ((c (x y) (complex x y))) (let* ( ;; define some x coordinates (xa (ceiling (* 0.5 sld))) @@ -509,7 +509,8 @@ (xk (+ xj (ceiling (* 0.5 sld)))) (xl (+ xe (round staff-line-thickness))) ;; define some y coordinates - (top (* 2 sld)) + (ystart (* 0.5 staff-line-thickness)) + (top (+ (* 2 sld) (* 0.5 staff-line-thickness))) (yd (+ sld (max 1 (round (* 0.1 sld))))) (ye sld) (yg (- top (* 2 staff-line-thickness))) @@ -517,7 +518,7 @@ (yj ye) (yk yj) (yl yh) - (p (mf (c xc 0) (direction #c(2 1)) ++ + (p (mf (c xc ystart) (direction #c(2 1)) ++ (direction #c(1 2)) (c xe ye) & (c xe ye) -- (c (1+ xe) ye) & (c (1+ xe) ye) (direction #c(1 -2)) ++ @@ -530,22 +531,23 @@ (c xd (+ yd (* 0.5 dot-width))) up ++ (c xf top) right ++ (c xk yk) down ++ (c xh (- yh staff-line-thickness)) ++ (c xl yl) & (c xl yl) ++ down (c xi 0))) - (q (translate (yscale p -1) (c 0 (- staff-line-thickness)))) + (q (yscale p -1)) (r (climi::close-path (reduce #'clim:region-union (list p - (mf (c xi 0) -- (c xi (- staff-line-thickness))) (climi::reverse-path q) - (mf (c xc (- staff-line-thickness)) -- (c xc 0))))))) - (clim:region-union - (climi::close-path (mf (c 0 top) -- (c xa top) -- - (c xa (- top)) -- - (c 0 (- top)) -- (c 0 top))) + (mf (c xc (- ystart)) -- (c xc ystart))))))) + (translate (clim:region-union - (climi::close-path (mf (c xb top) -- (c xc top) -- - (c xc (- top)) -- - (c xb (- top)) -- (c xb top))) - (translate r (c 0 staff-line-thickness)))))))) + (climi::close-path (mf (c 0 top) -- (c xa top) -- + (c xa (- top)) -- + (c 0 (- top)) -- (c 0 top))) + (clim:region-union + (climi::close-path (mf (c xb top) -- (c xc top) -- + (c xc (- top)) -- + (c xb (- top)) -- (c xb top))) + r)) + (c 0 yoffset)))))) ;;; ;;;

1 0

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

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv19095 Modified Files: modes.lisp Log Message: Fix M-h in lyrics mode --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/05/23 10:55:26 1.14 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/06/05 10:06:58 1.15 @@ -89,7 +89,7 @@ :inherit-from (rhythmic-table)) (set-key (lambda () (erase-char (cur-element))) 'lyrics-table '((#\h :control))) -(set-key 'com-erase-element 'lyrics-table '((#\h :meta))) +(set-key `(com-erase-element *numeric-argument-marker*) 'lyrics-table '((#\h :meta))) (set-key 'insert-lyrics-element 'lyrics-table '((#\Space :control)))

1 0

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

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv12155 Modified Files: INSTALL Log Message: Removed instruction for making old font system. --- /project/gsharp/cvsroot/gsharp/INSTALL 2006/03/25 22:06:35 1.4 +++ /project/gsharp/cvsroot/gsharp/INSTALL 2006/06/05 01:23:15 1.5 @@ -1,6 +1,6 @@ ;;; Requirements -* A Common Lisp. Known to work: SBCL 0.9.10 +* A Common Lisp. Known to work: SBCL 0.9.12 * McCLIM. The "Laetare Sunday" release is needed, along with ** spatial-trees; @@ -14,10 +14,6 @@ Make sure ASDF knows how to find all of these projects. -;;; Compile the fonts - -$ (cd Fonts; make) - ;;; Start the lisp system ;;; Load the gsharp.asd file or make sure the directory in which it

1 0

[gsharp-cvs] CVS gsharp/Fonts
by rstrandh 05 Jun '06

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp/Fonts In directory clnet:/tmp/cvs-serv9215/Fonts Removed Files: Makefile accents.mf accidentals.mf beams.mf c_clef.mf charmap.mf clefs.mf dot.mf double-flat.mf double-sharp.mf eighth_rest.mf f_clef.mf flags.mf flat.mf g_clef.mf half_rest.mf macros.mf natural.mf noteheads.mf quarter_rest.mf rests.mf sdl.mf sharp.mf ties.mf viewer.lisp whole_rest.mf Log Message: Removed files related to old font system.

1 0

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

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv8356 Modified Files: gsharp.asd packages.lisp score-pane.lisp sdl.lisp Removed Files: gf.lisp Log Message: Removed references to old font system, including the file gf.lisp. --- /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/06/05 00:26:18 1.11 +++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/06/05 00:53:40 1.12 @@ -23,7 +23,6 @@ (gsharp-defsystem (:gsharp :depends-on (:mcclim :flexichain :esa)) "packages" "utilities" - "gf" "bezier" "mf" "sdl" --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/05 00:26:18 1.53 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/05 00:53:40 1.54 @@ -4,15 +4,6 @@ (:export #:ninsert-element #:define-added-mixin #:unicode-to-char #:char-to-unicode)) -(defpackage :gf - (:use :common-lisp) - (:export #:parse-gf-file #:gf-font-comment #:gf-font-chars #:gf-font-design-size - #:gf-font-checksum #:gf-font-horizontal-ratio #:gf-font-vertical-ratio - #:gf-font-min-column #:gf-font-max-column - #:gf-font-min-row #:gf-font-max-row - #:gf-char-no #:gf-char-min-m #:gf-char-max-m - #:gf-char-min-n #:gf-char-max-n #:gf-char-matrix)) - (defpackage :mf (:use :cl) (:export #:make-bezier-segment #:bezier-segment @@ -34,12 +25,12 @@ #:left #:right #:up #:down)) (defpackage :sdl - (:use :common-lisp :gf :mf) + (:use :common-lisp :mf) (:export #:glyph #:staff-line-distance #:staff-line-offsets #:stem-offsets #:bar-line-offsets #:ledger-line-x-offsets #:ledger-line-y-offsets #:notehead-right-offsets #:notehead-left-offsets - #:load-font #:glyph-offsets #:suspended-note-offset + #:make-font #:glyph-offsets #:suspended-note-offset #:beam-offsets #:beam-hang-sit-offset)) (defpackage :score-pane --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/05 00:26:18 1.28 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/05 00:53:41 1.29 @@ -155,38 +155,6 @@ (defun staff-step (n) (* n (/ (staff-line-distance *font*) 2))) -;;; Given a pane, a glyph number, an x position (measured in pixels) -;;; and a y position (measured in staff steps), draw the glyph -;;; at the position in the pane. -;;; The font is organized so that the normal glyph is immediately -;;; followed by a light version of the glyph. Hence, we add 1 -;;; to the glyph number if a light version is desired. -;;; It appears that the resulting y-coordinate (in pixels) has the -;;; same sign as the staff-step argument, which suggests that this -;;; function must be called with a negated staff-step. It might be -;;; better to have this function do the negation. -(defun draw-antialiased-glyph (pane glyph-no x staff-step) - (let* ((extra (if *light-glyph* 1 0)) - (matrix (glyph *font* (+ glyph-no extra))) - (pixmap (pane-pixmap pane matrix))) - (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) - (let ((x1 (+ x dx)) - (y1 (- dy (staff-step staff-step)))) - (draw-pixmap* pane pixmap x1 y1))))) - -;;;;;;;;;;;;;;;;;; helper macro - -;;; This macro is currently not used. (And probably never will be -;;; used, now that we raster our own bezier curves.) -(defmacro define-pixmap-recording ((draw-name args) &body body) - `(defun ,draw-name (pane ,@args x staff-step) - (let* ((extra (if *light-glyph* 1 0)) - (glyph-no ,@body) - (matrix (glyph *font* (+ glyph-no extra))) - (pixmap (pane-pixmap pane matrix))) - (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) - (draw-pixmap* pane pixmap (+ x dx) (- dy (staff-step staff-step))))))) - ;;;;;;;;;;;;;;;;;; notehead (define-presentation-type notehead () :options (name x staff-step)) @@ -701,7 +669,7 @@ `(let ((,size-var ,size)) (unless (aref *fonts* ,size-var) (setf (aref *fonts* ,size-var) - (load-font ,size-var))) + (make-font ,size-var))) (let ((*font* (aref *fonts* ,size-var))) ,@body)))) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 22:03:08 1.25 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/05 00:53:41 1.26 @@ -1,16 +1,5 @@ (in-package :sdl) -(defvar *fonts-directory* - (merge-pathnames (make-pathname :directory '(:relative "Fonts")) - (make-pathname :directory (pathname-directory *load-truename*)))) - -(defgeneric glyph (font glyph-no)) -(defgeneric glyph-offsets (font glyph-no) - (:documentation "Return two values, DX and DY to be added to the reference point of -a glyph in order to obtain its upper-left corner. If (as is usually the case) -the reference point is somewhere inside the bounding box of the glyph, this -means that both the values returned are negative")) - (defgeneric staff-line-distance (font)) (defgeneric staff-line-offsets (font)) (defgeneric stem-offsets (font)) @@ -33,8 +22,7 @@ point of a hanging or sitting beam respectively")) (defclass font () - ((gf-font :initarg :gf-font :reader gf-font) - ;; The distance in pixels between the upper edge of two + (;; The distance in pixels between the upper edge of two ;; adjacent staff lines. (staff-line-distance :initarg :staff-line-distance :reader staff-line-distance) ;; An integer value indicating how many non-white pixels are @@ -120,8 +108,7 @@ (beam-offset-down) (beam-offset-up) (beam-hang-sit-offset :reader beam-hang-sit-offset) - (designs :initform (make-hash-table :test #'eq)) - (glyphs :initarg :glyphs :reader glyphs))) + (designs :initform (make-hash-table :test #'eq)))) (defmethod initialize-instance :after ((font font) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) @@ -200,53 +187,6 @@ (let ((beam-thickness (- beam-offset-down beam-offset-up))) (/ (- beam-thickness staff-line-thickness) 2))))) -(defgeneric gf-char (glyph)) -(defgeneric pixmap (glyph)) -(defgeneric (setf pixmap) (glyph pixmap)) - -(defclass glyph () - ((gf-char :initarg :gf-char :reader gf-char) - (x-offset) - (y-offset) - (pixmap :initform nil :initarg :pixmap :accessor pixmap))) - -(defmethod initialize-instance :after ((glyph glyph) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (with-slots (gf-char x-offset y-offset) glyph - (setf x-offset (floor (gf-char-min-m gf-char) 4) - ;; adding 1 to gv-char-max-n is necessary because - ;; of a discrepancy between the GF documentation - ;; and the GF file format - y-offset (- (ceiling (1+ (gf-char-max-n gf-char)) 4))))) - -(defmethod glyph ((font font) glyph-no) - (with-slots (gf-char pixmap) (aref (glyphs font) glyph-no) - (let ((left (floor (gf-char-min-m gf-char) 4)) - (right (ceiling (1+ (gf-char-max-m gf-char)) 4)) - (down (floor (gf-char-min-n gf-char) 4)) - ;; adding 1 to gv-char-max-n is necessary because - ;; of a discrepancy between the GF documentation - ;; and the GF file format - (up (ceiling (1+ (gf-char-max-n gf-char)) 4)) - (matrix (gf-char-matrix gf-char))) - (unless pixmap - (setf pixmap (make-array (list (- up down) (- right left)) - :element-type '(unsigned-byte 8) - :initial-element 16)) - (loop for r from 0 below (car (array-dimensions matrix)) - for y downfrom (gf-char-max-n gf-char) by 1 do - (loop for c from 0 below (cadr (array-dimensions matrix)) - for x from (gf-char-min-m gf-char) do - (decf (aref pixmap - (- up (ceiling (1+ y) 4)) - (- (floor x 4) left)) - (aref matrix r c)))))) - pixmap)) - -(defmethod glyph-offsets ((font font) glyph-no) - (with-slots (x-offset y-offset) (aref (glyphs font) glyph-no) - (values x-offset y-offset))) - ;;; the DOWN staff line offset is a nonnegative integer, and the UP ;;; staff line offset is a negative integer. This way, both of them ;;; should be ADDED to a reference y value to obtain the lower and @@ -294,19 +234,8 @@ (with-slots (beam-offset-down beam-offset-up) font (values beam-offset-down beam-offset-up))) -(defun load-font (staff-line-distance) - (let* ((gf-font (parse-gf-file (merge-pathnames - (format nil "sdl~a.gf" staff-line-distance) - *fonts-directory*))) - (maxchar (reduce #'max (gf-font-chars gf-font) :key #'gf-char-no)) - (glyphs (make-array (list (1+ maxchar)) :initial-element nil))) - (loop for char in (gf-font-chars gf-font) - do (setf (aref glyphs (gf-char-no char)) - (make-instance 'glyph :gf-char char))) - (make-instance 'font - :staff-line-distance staff-line-distance - :gf-font gf-font - :glyphs glyphs))) +(defun make-font (staff-line-distance) + (make-instance 'font :staff-line-distance staff-line-distance)) (defgeneric xyscale (thing kx ky))

1 0

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

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv4321 Modified Files: score-pane.lisp packages.lisp gsharp.asd Removed Files: charmap.lisp Log Message: Removed code (which was not used anyway) for drawing stacks of notes. I intend to do that differently anyway, by having special versions of glyphs for individual noteheads that have other noteheads above or below. Removed references to old GF glyphs of the form +glyph-xxx+. Removed the file charmap.lisp that contained glyph numbers in GF file. --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/03 21:26:07 1.27 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/05 00:26:18 1.28 @@ -174,41 +174,6 @@ (y1 (- dy (staff-step staff-step)))) (draw-pixmap* pane pixmap x1 y1))))) -;;; Given a pane, an x position (measured in pixels) a y position -;;; (measured in staff steps), a glyph to draw a the bottom of the stack -;;; a glyph to draw at the top of the stack, a glyph to draws in the middle -;;; of the stack, and the number of elements of the stack, draw the stack -;;; by first drawing the lower glyph, then the intermediate glyphs, and -;;; finally the upper glyph. -;;; It appears that this function increases the staff step in each iteration, -;;; which seems incomptible with the way draw-antialiased-glyph appears to work. -;;; This function is currently used only by the three draw-xxx-stack functions, -;;; which in turn are currently not used. -(defun draw-stack (pane glyph-lower glyph-upper glyph-two x staff-step how-many) - (draw-antialiased-glyph pane glyph-lower x staff-step) - (loop for ss from staff-step by 2 - repeat (1- how-many) do - (draw-antialiased-glyph pane glyph-two x ss)) - (draw-antialiased-glyph pane glyph-upper x (+ staff-step (* 2 (1- how-many))))) - -;;; Draw a stack of whole-note noteheads -;;; This function is currently not used. -(defun draw-whole-stack (pane x staff-step how-many) - (draw-stack pane +glyph-whole-lower+ +glyph-whole-upper+ +glyph-whole-two+ - x staff-step how-many)) - -;;; draw a stack of half-note noteheads -;;; This function is currently not used. -(defun draw-half-stack (pane x staff-step how-many) - (draw-stack pane +glyph-half-lower+ +glyph-half-upper+ +glyph-half-two+ - x staff-step how-many)) - -;;; draw a stack of filled noteheads. -;;; This function is currently not used. -(defun draw-filled-stack (pane x staff-step how-many) - (draw-stack pane +glyph-filled-lower+ +glyph-filled-upper+ +glyph-filled-two+ - x staff-step how-many)) - ;;;;;;;;;;;;;;;;;; helper macro ;;; This macro is currently not used. (And probably never will be --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/05 00:06:16 1.52 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/05 00:26:18 1.53 @@ -40,99 +40,7 @@ #:ledger-line-x-offsets #:ledger-line-y-offsets #:notehead-right-offsets #:notehead-left-offsets #:load-font #:glyph-offsets #:suspended-note-offset - #:beam-offsets #:beam-hang-sit-offset - #:+glyph-whole+ #:+glyph-whole-upper+ #:+glyph-whole-lower+ #:+glyph-whole-two+ - #:+glyph-half+ #:+glyph-half-upper+ #:+glyph-half-lower+ #:+glyph-half-two+ - #:+glyph-filled+ #:+glyph-filled-upper+ #:+glyph-filled-lower+ #:+glyph-filled-two+ - #:+glyph-sharp+ #:+glyph-natural+ #:+glyph-flat+ #:+glyph-double-sharp+ - #:+glyph-double-flat+ #:+glyph-g-clef+ #:+glyph-f-clef+ #:+glyph-c-clef+ - #:+glyph-dot+ #:+glyph-whole-rest+ #:+glyph-half-rest+ #:+glyph-quarter-rest+ - #:+glyph-eighth-rest+ #:+glyph-sixteenth-rest+ #:+glyph-thirtysecondth-rest+ - #:+glyph-sixtyfourth-rest+ #:+glyph-onehundredandtwentyeigth-rest+ - #:+glyph-flags-down-one+ #:+glyph-flags-down-two+ #:+glyph-flags-down-three+ - #:+glyph-flags-down-four+ #:+glyph-flags-down-five+ #:+glyph-flags-up-one+ - #:+glyph-flags-up-two+ #:+glyph-flags-up-three+ #:+glyph-flags-up-four+ - #:+glyph-flags-up-five+ - #:+glyph-small-tie-one-up+ - #:+glyph-small-tie-one-up-light+ - #:+glyph-small-tie-two-up+ - #:+glyph-small-tie-two-up-light+ - #:+glyph-small-tie-three-up+ - #:+glyph-small-tie-three-up-light+ - #:+glyph-small-tie-four-up+ - #:+glyph-small-tie-four-up-light+ - #:+glyph-small-tie-five-up+ - #:+glyph-small-tie-five-up-light+ - #:+glyph-small-tie-six-up+ - #:+glyph-small-tie-six-up-light+ - #:+glyph-small-tie-seven-up+ - #:+glyph-small-tie-seven-up-light+ - #:+glyph-small-tie-eight-up+ - #:+glyph-small-tie-eight-up-light+ - #:+glyph-small-tie-one-down+ - #:+glyph-small-tie-one-down-light+ - #:+glyph-small-tie-two-down+ - #:+glyph-small-tie-two-down-light+ - #:+glyph-small-tie-three-down+ - #:+glyph-small-tie-three-down-light+ - #:+glyph-small-tie-four-down+ - #:+glyph-small-tie-four-down-light+ - #:+glyph-small-tie-five-down+ - #:+glyph-small-tie-five-down-light+ - #:+glyph-small-tie-six-down+ - #:+glyph-small-tie-six-down-light+ - #:+glyph-small-tie-seven-down+ - #:+glyph-small-tie-seven-down-light+ - #:+glyph-small-tie-eight-down+ - #:+glyph-small-tie-eight-down-light+ - #:+glyph-large-tie-one-up+ - #:+glyph-large-tie-one-up-light+ - #:+glyph-large-tie-two-up+ - #:+glyph-large-tie-two-up-light+ - #:+glyph-large-tie-three-up+ - #:+glyph-large-tie-three-up-light+ - #:+glyph-large-tie-four-up+ - #:+glyph-large-tie-four-up-light+ - #:+glyph-large-tie-five-up+ - #:+glyph-large-tie-five-up-light+ - #:+glyph-large-tie-six-up+ - #:+glyph-large-tie-six-up-light+ - #:+glyph-large-tie-seven-up+ - #:+glyph-large-tie-seven-up-light+ - #:+glyph-large-tie-eight-up+ - #:+glyph-large-tie-eight-up-light+ - #:+glyph-large-tie-nine-up+ - #:+glyph-large-tie-nine-up-light+ - #:+glyph-large-tie-ten-up+ - #:+glyph-large-tie-ten-up-light+ - #:+glyph-large-tie-left-up+ - #:+glyph-large-tie-left-up-light+ - #:+glyph-large-tie-right-up+ - #:+glyph-large-tie-right-up-light+ - #:+glyph-large-tie-one-down+ - #:+glyph-large-tie-one-down-light+ - #:+glyph-large-tie-two-down+ - #:+glyph-large-tie-two-down-light+ - #:+glyph-large-tie-three-down+ - #:+glyph-large-tie-three-down-light+ - #:+glyph-large-tie-four-down+ - #:+glyph-large-tie-four-down-light+ - #:+glyph-large-tie-five-down+ - #:+glyph-large-tie-five-down-light+ - #:+glyph-large-tie-six-down+ - #:+glyph-large-tie-six-down-light+ - #:+glyph-large-tie-seven-down+ - #:+glyph-large-tie-seven-down-light+ - #:+glyph-large-tie-eight-down+ - #:+glyph-large-tie-eight-down-light+ - #:+glyph-large-tie-nine-down+ - #:+glyph-large-tie-nine-down-light+ - #:+glyph-large-tie-ten-down+ - #:+glyph-large-tie-ten-down-light+ - #:+glyph-large-tie-left-down+ - #:+glyph-large-tie-left-down-light+ - #:+glyph-large-tie-right-down+ - #:+glyph-large-tie-right-down-light+)) + #:beam-offsets #:beam-hang-sit-offset)) (defpackage :score-pane (:use :clim :clim-extensions :clim-lisp :sdl :esa) --- /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/06/05 00:06:16 1.10 +++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/06/05 00:26:18 1.11 @@ -27,7 +27,6 @@ "bezier" "mf" "sdl" - "charmap" "score-pane" "buffer" "numbering"

1 0

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

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv2507 Removed Files: glyphs.lisp postscript.lisp Log Message: Removed useless files.

1 0

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

05 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv2358 Modified Files: packages.lisp gsharp.asd Log Message: Removed entry "glyphs.lisp" which contained glyphs from Common Music Notaion and that we are now sure that we will not need. Removed entry "postscript.lisp" because we are now sure that we will not need it. --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/05/29 19:55:24 1.51 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/05 00:06:16 1.52 @@ -231,32 +231,6 @@ #:timeline #:timelines #:elasticity #:smallest-gap #:elasticity-function)) -(defpackage :gsharp-postscript - (:use :clim :clim-lisp) - (:export #:postscript-path #:make-postscript-path - #:draw-design #:medium-draw-design - #:newpath #:lineto #:curveto #:moveto - #:rlineto #:circle)) - -(defpackage :gsharp-glyphs - (:use :clim :clim-lisp :gsharp-postscript) - (:export #:treble-clef #:percussion-clef #:c-clef #:bass-clef #:turn - #:mordent #:double-mordent #:trill-section #:trill-sections - #:arpeggio #:arpeggios #:tr #:accent #:tnecca #:breath-mark - #:caesura #:fermata #:upside-down-fermata #:repeat-sign - #:upper-bracket #:lower-bracket #:segno #:coda #:pedal-off - #:ped #:left-paren #:right-paren #:wedge #:down-bow #:up-bow - #:zero #:one #:two #:three #:four #:five #:six #:seven - #:eight #:nine #:common-time #:cut-time #:plus #:sharp #:flat - #:double-sharp #:natural #:double-flat #:f #:p #:lig-p #:m - #:n #:niente #:subito #:z #:s #:r #:double-whole-note - #:whole-note #:half-note #:quarter-note #:diamond #:diamond-1 - #:filled-diamond-1 #:rhythmx #:circled-x #:slash #:mslash - #:triangle #:square #:8th-flag-up #:extend-flag-up - #:8th-flag-down #:extend-flag-down #:whole-rest #:half-rest - #:quarter-rest #:8th-rest #:16th-rest #:32nd-rest #:64th-rest - #:128th-rest #:measure-rest #:double-whole-rest)) - (defpackage :gsharp-beaming (:use :common-lisp) (:export #:beaming-single #:beaming-double)) --- /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/05/29 19:55:24 1.9 +++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/06/05 00:06:16 1.10 @@ -33,8 +33,6 @@ "numbering" "Obseq/obseq" "measure" - "postscript" - "glyphs" "beaming" "elasticity" "drawing"

1 0

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

03 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv19234 Modified Files: sdl.lisp Log Message: Fixed the flags. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 05:40:07 1.24 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 22:03:08 1.25 @@ -1322,7 +1322,6 @@ extreme-point & extreme-point ++ (c (- (round (* 0.88 sld)) st) (* -2.5 sld)) up ++ - (c (* 0.75 sld) (* -2.5 sld)) up ++ (c 0 (* -1.3 sld)) & (c 0 (* -1.3 sld)) -- (c 0 0))))) @@ -1333,7 +1332,6 @@ extreme-point & extreme-point ++ (c (- (round (* 0.88 sld)) st) (* -2.5 sld)) up ++ - (c (* 0.75 sld) (* -2.6 sld)) up ++ (direction #c(-1 2)) (c 0 (* (- -1.3 0.625) sld)) & (c 0 (* (- -1.3 0.625) sld)) -- (c 0 (* -1.4 sld))))))

1 0

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

03 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv12624 Modified Files: score-pane.lisp Log Message: Fixed the y offset of stems wrt the reference point of the notehead which generated ugly PS output. --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/02 14:11:10 1.26 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/03 21:26:07 1.27 @@ -429,13 +429,11 @@ (defun draw-right-stem (pane x y1 y2) (multiple-value-bind (dx dy) (notehead-right-offsets *font*) - (declare (ignore dy)) - (draw-stem pane (+ x dx) y1 y2))) + (draw-stem pane (+ x dx) (- y1 dy) y2))) (defun draw-left-stem (pane x y1 y2) (multiple-value-bind (dx dy) (notehead-left-offsets *font*) - (declare (ignore dy)) - (draw-stem pane (+ x dx) y1 y2))) + (draw-stem pane (+ x dx) (- y1 dy) y2))) ;;;;;;;;;;;;;;;;;; ledger line

1 0

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

03 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv23201 Modified Files: sdl.lisp Log Message: Improved F-clef. This gave me the opportunity to use the Metafont `curl' operator for the first time. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 04:59:56 1.23 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 05:40:07 1.24 @@ -666,7 +666,7 @@ (xc (+ xa bigdot-diameter)) (yc ya) (xd xb) (xe (* 0.85 sld)) (ye (- sld (* 2.0 staff-line-thickness))) - (xf (round (* 1.5 sld))) (yf (- 0.5 sld)) + (xf (round (* 1.5 sld))) (yf (- 0.3 sld)) (xg 0.0) (yg (* -2.5 sld)) (xh (+ xf (round (* 0.5 sld)))) (yh yf) (xi sld) (yi sld) @@ -679,12 +679,12 @@ left (c xd yd) & (c xd yd) ++ (c xe ye) right ++ - (c xf yf) down ++ + (c xf yf) (direction #c(-0.2 -1)) ++ (curl 3) (c xg yg) & (c xg yg) -- (c xg (1- yg)) & - (c xg (1- yg)) ++ - (c xh yh) up ++ + (c xg (1- yg)) (curl 3) ++ + (c xh yh) (direction #c(0.2 1)) ++ (c xi yi) left ++ cycle))) (clim:region-union (translate p (c 0 staff-line-thickness))

1 0

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

03 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv18042 Modified Files: sdl.lisp Log Message: Increase the size of the dot slightly. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 04:45:42 1.22 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 04:59:56 1.23 @@ -761,12 +761,14 @@ ;;; both vertically and horizontally. ;;; Ross says the dot should be roughly a third of the staff line -;;; distance. We count on anti aliasing to save us from too ugly a -;;; result when the edges do not fall on pixel boundaries. +;;; distance, but in his examples, it is closer to half a staff line +;;; distance. Compromise by using 0.4. We count on anti aliasing to +;;; save us from too ugly a result when the edges do not fall on pixel +;;; boundaries. (defmethod compute-design ((font font) (shape (eql :dot))) (with-slots (yoffset staff-line-distance) font - (let ((diameter (* 0.33 staff-line-distance))) + (let ((diameter (* 0.4 staff-line-distance))) (translate (scale +full-circle+ diameter) (complex yoffset yoffset)))))

1 0

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

03 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv16278 Modified Files: sdl.lisp Log Message: Fixed the reference point of the whole and half rests. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/02 13:17:35 1.21 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/03 04:45:42 1.22 @@ -1225,18 +1225,20 @@ ;;; Rests (defmethod compute-design ((font font) (shape (eql :whole-rest))) - (with-slots ((sld staff-line-distance) notehead-width xoffset yoffset) font + (with-slots ((sld staff-line-distance) (slt staff-line-thickness) + notehead-width xoffset yoffset) font (flet ((c (x y) (complex x y))) - (translate (xyscale (translate +unit-square+ #c(-0.5 0)) + (translate (xyscale +unit-square+ notehead-width (* 0.5 sld)) - (c xoffset (+ yoffset (* 0.5 sld))))))) + (c xoffset (+ yoffset sld (- (* 0.25 sld)) (- (* 0.5 slt)))))))) (defmethod compute-design ((font font) (shape (eql :half-rest))) - (with-slots ((sld staff-line-distance) notehead-width xoffset yoffset) font + (with-slots ((sld staff-line-distance) (slt staff-line-thickness) + notehead-width xoffset yoffset) font (flet ((c (x y) (complex x y))) - (translate (xyscale (translate +unit-square+ #c(-0.5 0)) + (translate (xyscale +unit-square+ notehead-width (* 0.5 sld)) - (c xoffset yoffset))))) + (c xoffset (+ yoffset (* 0.25 sld) (* 0.5 slt))))))) (defmethod compute-design ((font font) (shape (eql :quarter-rest))) (with-slots ((sld staff-line-distance) stem-thickness) font

1 0

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

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv25428 Modified Files: bezier.lisp fontview.lisp Log Message: Fixed a minor bug in bezier.lisp (reference to an undefined variable). Improved the font viewer so that it now takes an optional argument indicating which shape to render. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 14:54:16 1.5 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 21:49:10 1.6 @@ -751,7 +751,7 @@ (climi::with-medium-options (sheet options) (medium-draw-bezier-design* sheet design))) -(defmethod draw-design (medium (design bezier-design) &rest args &key &allow-other-keys) +(defmethod draw-design (medium (design bezier-design) &rest options &key &allow-other-keys) (apply #'draw-bezier-design* medium design options)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 18:57:40 1.3 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/02 21:49:10 1.4 @@ -7,7 +7,7 @@ (define-application-frame fontview () ((font :initform (make-instance 'sdl::font :staff-line-distance 6)) - (shape :initform :g-clef) + (shape :initarg :shape :initform :g-clef) (grid :initform t) (staff :initform t) (staff-offset :initform 0) @@ -99,8 +99,8 @@ (display-antialiased-view frame pane) (display-pixel-view frame pane)))) -(defun fontview () - (let ((frame (make-application-frame 'fontview))) +(defun fontview (&optional (shape :g-clef)) + (let ((frame (make-application-frame 'fontview :shape shape))) (run-frame-top-level frame))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

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

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv3551 Modified Files: bezier.lisp Log Message: Implement postscript methods for drawing bezier stuff. * new superclass bezier-design; * new functions {,medium-}draw-bezier-design* * translated-region -> translated-bezier-design * zap medium-draw-design*. We preserve the translated-bezier-design because (it turns out) otherwise the X11 backend is slow as molasses. No gtkairo methods yet, because of the strange jumping designs (and also because it's not clear how to manage the dependency). Now code of the form (in-package :gsharp) (define-gsharp-command (com-hacky-print :name t) () (with-open-file (ps "/tmp/foo.ps" :direction :output :if-exists :supersede) (with-output-to-postscript-stream (s ps) (setf (stream-default-view s) (make-instance 'orchestra-view :buffer (current-buffer *application-frame*) :cursor (current-cursor))) (setf (medium-transformation s) (compose-scaling-with-transformation (medium-transformation s) 0.5 0.5)) (draw-buffer s (current-buffer *application-frame*) (current-cursor) (left-margin (current-buffer *application-frame*)) 100)))) draws a buffer to /tmp/foo.ps. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 18:57:40 1.4 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 14:54:16 1.5 @@ -56,12 +56,9 @@ (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v)))) -;;; the CLIM spec does not mention the existence of -;;; medium-draw-design*, but I assume it has to exist -;;; RS 2006-05-27 +(defclass bezier-design (design) ()) -;;; define the trampoline method from a sheet to a medium -(def-graphic-op draw-design (design)) +(defgeneric medium-draw-bezier-design* (stream design)) (defclass bezier-design-output-record (standard-graphics-displayed-output-record) ((stream :initarg :stream) @@ -72,7 +69,7 @@ (setf (rectangle-edges* record) (bounding-rectangle* design)))) -(defmethod medium-draw-design* :around ((stream output-recording-stream) design) +(defmethod medium-draw-bezier-design* :around ((stream output-recording-stream) design) (with-sheet-medium (medium stream) (let ((transformed-design (transform-region (medium-transformation medium) design))) (when (stream-recording-p stream) @@ -81,13 +78,13 @@ :design transformed-design))) (stream-add-output-record stream record))) (when (stream-drawing-p stream) - (medium-draw-design* medium design))))) + (medium-draw-bezier-design* medium design))))) (defmethod replay-output-record ((record bezier-design-output-record) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) (with-slots (design) record - (medium-draw-design* (sheet-medium stream) design))) + (medium-draw-bezier-design* (sheet-medium stream) design))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -193,11 +190,11 @@ (call-next-method)))) ;;; A region that translates a different region -(defclass translated-region (region) +(defclass translated-bezier-design (region bezier-design) ((%translation :initarg :translation :reader translation) (%region :initarg :region :reader original-region))) -(defmethod bounding-rectangle* ((region translated-region)) +(defmethod bounding-rectangle* ((region translated-bezier-design)) (let ((translation (translation region))) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* (original-region region)) @@ -210,7 +207,7 @@ (defgeneric really-transform-region (transformation region)) ;;; an area defined as a closed path of Bezier curve segments -(defclass bezier-area (area segments-mixin bounding-rectangle-mixin) ()) +(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) ()) (defgeneric close-path (path)) @@ -243,7 +240,7 @@ (defmethod transform-region (transformation (area bezier-area)) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) @@ -253,7 +250,7 @@ ;;; Special cases of combined Bezier areas ;;; A union of bezier areas. This is not itself a bezier area. -(defclass bezier-union (area) +(defclass bezier-union (area bezier-design) ((%areas :initarg :areas :initform '() :reader areas))) (defmethod really-transform-region (transformation (area bezier-union)) @@ -264,7 +261,7 @@ (defmethod transform-region (transformation (area bezier-union)) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) @@ -300,7 +297,7 @@ (make-instance 'bezier-union :areas (append (areas r1) (areas r2)))) -(defclass bezier-difference (area) +(defclass bezier-difference (area bezier-design) ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas) (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas))) @@ -315,7 +312,7 @@ (defmethod transform-region (transformation (area bezier-difference)) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) @@ -732,19 +729,6 @@ (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) (medium-sheet medium) (+ *x* min-x) (+ *y* min-y))))) -(defmethod medium-draw-design* (medium (design bezier-area)) - (render-through-pixmap design medium (list design) '())) - -(defmethod medium-draw-design* (medium (design bezier-union)) - (render-through-pixmap design medium (areas design) '())) - -(defmethod medium-draw-design* (medium (design bezier-difference)) - (render-through-pixmap design medium (positive-areas design) (negative-areas design))) - -(defmethod medium-draw-design* (medium (design translated-region)) - (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) - (medium-draw-design* medium (original-region design)))) - (defgeneric render-design-to-array (design)) (defmethod render-design-to-array ((design bezier-area)) @@ -756,76 +740,134 @@ (defmethod render-design-to-array ((design bezier-difference)) (render-to-array (positive-areas design) (negative-areas design))) -(defmethod render-design-to-array ((design translated-region)) +(defmethod render-design-to-array ((design translated-bezier-design)) (render-design-to-array (original-region design))) -(defmethod draw-design (sheet design &rest args &key &allow-other-keys) - (climi::with-medium-options (sheet args) - (medium-draw-design* medium design))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Generic drawing + +(defun draw-bezier-design* (sheet design &rest options) + (climi::with-medium-options (sheet options) + (medium-draw-bezier-design* sheet design))) + +(defmethod draw-design (medium (design bezier-design) &rest args &key &allow-other-keys) + (apply #'draw-bezier-design* medium design options)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Drawing bezier designs to screen + + +;;; Fallback methods (suitable for CLX) +(defmethod medium-draw-bezier-design* (medium (design bezier-area)) + (render-through-pixmap design medium (list design) '())) +(defmethod medium-draw-bezier-design* (medium (design bezier-union)) + (render-through-pixmap design medium (areas design) '())) +(defmethod medium-draw-bezier-design* (medium (design bezier-difference)) + (render-through-pixmap design medium (positive-areas design) (negative-areas design))) +(defmethod medium-draw-bezier-design* (medium (design translated-bezier-design)) + (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) + (medium-draw-bezier-design* medium (original-region design)))) + +;;; Postscript methods +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design bezier-area)) + (let ((stream (clim-postscript::postscript-medium-file-stream medium)) + (clim-postscript::*transformation* (sheet-native-transformation (medium-sheet medium)))) + (clim-postscript::postscript-actualize-graphics-state stream medium :color) + (format stream "newpath~%") + (let ((p0 (slot-value (car (segments design)) 'p0))) + (clim-postscript::write-coordinates stream (point-x p0) (point-y p0)) + (format stream "moveto~%")) + (loop for segment in (segments design) + do (with-slots (p1 p2 p3) segment + (clim-postscript::write-coordinates stream (point-x p1) (point-y +p1)) + (clim-postscript::write-coordinates stream (point-x p2) (point-y +p2)) + (clim-postscript::write-coordinates stream (point-x p3) (point-y +p3)) + (format stream "curveto~%"))) + (format stream "fill~%"))) +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design bezier-union)) + (dolist (area (areas design)) + (medium-draw-bezier-design* medium area))) +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design bezier-difference)) + (dolist (area (positive-areas design)) + (medium-draw-bezier-design* medium area)) + (with-drawing-options (medium :ink +background-ink+) + (dolist (area (negative-areas design)) + (medium-draw-bezier-design* medium area)))) +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design translated-bezier-design)) + (medium-draw-bezier-design* medium (really-transform-region (translation design) (original-region design)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Special cases on region-union and region-intersection -(defmethod region-union ((r1 translated-region) (r2 bezier-curve)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-curve)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 translated-region) (r2 bezier-area)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-area)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 translated-region) (r2 bezier-union)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-union)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 translated-region) (r2 bezier-difference)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-difference)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 bezier-curve) (r2 translated-region)) +(defmethod region-union ((r1 bezier-curve) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 bezier-area) (r2 translated-region)) +(defmethod region-union ((r1 bezier-area) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 bezier-union) (r2 translated-region)) +(defmethod region-union ((r1 bezier-union) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 bezier-difference) (r2 translated-region)) +(defmethod region-union ((r1 bezier-difference) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 translated-region) (r2 translated-region)) +(defmethod region-union ((r1 translated-bezier-design) (r2 translated-bezier-design)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-curve)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-curve)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-area)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-area)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-union)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-union)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-difference)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-difference)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 bezier-curve) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-curve) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 bezier-area) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-area) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 bezier-union) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-union) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 bezier-difference) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-difference) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 translated-region) (r2 translated-region)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod transform-region (transformation (region translated-region)) +(defmethod transform-region (transformation (region translated-bezier-design)) (let ((combined-transformation (compose-transformations transformation (translation region)))) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation combined-transformation :region (original-region region)) (transform-region combined-transformation (original-region region)))))

1 0

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

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv30880 Modified Files: score-pane.lisp Log Message: Use the new code for all the pixmap-recording things (noteheads, rests, ties, flags, accidentals). Some degradation in output as a result * misalignments between stems and noteheads; * whole and half rests do not line up with staff lines; * flag has a discontinuity near the extreme point on the inside. (Possibly others. On the other hand, this means that with my local modifications I can produce things like <http://www-jcsu.jesus.cam.ac.uk/~csr21/gsharp-cris.ps>) --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/05/30 02:13:26 1.25 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/02 14:11:10 1.26 @@ -211,6 +211,8 @@ ;;;;;;;;;;;;;;;;;; helper macro +;;; This macro is currently not used. (And probably never will be +;;; used, now that we raster our own bezier curves.) (defmacro define-pixmap-recording ((draw-name args) &body body) `(defun ,draw-name (pane ,@args x staff-step) (let* ((extra (if *light-glyph* 1 0)) @@ -222,14 +224,16 @@ ;;;;;;;;;;;;;;;;;; notehead -(define-pixmap-recording (draw-notehead (name)) - (ecase name - (:whole +glyph-whole+) - (:half +glyph-half+) - (:filled +glyph-filled+))) - (define-presentation-type notehead () :options (name x staff-step)) +(defun draw-notehead (stream name x staff-step) + (sdl::draw-shape stream *font* + (ecase name + (:whole :whole-notehead) + (:half :half-notehead) + (:filled :filled-notehead)) + x (staff-step (- staff-step)))) + (define-presentation-method present (object (type notehead) stream (view score-view) &key) (with-output-as-presentation (stream object 'notehead) @@ -237,31 +241,19 @@ ;;;;;;;;;;;;;;;;;; accidental -(define-pixmap-recording (draw-accidental (name)) - (ecase name - (:natural +glyph-natural+) - (:flat +glyph-flat+) - (:double-flat +glyph-double-flat+) - (:sharp +glyph-sharp+) - (:double-sharp +glyph-double-sharp+))) +(defun draw-accidental (stream name x staff-step) + (sdl::draw-shape stream *font* name x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; clef -(define-pixmap-recording (draw-clef (name)) - (ecase name - ;; FIXME: while using the same glyph for :TREBLE and :TREBLE8 is - ;; fine from a musical point of view, some differentiation (by - ;; putting an italic 8 underneath, for instance) would be good. - ((:treble :treble8) +glyph-g-clef+) - (:bass +glyph-f-clef+) - (:c +glyph-c-clef+))) - -(defun new-draw-clef (stream name x staff-step) +(defun draw-clef (stream name x staff-step) (sdl::draw-shape stream *font* (ecase name - ;; FIXME: while using the same glyph for :TREBLE and :TREBLE8 is - ;; fine from a musical point of view, some differentiation (by - ;; putting an italic 8 underneath, for instance) would be good. + ;; FIXME: while using the same glyph for :TREBLE + ;; and :TREBLE8 is fine from a musical point of + ;; view, some differentiation (by putting an + ;; italic 8 underneath, for instance) would be + ;; good. ((:treble :treble8) :g-clef) (:bass :f-clef) (:c :c-clef)) @@ -272,45 +264,52 @@ (define-presentation-method present (object (type clef) stream (view score-view) &key) (with-output-as-presentation (stream object 'clef) - (new-draw-clef stream name x staff-step))) + (draw-clef stream name x staff-step))) ;;;;;;;;;;;;;;;;;; rest -(define-pixmap-recording (draw-rest (duration)) - (ecase duration - (1 +glyph-whole-rest+) - (1/2 +glyph-half-rest+) - (1/4 +glyph-quarter-rest+) - (1/8 +glyph-eighth-rest+) - (1/16 +glyph-sixteenth-rest+) - (1/32 +glyph-thirtysecondth-rest+) - (1/64 +glyph-sixtyfourth-rest+) - (1/128 +glyph-onehundredandtwentyeigth-rest+))) +(defun draw-rest (stream duration x staff-step) + (sdl::draw-shape stream *font* + (ecase duration + (1 :whole-rest) + (1/2 :half-rest) + (1/4 :quarter-rest) + (1/8 :8th-rest) + (1/16 :16th-rest) + (1/32 :32nd-rest) + (1/64 :64th-rest) + ;; FIXME 128th + ) + x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; flags down -(define-pixmap-recording (draw-flags-down (nb)) - (ecase nb - (1 +glyph-flags-down-one+) - (2 +glyph-flags-down-two+) - (3 +glyph-flags-down-three+) - (4 +glyph-flags-down-four+) - (5 +glyph-flags-down-five+))) +(defun draw-flags-down (stream nb x staff-step) + (sdl::draw-shape stream *font* + (ecase nb + (1 :flags-down-1) + (2 :flags-down-2) + (3 :flags-down-3) + (4 :flags-down-4) + (5 :flags-down-5)) + x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; flags up -(define-pixmap-recording (draw-flags-up (nb)) - (ecase nb - (1 +glyph-flags-up-one+) - (2 +glyph-flags-up-two+) - (3 +glyph-flags-up-three+) - (4 +glyph-flags-up-four+) - (5 +glyph-flags-up-five+))) +(defun draw-flags-up (stream nb x staff-step) + (sdl::draw-shape stream *font* + (ecase nb + (1 :flags-up-1) + (2 :flags-up-2) + (3 :flags-up-3) + (4 :flags-up-4) + (5 :flags-up-5)) + x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; dot -(define-pixmap-recording (draw-dot ()) - +glyph-dot+) +(defun draw-dot (stream x staff-step) + (sdl::draw-shape stream *font* :dot x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; staff line @@ -652,58 +651,60 @@ (xx2 (round (- x2 (staff-step 10)))) (y1 (- (round (staff-step (+ staff-step 11/3))))) (thickness (round (staff-step 2/3)))) - (draw-antialiased-glyph pane +glyph-large-tie-left-up+ xx1 staff-step) - (draw-antialiased-glyph pane +glyph-large-tie-right-up+ xx2 staff-step) + (sdl::draw-shape pane *font* :large-tie-up-left xx1 (staff-step (- staff-step))) + (sdl::draw-shape pane *font* :large-tie-up-right xx2 (staff-step (- staff-step))) (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness))) - (let ((glyph-no (cond ((> dist 18) +glyph-large-tie-ten-up+) - ((> dist 17) +glyph-large-tie-nine-up+) - ((> dist 16) +glyph-large-tie-eight-up+) - ((> dist 15) +glyph-large-tie-seven-up+) - ((> dist 14) +glyph-large-tie-six-up+) - ((> dist 13) +glyph-large-tie-five-up+) - ((> dist 12) +glyph-large-tie-four-up+) - ((> dist 11) +glyph-large-tie-three-up+) - ((> dist 10) +glyph-large-tie-two-up+) - ((> dist 9) +glyph-large-tie-one-up+) - ((> dist 8) +glyph-small-tie-eight-up+) - ((> dist 7) +glyph-small-tie-seven-up+) - ((> dist 6) +glyph-small-tie-six-up+) - ((> dist 5) +glyph-small-tie-five-up+) - ((> dist 4) +glyph-small-tie-four-up+) - ((> dist 3) +glyph-small-tie-three-up+) - ((> dist 2) +glyph-small-tie-two-up+) - (t +glyph-small-tie-one-up+)))) - (draw-antialiased-glyph pane glyph-no (round (* 0.5 (+ x1 x2))) staff-step))))) + (let ((glyph-name (cond ((> dist 18) :large-tie-10-up) + ((> dist 17) :large-tie-9-up) + ((> dist 16) :large-tie-8-up) + ((> dist 15) :large-tie-7-up) + ((> dist 14) :large-tie-6-up) + ((> dist 13) :large-tie-5-up) + ((> dist 12) :large-tie-4-up) + ((> dist 11) :large-tie-3-up) + ((> dist 10) :large-tie-2-up) + ((> dist 9) :large-tie-1-up) + ((> dist 8) :small-tie-8-up) + ((> dist 7) :small-tie-7-up) + ((> dist 6) :small-tie-6-up) + ((> dist 5) :small-tie-5-up) + ((> dist 4) :small-tie-4-up) + ((> dist 3) :small-tie-3-up) + ((> dist 2) :small-tie-2-up) + (t :small-tie-1-up)))) + (sdl::draw-shape pane *font* glyph-name + (round (* 0.5 (+ x1 x2))) (staff-step (- staff-step))))))) (defun draw-tie-down (pane x1 x2 staff-step) (let ((dist (/ (- x2 x1) (staff-step 4/3)))) (if (> dist 19) (let ((xx1 (round (+ x1 (staff-step 10)))) (xx2 (round (- x2 (staff-step 10)))) - (y1 (- (round (staff-step (+ staff-step 11/3))))) + (y1 (- (round (staff-step (- staff-step 8/3))))) (thickness (round (staff-step 2/3)))) - (draw-antialiased-glyph pane +glyph-large-tie-left-down+ xx1 staff-step) - (draw-antialiased-glyph pane +glyph-large-tie-right-down+ xx2 staff-step) + (sdl::draw-shape pane *font* :large-tie-down-left xx1 (staff-step (- staff-step))) + (sdl::draw-shape pane *font* :large-tie-down-right xx2 (staff-step (- staff-step))) (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness))) - (let ((glyph-no (cond ((> dist 18) +glyph-large-tie-ten-down+) - ((> dist 17) +glyph-large-tie-nine-down+) - ((> dist 16) +glyph-large-tie-eight-down+) - ((> dist 15) +glyph-large-tie-seven-down+) - ((> dist 14) +glyph-large-tie-six-down+) - ((> dist 13) +glyph-large-tie-five-down+) - ((> dist 12) +glyph-large-tie-four-down+) - ((> dist 11) +glyph-large-tie-three-down+) - ((> dist 10) +glyph-large-tie-two-down+) - ((> dist 9) +glyph-large-tie-one-down+) - ((> dist 8) +glyph-small-tie-eight-down+) - ((> dist 7) +glyph-small-tie-seven-down+) - ((> dist 6) +glyph-small-tie-six-down+) - ((> dist 5) +glyph-small-tie-five-down+) - ((> dist 4) +glyph-small-tie-four-down+) - ((> dist 3) +glyph-small-tie-three-down+) - ((> dist 2) +glyph-small-tie-two-down+) - (t +glyph-small-tie-one-down+)))) - (draw-antialiased-glyph pane glyph-no (round (* 0.5 (+ x1 x2))) staff-step))))) + (let ((glyph-name (cond ((> dist 18) :large-tie-10-down) + ((> dist 17) :large-tie-9-down) + ((> dist 16) :large-tie-8-down) + ((> dist 15) :large-tie-7-down) + ((> dist 14) :large-tie-6-down) + ((> dist 13) :large-tie-5-down) + ((> dist 12) :large-tie-4-down) + ((> dist 11) :large-tie-3-down) + ((> dist 10) :large-tie-2-down) + ((> dist 9) :large-tie-1-down) + ((> dist 8) :small-tie-8-down) + ((> dist 7) :small-tie-7-down) + ((> dist 6) :small-tie-6-down) + ((> dist 5) :small-tie-5-down) + ((> dist 4) :small-tie-4-down) + ((> dist 3) :small-tie-3-down) + ((> dist 2) :small-tie-2-down) + (t :small-tie-1-down)))) + (sdl::draw-shape pane *font* glyph-name + (round (* 0.5 (+ x1 x2))) (staff-step (- staff-step))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv25227 Modified Files: sdl.lisp Log Message: Implement the large (outsize) tie left and right curves. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/02 12:37:47 1.20 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/02 13:17:35 1.21 @@ -883,6 +883,36 @@ (c (- (- width 1.0)) (- top height)) -- (c (- width) (- top height)) ++ cycle)))) +(defun large-tie-up-left (sld slt width-multiplier) + (declare (ignore slt)) + (let* ((thickness (round (* 0.33 sld))) + (height (round (* 1.0 sld))) + (top (round (* 11/6 sld))) + (width (* width-multiplier sld))) + (flet ((c (x y) (complex x y))) + (climi::close-path + (mf (c 0.0 top) left ++ + (c (- width) (- top height)) -- + (c (- (- width 1.0)) (- top height)) ++ + (c (* -0.3 width) (- top thickness)) ++ + (c 0.0 (- top thickness)) & + (c 0.0 (- top thickness)) -- (c 0.0 top)))))) + +(defun large-tie-up-right (sld slt width-multiplier) + (declare (ignore slt)) + (let* ((thickness (round (* 0.33 sld))) + (height (round (* 1.0 sld))) + (top (round (* 11/6 sld))) + (width (* width-multiplier sld))) + (flet ((c (x y) (complex x y))) + (climi::close-path + (mf (c 0.0 top) right ++ + (c width (- top height)) -- + (c (- width 1.0) (- top height)) ++ + (c (* 0.3 width) (- top thickness)) ++ + (c 0.0 (- top thickness)) & + (c 0.0 (- top thickness)) -- (c 0.0 top)))))) + (defmethod compute-design ((font font) (shape (eql :large-tie-1-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font (large-tie-up sld slt 2.0))) @@ -923,6 +953,14 @@ (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font (large-tie-up sld slt 5.0))) +(defmethod compute-design ((font font) (shape (eql :large-tie-up-left))) + (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font + (large-tie-up-left sld slt 5.0))) + +(defmethod compute-design ((font font) (shape (eql :large-tie-up-right))) + (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font + (large-tie-up-right sld slt 5.0))) + (defun large-tie-down (sld slt width-multiplier) (let* ((thickness (round (* 0.33 sld))) (height (round (* 1.0 sld))) @@ -938,6 +976,34 @@ (c (- (- width 1.0)) (- height bot)) -- (c (- width) (- height bot)) ++ cycle)))) +(defun large-tie-down-left (sld slt width-multiplier) + (let* ((thickness (round (* 0.33 sld))) + (height (round (* 1.0 sld))) + (bot (- (round(* 11/6 sld)) slt)) + (width (* width-multiplier sld))) + (flet ((c (x y) (complex x y))) + (climi::close-path + (mf (c 0.0 (- bot)) left ++ + (c (- width) (- height bot)) -- + (c (- (- width 1.0)) (- height bot)) ++ + (c (* -0.3 width) (- thickness bot)) ++ + (c 0.0 (- thickness bot)) & + (c 0.0 (- thickness bot)) -- (c 0.0 (- bot))))))) + +(defun large-tie-down-right (sld slt width-multiplier) + (let* ((thickness (round (* 0.33 sld))) + (height (round (* 1.0 sld))) + (bot (- (round(* 11/6 sld)) slt)) + (width (* width-multiplier sld))) + (flet ((c (x y) (complex x y))) + (climi::close-path + (mf (c 0.0 (- bot)) right ++ + (c width (- height bot)) -- + (c (- width 1.0) (- height bot)) ++ + (c (* 0.3 width) (- thickness bot)) ++ + (c 0.0 (- thickness bot)) & + (c 0.0 (- thickness bot)) -- (c 0.0 (- bot))))))) + (defmethod compute-design ((font font) (shape (eql :large-tie-1-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font (large-tie-down sld slt 2.0))) @@ -978,6 +1044,14 @@ (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font (large-tie-down sld slt 5.0))) +(defmethod compute-design ((font font) (shape (eql :large-tie-down-left))) + (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font + (large-tie-down-left sld slt 5.0))) + +(defmethod compute-design ((font font) (shape (eql :large-tie-down-right))) + (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font + (large-tie-down-right sld slt 5.0))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Accidentals

1 0

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

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv19736 Modified Files: sdl.lisp Log Message: Fix large-tie glyphs and whole-rest glyph. (Note that there is clearly an offset problem: the half- and whole- rests do not lie on / hang cleanly from staff lines, with or without this change) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 18:57:40 1.19 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/02 12:37:47 1.20 @@ -885,43 +885,43 @@ (defmethod compute-design ((font font) (shape (eql :large-tie-1-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 2.0 sld))))) + (large-tie-up sld slt 2.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-2-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 2.33 sld))))) + (large-tie-up sld slt 2.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-3-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 2.67 sld))))) + (large-tie-up sld slt 2.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-4-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 3.0 sld))))) + (large-tie-up sld slt 3.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-5-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 3.33 sld))))) + (large-tie-up sld slt 3.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-6-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 3.67 sld))))) + (large-tie-up sld slt 3.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-7-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 4.0 sld))))) + (large-tie-up sld slt 4.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-8-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 4.33 sld))))) + (large-tie-up sld slt 4.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-9-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 4.67 sld))))) + (large-tie-up sld slt 4.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-10-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 5.0 sld))))) + (large-tie-up sld slt 5.0))) (defun large-tie-down (sld slt width-multiplier) (let* ((thickness (round (* 0.33 sld))) @@ -940,43 +940,43 @@ (defmethod compute-design ((font font) (shape (eql :large-tie-1-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 2.0 sld))))) + (large-tie-down sld slt 2.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-2-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 2.33 sld))))) + (large-tie-down sld slt 2.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-3-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 2.67 sld))))) + (large-tie-down sld slt 2.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-4-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 3.0 sld))))) + (large-tie-down sld slt 3.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-5-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 3.33 sld))))) + (large-tie-down sld slt 3.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-6-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 3.67 sld))))) + (large-tie-down sld slt 3.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-7-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 4.0 sld))))) + (large-tie-down sld slt 4.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-8-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 4.33 sld))))) + (large-tie-down sld slt 4.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-9-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 4.67 sld))))) + (large-tie-down sld slt 4.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-10-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 5.0 sld))))) + (large-tie-down sld slt 5.0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1155,7 +1155,7 @@ (flet ((c (x y) (complex x y))) (translate (xyscale (translate +unit-square+ #c(-0.5 0)) notehead-width (* 0.5 sld)) - (c xoffset (* yoffset (* 0.5 sld))))))) + (c xoffset (+ yoffset (* 0.5 sld))))))) (defmethod compute-design ((font font) (shape (eql :half-rest))) (with-slots ((sld staff-line-distance) notehead-width xoffset yoffset) font

1 0

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

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv5096 Modified Files: bezier.lisp fontview.lisp sdl.lisp Log Message: Fixed a bug in bezier.lisp that made the resulting pixmap positioned in the wrong place sometimes. Fixed a bug in sdl.lisp that computed the wrong xoffset (in particular for noteheads). Fixed the whole notehead so that its vertical position is not offset as it should. Fixed the C clef so that it no longer goes below the bottom line. Improved the font viewer by having the bounding box of the glyph drawn in :pixel mode. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 04:55:37 1.3 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 18:57:40 1.4 @@ -703,6 +703,8 @@ (defun render-through-pixmap (design medium positive-areas negative-areas) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) + (setf min-x (floor min-x) + min-y (floor min-y)) (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 04:55:37 1.2 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 18:57:40 1.3 @@ -9,9 +9,9 @@ ((font :initform (make-instance 'sdl::font :staff-line-distance 6)) (shape :initform :g-clef) (grid :initform t) - (staff :initform nil) + (staff :initform t) (staff-offset :initform 0) - (view :initform :pixel) + (view :initform :antialiased) (zoom :initform 1) (hoffset :initform 300) (voffset :initform 300)) @@ -72,6 +72,24 @@ do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) (loop for x from 0 below 300 by (* 4 zoom) do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) + ;; draw the bounding rectangle + (draw-rectangle* pane + (* zoom min-x) (* zoom min-y) + (* zoom max-x) (1+ (* zoom min-y)) + :ink +red+) + (draw-rectangle* pane + (* zoom min-x) (* zoom max-y) + (* zoom max-x) (1+ (* zoom max-y)) + :ink +red+) + (draw-rectangle* pane + (* zoom min-x) (* zoom min-y) + (1+ (* zoom min-x)) (* zoom max-y) + :ink +red+) + (draw-rectangle* pane + (* zoom max-x) (* zoom min-y) + (1+ (* zoom max-x)) (* zoom max-y) + :ink +red+) + ;; draw the reference point (draw-rectangle* pane -300 0 300 1 :ink +red+) (draw-rectangle* pane 0 -300 1 300 :ink +red+)))))))) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 11:01:26 1.18 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 18:57:40 1.19 @@ -151,7 +151,7 @@ beam-hang-sit-offset) font (setf staff-line-thickness (round (/ (staff-line-distance font) 10))) (setf xoffset - (if (oddp (round (* 1.5 staff-line-distance))) 1.5 0)) + (if (oddp (round (* 1.5 staff-line-distance))) 0.5 0)) (setf yoffset (if (oddp staff-line-thickness) 0.5 0)) (setf dot-diameter @@ -610,12 +610,12 @@ (mf (c xc (- staff-line-thickness)) -- (c xc 0))))))) (clim:region-union (climi::close-path (mf (c 0 top) -- (c xa top) -- - (c xa (- (- top) staff-line-thickness)) -- - (c 0 (- (- top) staff-line-thickness)) -- (c 0 top))) + (c xa (- top)) -- + (c 0 (- top)) -- (c 0 top))) (clim:region-union (climi::close-path (mf (c xb top) -- (c xc top) -- - (c xc (- (- top) staff-line-thickness)) -- - (c xb (- (- top) staff-line-thickness)) -- (c xb top))) + (c xc (- top)) -- + (c xb (- top)) -- (c xb top))) (translate r (c 0 staff-line-thickness)))))))) ;;; @@ -712,7 +712,7 @@ (complex xoffset yoffset)))) (defmethod compute-design ((font font) (shape (eql :whole-notehead))) - (with-slots ((sld staff-line-distance)) font + (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) sld)) @@ -720,7 +720,8 @@ #c(-0.3 0.0) #c(0.0 -0.35) 0.8) -0.3) sld))) - (clim:region-difference op (climi::reverse-path ip))))) + (translate (clim:region-difference op (climi::reverse-path ip)) + (complex xoffset yoffset))))) (defmethod compute-design ((font font) (shape (eql :half-notehead))) (with-slots (xoffset yoffset (sld staff-line-distance)) font

1 0

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

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv31532 Modified Files: sdl.lisp Log Message: Fix a bug in the C clef. It's still not symmetrical about the X axis, but the weird zooming point in the curve is fixed. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/05/31 19:51:58 1.17 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 11:01:26 1.18 @@ -598,7 +598,7 @@ (c (+ xd (* 0.5 dot-width)) (+ yd dot-width)) right ++ (c (+ xd dot-width) (+ yd (* 0.5 dot-width))) down ++ (c (+ xd (* 0.5 dot-width)) yd) left ++ - (c xd (* yd (* 0.5 dot-width))) up ++ (c xf top) right ++ + (c xd (+ yd (* 0.5 dot-width))) up ++ (c xf top) right ++ (c xk yk) down ++ (c xh (- yh staff-line-thickness)) ++ (c xl yl) & (c xl yl) ++ down (c xi 0))) (q (translate (yscale p -1) (c 0 (- staff-line-thickness))))

1 0

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

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv13899 Modified Files: gui.lisp Log Message: Removed bogus menu entry. --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/05/23 11:43:29 1.63 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/01 04:57:10 1.64 @@ -233,6 +233,7 @@ :errorp nil :menu '(("File" :menu file-command-table) ("Buffer" :menu buffer-command-table) + ("Stuff" :menu segment-command-table) ("Segment" :menu segment-command-table) ("Layer" :menu layer-command-table) ("Slice" :menu slice-command-table)

1 0

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

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv13742 Modified Files: bezier.lisp fontview.lisp Log Message: Moved things around a bit inside bezier.lisp to make it easier to render to an array from the font viewer. Implemented pixel viewing in the font viewer. Initial results indicate that the G-clef is pretty good, and there must be something wrong either with the way the pixmap gets generated or with the way it gets copied to the pane (it is too far down). Initial result also indicate that the C-clef is completely wrong and incredibly ugly at sizes above 6. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/05/30 02:13:26 1.2 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 04:55:37 1.3 @@ -662,23 +662,25 @@ repeat (nb-lines lines) do (render-scan-lines array pixel-value i (crossings lines i) min-x min-y)))) -(defun render-to-array (positive-areas negative-areas min-x min-y max-x max-y) - (setf min-x (* 4 (floor min-x)) - min-y (* 4 (floor min-y)) - max-x (* 4 (ceiling max-x)) - max-y (* 4 (ceiling max-y))) - (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) - :element-type 'bit :initial-element 1)) - (transformation (make-scaling-transformation* 4 4))) - (loop for area in positive-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 0 min-x min-y))) - (loop for area in negative-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 1 min-x min-y))) - result)) +(defun render-to-array (positive-areas negative-areas) + (multiple-value-bind (min-x min-y max-x max-y) + (bounding-rectangle-of-areas positive-areas) + (setf min-x (* 4 (floor min-x)) + min-y (* 4 (floor min-y)) + max-x (* 4 (ceiling max-x)) + max-y (* 4 (ceiling max-y))) + (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) + :element-type 'bit :initial-element 1)) + (transformation (make-scaling-transformation* 4 4))) + (loop for area in positive-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 0 min-x min-y))) + (loop for area in negative-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 1 min-x min-y))) + result))) (defparameter *x* 0) (defparameter *y* 0) @@ -699,12 +701,12 @@ (+ (* a 1.0) (* 1-a b)))))) (defun render-through-pixmap (design medium positive-areas negative-areas) - (multiple-value-bind (min-x min-y max-x max-y) - (bounding-rectangle-of-areas positive-areas) + (multiple-value-bind (min-x min-y) + (bounding-rectangle* design) (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) - (let* ((picture (render-to-array positive-areas negative-areas min-x min-y max-x max-y)) + (let* ((picture (render-to-array positive-areas negative-areas)) (height (array-dimension picture 0)) (width (array-dimension picture 1)) (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16))) @@ -741,6 +743,20 @@ (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) (medium-draw-design* medium (original-region design)))) +(defgeneric render-design-to-array (design)) + +(defmethod render-design-to-array ((design bezier-area)) + (render-to-array (list design) '())) + +(defmethod render-design-to-array ((design bezier-union)) + (render-to-array (areas design) '())) + +(defmethod render-design-to-array ((design bezier-difference)) + (render-to-array (positive-areas design) (negative-areas design))) + +(defmethod render-design-to-array ((design translated-region)) + (render-design-to-array (original-region design))) + (defmethod draw-design (sheet design &rest args &key &allow-other-keys) (climi::with-medium-options (sheet args) (medium-draw-design* medium design))) --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/05/31 19:55:19 1.1 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 04:55:37 1.2 @@ -8,10 +8,10 @@ (define-application-frame fontview () ((font :initform (make-instance 'sdl::font :staff-line-distance 6)) (shape :initform :g-clef) - (grid :initform nil) + (grid :initform t) (staff :initform nil) (staff-offset :initform 0) - (view :initform :antialiased) + (view :initform :pixel) (zoom :initform 1) (hoffset :initform 300) (voffset :initform 300)) @@ -41,9 +41,39 @@ (* 10 sld) (+ y down))))))))) (defun display-pixel-view (frame pane) - (declare (ignore pane)) (with-slots (font shape grid zoom hoffset voffset) frame - nil)) + (with-translation (pane hoffset voffset) + (let ((design (sdl::ensure-design font shape))) + (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* design) + (setf min-x (* 4 (floor min-x)) + min-y (* 4 (floor min-y)) + max-x (* 4 (ceiling max-x)) + max-y (* 4 (ceiling max-y))) + (let ((array (climi::render-design-to-array design))) + (loop for y from min-y below max-y + for y-index from 0 + do (loop with x0 = nil + for x from min-x below max-x + for x-index from 0 + do (if (zerop (aref array y-index x-index)) + (when (null x0) + (setf x0 x)) + (unless (null x0) + (draw-rectangle* pane (* x0 zoom) (* y zoom) (* x zoom) (* (1+ y) zoom)) + (setf x0 nil))) + finally (unless (null x0) + (draw-rectangle* pane (* x0 zoom) (* y zoom) (* x zoom) (* (1+ y) zoom))))) + (when grid + (loop for y downfrom 0 above -300 by (* 4 zoom) + do (draw-rectangle* pane -300 y 300 (1+ y) :ink +blue+)) + (loop for y from 0 below 300 by (* 4 zoom) + do (draw-rectangle* pane -300 y 300 (1+ y) :ink +blue+)) + (loop for x downfrom 0 above -300 by (* 4 zoom) + do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) + (loop for x from 0 below 300 by (* 4 zoom) + do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) + (draw-rectangle* pane -300 0 300 1 :ink +red+) + (draw-rectangle* pane 0 -300 1 300 :ink +red+)))))))) (defun display-entry (frame pane) (with-slots (view) frame

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

gsharp-cvs June 2006