[gsharp-cvs] CVS gsharp
rstrandh
rstrandh at common-lisp.net
Mon May 29 19:55:24 UTC 2006
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv23421
Modified Files:
gsharp.asd packages.lisp score-pane.lisp sdl.lisp
Added Files:
bezier.lisp mf.lisp
Log Message:
The new font-rendering code is now in there, but is not yet being used.
The reason for that is that I still have not managed to get output
recording for designs right.
Once that problem is fixed, I am planning to gradually move to the new
system, debugging the glyphs one at a time. The code for the glyphs
has been tested in a separate context, but there might be unforeseen
problems.
The new system allows designs to be drawn in any color and
transformation by being rendered to anti-aliased pixmaps, so there is
no need to use special gray pixmaps. It might be worthwhile thinking
about moving beam drawing to this new system one day.
This font rendering system should be easy for PostScript output, but
I haven't attacked that problem yet.
--- /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/05/28 21:35:30 1.8
+++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/05/29 19:55:24 1.9
@@ -24,6 +24,8 @@
"packages"
"utilities"
"gf"
+ "bezier"
+ "mf"
"sdl"
"charmap"
"score-pane"
--- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/03/25 22:06:35 1.50
+++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/05/29 19:55:24 1.51
@@ -13,8 +13,28 @@
#: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
+ #:make-open-path #:make-closed-path
+ #:closed-path #:concatenate-paths #:path-start
+ #:close-path
+ #:polygonalize
+ #:path-bounding-box
+ #:scan-lines
+ #:first-line #:nb-lines #:crossings
+ #:translate #:rotate #:scale #:slant #:reverse-path
+ #:draw-path #:with-pen
+ #:+razor+ #:+unit-square+
+ #:+quarter-circle+ #:+half-circle+ #:+full-circle+
+ #:superellipse
+ ;; mf-like stuff
+ #:paths #:mf #:paths #:control #:controls #:tension #:tensions
+ #:& #:-- #:--- #:curl #:direction #:cycle
+ #:left #:right #:up #:down))
+
(defpackage :sdl
- (:use :common-lisp :gf)
+ (:use :common-lisp :gf :mf)
(:export #:glyph #:staff-line-distance #:staff-line-offsets
#:stem-offsets #:bar-line-offsets
#:ledger-line-x-offsets #:ledger-line-y-offsets
--- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/05/28 21:30:29 1.23
+++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/05/29 19:55:24 1.24
@@ -256,6 +256,19 @@
(:bass +glyph-f-clef+)
(:c +glyph-c-clef+)))
+(defun new-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.
+ ((:treble :treble8) :g-clef)
+ (:bass :f-clef)
+ (:c :c-clef))
+ x (staff-step staff-step)))
+
+
+
(define-presentation-type clef () :options (name x staff-step))
(define-presentation-method present
--- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/01/04 19:08:12 1.14
+++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/05/29 19:55:24 1.15
@@ -34,7 +34,75 @@
(defclass font ()
((gf-font :initarg :gf-font :reader gf-font)
+ ;; 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
+ ;; used to draw a staff line.
+ (staff-line-thickness)
+ ;; An integer value indicating how many non-white pixels are
+ ;; used to draw a stem
+ (stem-thickness)
+ ;; The width of filled and half-note noteheads is always 1.5 times the
+ ;; staff line distance. Since the staff line distance is an even
+ ;; number, this width is always an integer. This is important, because
+ ;; we need to position stems very precisely with respect to noteheads.
+ ;; and we want the left and right edges of noteheads to fall on integer
+ ;; pixel borders. Moreover, by having a fixed proportion, these
+ ;; noteheads will have the same proportional width no matter what the
+ ;; staff line distance is, which makes the characters look similar at
+ ;; different sizes. However, this means that we cannot make the
+ ;; heights of these characters integers. That is OK, though, since we
+ ;; count on anti-aliasing to give the impression of proportional
+ ;; sizes.
+ (notehead-width)
+ ;; While the rule above guarantees that the width of noteheads is an
+ ;; integer, it sometimes creates an even integer and sometimes an odd
+ ;; integer. When the width is even, the x-coordinate of the middle of
+ ;; the character is between two pixels, which is fine because that is
+ ;; how the MetaFont coordinate system works. When it is odd, however,
+ ;; the middle of the character is in the middle of a pixel. If we were
+ ;; to leave it like that, the left and right edges of the character
+ ;; would be in the middle of a pixel, which defeats the purpose. For
+ ;; that reason, when the width is odd, we put the reference point of
+ ;; the character one half pixel to the left of its middle.
+ ;;
+ ;; A similar rule holds for vertical reference points. For instance,
+ ;; the reference point of a staff line is the middle of the line if its
+ ;; thickness is even and one half pixel below that if it is odd.
+ ;;
+ ;; We do this consistently for stems, staff lines, etc. Thus, the
+ ;; client program can pretend that the reference point is always in the
+ ;; middle of the object. When the object has an odd size the effect is
+ ;; simply that everything appears to be off by half a pixel. We just
+ ;; have to watch out with attach points between stems and noteheads.
+ ;; In fact, in general, the noteheads may have a different distance
+ ;; from the reference point to the left attach point from the distance
+ ;; from the reference point to the right attach point.
+
+ ;; Characters are positioned vertically in multiples of half a staff
+ ;; line distance. An even multiple indicates that the symbol will be
+ ;; placed ON A STAFF LINE, and an odd multiple a symbol BETWEEN TWO
+ ;; STAFF LINES. The bottom staff line of a staff has a multiple of
+ ;; zero, and the multiple is positive towards the upper edge of the
+ ;; page and negative towards the lower edge of the page.
+ ;;
+ ;; When the staff line thickness is even, the reference point for
+ ;; placing characters is the middle of the staff line or half way
+ ;; between two adjacent middles of staff lines. When the staff line
+ ;; thickness is odd, the reference point is located half a pixel lower
+ ;; down.
+
+ ;; A certain number of characters are rotationally symmetric. But the
+ ;; center of the character is usually not the reference point. Since
+ ;; the reference point is (0, 0), we must draw these characters at an
+ ;; offset.
+ (xoffset)
+ ;; The vertical offset from the reference point to the middle of the
+ ;; staff line. This is zero for even staff line thicknesses and 0.5
+ ;; otherwise.
+ (yoffset)
+ (dot-diameter)
(staff-line-offset-down)
(staff-line-offset-up)
(ledger-line-offset-down)
@@ -52,11 +120,18 @@
(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)))
(defmethod initialize-instance :after ((font font) &rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(with-slots (staff-line-distance
+ staff-line-thickness
+ stem-thickness
+ notehead-width
+ xoffset
+ yoffset
+ dot-diameter
staff-line-offset-down
staff-line-offset-up
ledger-line-offset-down
@@ -74,16 +149,25 @@
beam-offset-down
beam-offset-up
beam-hang-sit-offset) font
- (let ((staff-line-thickness (round (/ (staff-line-distance font) 10))))
- (setf staff-line-offset-down
- (floor (/ staff-line-thickness 2))
- staff-line-offset-up
- (- staff-line-offset-down staff-line-thickness)))
- (let ((stem-thickness (round (/ staff-line-distance 11.9))))
- (setf stem-offset-left
- (- (floor (/ stem-thickness 2)))
- stem-offset-right
- (+ stem-thickness stem-offset-left)))
+ (setf xoffset
+ (if (oddp (round (* 1.5 staff-line-distance))) 1.5 0))
+ (setf yoffset
+ (if (oddp staff-line-distance) 0.5 0))
+ (setf staff-line-thickness (round (/ (staff-line-distance font) 10)))
+ (setf dot-diameter
+ (min (- staff-line-distance staff-line-thickness 2)
+ (round (/ staff-line-distance 3))))
+ (setf staff-line-offset-down
+ (floor (/ staff-line-thickness 2))
+ staff-line-offset-up
+ (- staff-line-offset-down staff-line-thickness))
+ ;; we can't use 12 here, because Lisp rounds 0.5 to 0 which
+ ;; happens for the smallest staff-line-distance = 6
+ (setf stem-thickness (round (/ staff-line-distance 11.999)))
+ (setf stem-offset-left
+ (- (floor (/ stem-thickness 2)))
+ stem-offset-right
+ (+ stem-thickness stem-offset-left))
(let ((bar-line-thickness (round (/ (staff-line-distance font) 8))))
(setf bar-line-offset-left
(- (floor (/ bar-line-thickness 2)))
@@ -99,24 +183,22 @@
(- (floor (/ ledger-line-width 2)))
ledger-line-offset-right
(ceiling (/ ledger-line-width 2))))
- (let* ((notehead-width (* 3/2 staff-line-distance))
- (staff-line-thickness (round (/ (staff-line-distance font) 10)))
- (yoffset (if (oddp staff-line-thickness) 0.5 0)))
- (setf notehead-right-x-offset
- (- (ceiling (/ notehead-width 2)) stem-offset-right))
- (setf notehead-left-x-offset
- (- (+ (floor (/ notehead-width 2)) stem-offset-left)))
- (setf notehead-right-y-offset
- (round (+ (* 0.25 staff-line-distance) yoffset)))
- (setf notehead-left-y-offset
- (- (round (- (* 0.25 staff-line-distance) yoffset))))
- (setf beam-offset-down
- (floor (/ staff-line-distance 2) 2))
- (setf beam-offset-up
- (- (ceiling (/ staff-line-distance 2) 2)))
- (setf beam-hang-sit-offset
- (let ((beam-thickness (- beam-offset-down beam-offset-up)))
- (/ (- beam-thickness staff-line-thickness) 2))))))
+ (setf notehead-width (* 3/2 staff-line-distance))
+ (setf notehead-right-x-offset
+ (- (ceiling (/ notehead-width 2)) stem-offset-right))
+ (setf notehead-left-x-offset
+ (- (+ (floor (/ notehead-width 2)) stem-offset-left)))
+ (setf notehead-right-y-offset
+ (round (+ (* 0.25 staff-line-distance) yoffset)))
+ (setf notehead-left-y-offset
+ (- (round (- (* 0.25 staff-line-distance) yoffset))))
+ (setf beam-offset-down
+ (floor (/ staff-line-distance 2) 2))
+ (setf beam-offset-up
+ (- (ceiling (/ staff-line-distance 2) 2)))
+ (setf beam-hang-sit-offset
+ (let ((beam-thickness (- beam-offset-down beam-offset-up)))
+ (/ (- beam-thickness staff-line-thickness) 2)))))
(defgeneric gf-char (glyph))
(defgeneric pixmap (glyph))
@@ -226,4 +308,1065 @@
:gf-font gf-font
:glyphs glyphs)))
-
\ No newline at end of file
+(defgeneric xyscale (thing kx ky))
+
+(defmethod xyscale ((point number) kx ky)
+ (complex (* (realpart point) kx)
+ (* (imagpart point) ky)))
+
+(defmethod xyscale ((region clim:region) kx ky)
+ (let ((tr (clim:make-scaling-transformation kx ky)))
+ (clim:transform-region tr region)))
+
+(defun scale (thing k)
+ (xyscale thing k k))
+
+(defun xscale (thing k)
+ (xyscale thing k 1.0))
+
+(defun yscale (thing k)
+ (xyscale thing 1.0 k))
+
+(defgeneric translate (thing z))
+
+(defmethod translate ((region clim:region) z)
+ (let ((tr (clim:make-translation-transformation (realpart z) (imagpart z))))
+ (clim:transform-region tr region)))
+
+(defgeneric rotate (thing angle))
+
+(defmethod rotate ((region clim:region) angle)
+ (let ((tr (clim:make-rotation-transformation angle)))
+ (clim:transform-region tr region)))
+
+(defgeneric slant (thing slant))
+
+(defmethod slant ((region clim:region) slant)
+ (let ((tr (climi::make-slanting-transformation slant)))
+ (clim:transform-region tr region)))
+
+(defgeneric compute-design (font shape))
+
+(defun ensure-design (font shape)
+ (or (gethash shape (slot-value font 'designs))
+ (setf (gethash shape (slot-value font 'designs))
+ (yscale (compute-design font shape) -1))))
+
+(defgeneric draw-shape (sheet font shape x y))
+
+(defmethod draw-shape (sheet (font font) shape x y)
+ (let ((design (ensure-design font shape))
+ (tr (clim:make-translation-transformation x y)))
+ (clim:draw-design sheet (clim:transform-region tr design))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Clefs
+
+;;; w
+;;; |
+;;; **
+;;; ****
+;;; *****
+;;; ** | **
+;;; ** h **
+;;; ** **
+;;; ** g-**
+;;; v-**-i **
+;;; ** ***
+;;; * ***
+;;; * ***-x
+;;; * ****
+;;; * ****
+;;; * ****
+;;;*************************************************************************
+;;; * ******
+;;; * ******
+;;; * ******
+;;; ******
+;;; ******
+;;; ee\ ******/dd
+;;;*************************************************************************
+;;; ********
+;;; ******* *
+;;; ******* *
+;;; ******* *
+;;; ******* *
+;;; ****** ff\*/gg/c
+;;;*************************************************************************
+;;; ****** ************
+;;; ***** ****************
+;;; f ***** ******************
+;;; \***** ***** * | ***
+;;; **** b-**** * bb **
+;;; (0, 0)\ ****/y ***/cc * aa\**/d
+;;;*************************************************************************
+;;; **** ** * **
+;;; *** * * **
+;;; ** | * **
+;;; ** a z ) * **
+;;; *** | * **
+;;; ***************
+;;;*************************************************************************
+;;; |e *
+;;; o *
+;;; | *
+;;; *** *
+;;; ******* *
+;;; ********* *
+;;; n-*********-p *
+;;; ****** s-*-l
+;;; ****-q r *
+;;; **** / **
+;;; *******
+;;; |
+;;; m
+;;;
+;;;
+
+(defmethod compute-design ((font font) (shape (eql :g-clef)))
+ (with-slots ((sld staff-line-distance) staff-line-thickness stem-thickness) font
+ (let* ((xf 0.0) (yf (* 0.5 sld))
+ (xy (max 2.0 (round (* 0.4 sld)))) (yy (* 0.2 sld))
+ (xb (+ xy (max 2.0 (round (* 0.4 sld))))) (yb (* 0.3 sld))
+ (xcc (+ xb (max 2.0 (round (* 0.4 sld))))) (ycc 0)
+ (xa (+ xcc (max 1.0 (* 0.2 sld)))) (ya (* -0.4 sld))
+ (xc (+ xb (round (* 0.7 sld)))) (yc (+ sld (max 1.0 (* 0.15 sld))))
+ (xd (+ xc sld)) (yd 0.0)
+ (xe (* 1.5 sld)) (ye (- (+ staff-line-thickness sld)))
+ (xg (round (* 1.8 sld))) (yg (* 3.8 sld))
+ (xw (- xg (* 2.0 staff-line-thickness))) (yw (round (* 5.0 sld)))
+ (xh xw) (yh (- yw (max 2.0 (round (* 0.4 sld)))))
+ (xv (round (* 1.0 sld))) (yv (* 3.5 sld))
+ (xi (+ xv (max 2.0 (* 0.2 sld)))) (yi yv)
+ (xx (+ xg (max 2.0 (round (* 0.3 sld))))) (yx (* 3.5 sld))
+ (bigdot-diameter sld)
+ (yo (- (+ sld (round (* 0.5 sld)))))
+ (xn (round (* 0.5 sld))) (yn (- yo (* 0.5 bigdot-diameter)))
+ (xo (+ xn (* 0.5 bigdot-diameter)))
+ (xp (+ xn bigdot-diameter)) (yp yn)
+ (xq xo) (yq (- yo bigdot-diameter))
+ (xs (+ xp (max 1 (floor (* 0.4 sld))))) (ys yp)
+ (xl (+ xs stem-thickness)) (yl ys)
+ (xm (- xp (* 1 staff-line-thickness))) (ym (round (* -2.75 sld)))
+ (xr xm) (yr (+ ym staff-line-thickness))
+ (xz xe) (yz (- staff-line-thickness sld))
+ (xaa (- xd (max 1 (round (* 0.3 sld))))) (yaa yd)
+ (xbb xc) (ybb (- sld staff-line-thickness (max 2 (* 0.3 sld))))
+ (xdd xp) (ydd (* 2 sld))
+ (xee xn) (yee ydd)
+ (xff (floor (* 1.4 sld))) (yff sld)
+ (xgg (+ xff stem-thickness)) (ygg yff))
+ (flet ((c (x y) (complex x y)))
+ (mf (c xa ya) ++ (c xb yb) up ++ (c xc yc) right ++
+ (c xd yd) down ++ (c xe ye) left ++ (c xf yf) up ++
+ (c xee yee) ++
+ (c xg yg) up
+ (tensions 1 1.8)
+ (c xh yh)
+ (tensions 1.8 1)
+ (c xi yi)
+ (tensions 1.8 1)
+ (c xgg ygg) (direction #c(1 -4))
+ (tensions 1 20)
+ (c xl yl) down ++
+ (c xm ym) left ++
+ (c xn yn) up ++ (c xo yo) right ++ (c xp yp) down ++
+ (c xq yq) &
+ (c xq yq) ++ (c xr yr) right ++
+ (c xs ys) up
+ (tensions 20 1)
+ (c xff yff) (direction #c(-1 4))
+ (tensions 1 1.8)
+ (c xv yv) up
+ (tensions 1 1.8)
+ (c xw yw) right
+ (tensions 1.8 1)
+ (c xx yx) down ++
+ (c xdd ydd) ++
+ (c xy yy) down ++ (c xz yz) right ++
+ (c xaa yaa) up ++ (c xbb ybb) left ++
+ (c xcc ycc) down ++ (c (+ xa 1) ya) &
+ (c (+ xa 1) ya) ++ cycle))))) ; replace ++ by -- one day
+
+;;;
+;;; xa xb
+;;; ||
+;;; || xc xf
+;;; || | |
+;;; (0, top) ********* ** ****************
+;;; ********* ** ********************
+;;; ********* ** **** | **********
+;;; ********* ** *** | ********
+;;; ********* ** *** (xg,yg) *******
+;;; ********* ** ***** ********
+;;; ********* ** ******* ********
+;;; ********* ** ******** ********
+;;; ********* ** ******** ********
+;;; ********* ** | ****** ********
+;;; ********* ** | **___yd ********
+;;; ********* ** xd ********
+;;; ********* ** (xj,yj)-- ********
+;;; ********* ** ********
+;;; ********* ** (xe,ye) ********
+;;; ********* ** | ********--(xk,yk)
+;;; ********* ** ** ********
+;;; ********* ** **** ********
+;;; ********* ** **** (xh,yh) ********
+;;; ********* ** ****** | *******
+;;; ********* ** ******* | ******
+;;; ********* ** ***** *************
+;;; ********* ** **** |_____
+;;; ********* ** ****** (xl,yl)
+;;; (0, 0) ********* ***********--xi
+;;; ********* ***********
+;;; ********* ** *******
+;;; ********* ** ****
+;;; ********* ** ***** *************
+;;; ********* ** ******* ******
+;;; ********* ** ****** *******
+;;; ********* ** **** ********
+;;; ********* ** **** ********
+;;; ********* ** ** ********
[842 lines skipped]
--- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/05/29 19:55:24 NONE
+++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/05/29 19:55:24 1.1
[1648 lines skipped]
--- /project/gsharp/cvsroot/gsharp/mf.lisp 2006/05/29 19:55:25 NONE
+++ /project/gsharp/cvsroot/gsharp/mf.lisp 2006/05/29 19:55:25 1.1
[2240 lines skipped]
More information about the Gsharp-cvs
mailing list