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

[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