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