gsharp-cvs

gsharp-cvs@common-lisp.net

396 discussions

[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

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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

gsharp-cvs