[gsharp-cvs] CVS gsharp
crhodes
crhodes at common-lisp.net
Thu Jun 21 11:14:29 UTC 2007
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv28358
Modified Files:
buffer.lisp gui.lisp measure.lisp modes.lisp sdl.lisp
Log Message:
Support for semi/sesqui sharp/flat.
* don't declare the type of the accidentals slot any more; we can put
that back in a little, after we work out a declarative way of defining
all properties of accidentals.
* microsharpen and microflatten commands and functions; define sharpen
and flatten in terms of those (and knowing which accidentals are the
tonal ones). Keybindings for the commands.
* a more declarative table-based system for kerning accidentals, along
with the ability to specify a per-glyph default (and a default
default). Choose a sensible default default; also alter the
:sharp/:sharp table when +4 steps away, as the previous value was
colliding a little too much.
* support for playing the semi accidentals in equal temperament. No
support in linear temperament, as I don't know what they mean.
* glyphs defined with a little too much liberal cut'n'paste. Some
FIXMEs note the essential differences between the related glyphs.
--- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/18 15:18:17 1.46
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/21 11:14:25 1.47
@@ -219,8 +219,10 @@
(head :initform nil :initarg :head :reader head
:type (or (member :whole :half :filled) null))
(accidentals :initform :natural :initarg :accidentals :reader accidentals
- :type (member :natural :flat :double-flat
- :sharp :double-sharp))
+ ;; FIXME: we want :TYPE ACCIDENTAL here but need to
+ ;; sort out order of definition for that to be useful.
+ #+nil #+nil
+ :type (member :natural :flat :double-flat :sharp :double-sharp))
(dots :initform nil :initarg :dots :reader dots
:type (or (integer 0 3) null))
(%tie-right :initform nil :initarg :tie-right :accessor tie-right)
@@ -230,8 +232,9 @@
(declare (type (integer 0 127) pitch)
(type staff staff)
(type (or (member :whole :half :filled) null) head)
- (type (member :natural :flat :double-flat
- :sharp :double-sharp)
+ ;; FIXME: :TYPE ACCIDENTAL
+ #+nil #+nil
+ (type (member :natural :flat :double-flat :sharp :double-sharp)
accidentals)
(type (or (integer 0 3) null) dots)
(ignore head accidentals dots))
@@ -300,9 +303,13 @@
(ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100))
(ecase (accidentals note)
(:double-flat -200)
+ (:sesquiflat -150)
(:flat -100)
+ (:semiflat -50)
(:natural 0)
+ (:semisharp 50)
(:sharp 100)
+ (:sesquisharp 150)
(:double-sharp 200)))))
;;; regular temperaments are temperaments that
--- /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/18 15:18:17 1.77
+++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/21 11:14:25 1.78
@@ -822,17 +822,61 @@
(add-note element new-note)
(setf *current-note* new-note))))
+(defmacro define-microtonal-accidentals (&rest microaccidentals)
+ `(progn
+ (setf (symbol-plist 'microsharpen)
+ ',(loop for (a b) on microaccidentals
+ if b collect a and collect b
+ else collect a and collect a))
+ (setf (symbol-plist 'microflatten)
+ ',(loop for (a b) on (reverse microaccidentals)
+ if b collect a and collect b
+ else collect a and collect a))
+ (deftype accidental () '(member , at microaccidentals))
+ (defun microsharpen (accidental)
+ (or (getf (symbol-plist 'microsharpen) accidental)
+ (error 'type-error :datum accidental :expected-type 'microaccidental)))
+ (defun microflatten (accidental)
+ (or (getf (symbol-plist 'microflatten) accidental)
+ (error 'type-error :datum accidental :expected-type 'microaccidental)))))
+
+(defmacro define-accidentals (&rest accidentals)
+ `(progn
+ (deftype accidental () '(member , at accidentals))
+ (defun sharpen (accidental)
+ (do ((a (microsharpen accidental) (microsharpen a))
+ (olda accidental a))
+ ((or (eq a olda) (member a ',accidentals)) a)))
+ (defun flatten (accidental)
+ (do ((a (microflatten accidental) (microflatten a))
+ (olda accidental a))
+ ((or (eq a olda) (member a ',accidentals)) a)))))
+
+(define-microtonal-accidentals :double-flat :sesquiflat :flat :semiflat
+ :natural
+ :semisharp :sharp :sesquisharp :double-sharp)
+
+(define-accidentals :double-flat :flat :natural :sharp :double-sharp)
+
(define-gsharp-command com-sharper ()
(let* ((cluster (cur-cluster))
(note (cur-note))
(new-note (make-note (pitch note) (staff note)
:head (head note)
- :accidentals (ecase (accidentals note)
- (:double-sharp :double-sharp)
- (:sharp :double-sharp)
- (:natural :sharp)
- (:flat :natural)
- (:double-flat :flat))
+ :accidentals (sharpen (accidentals note))
+ :dots (dots note))))
+ (remove-note note)
+ (add-note cluster new-note)
+ (setf *current-note* new-note)))
+
+(define-gsharp-command com-microsharper ()
+ ;; FIXME: what are CUR-CLUSTER and CUR-NOTE and how do they relate
+ ;; to CURRENT-CLUSTER &c?
+ (let* ((cluster (cur-cluster))
+ (note (cur-note))
+ (new-note (make-note (pitch note) (staff note)
+ :head (head note)
+ :accidentals (microsharpen (accidentals note))
:dots (dots note))))
(remove-note note)
(add-note cluster new-note)
@@ -843,12 +887,18 @@
(note (cur-note))
(new-note (make-note (pitch note) (staff note)
:head (head note)
- :accidentals (ecase (accidentals note)
- (:double-sharp :sharp)
- (:sharp :natural)
- (:natural :flat)
- (:flat :double-flat)
- (:double-flat :double-flat))
+ :accidentals (flatten (accidentals note))
+ :dots (dots note))))
+ (remove-note note)
+ (add-note cluster new-note)
+ (setf *current-note* new-note)))
+
+(define-gsharp-command com-microflatter ()
+ (let* ((cluster (cur-cluster))
+ (note (cur-note))
+ (new-note (make-note (pitch note) (staff note)
+ :head (head note)
+ :accidentals (microflatten (accidentals note))
:dots (dots note))))
(remove-note note)
(add-note cluster new-note)
--- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/21 16:31:54 1.32
+++ /project/gsharp/cvsroot/gsharp/measure.lisp 2007/06/21 11:14:25 1.33
@@ -248,48 +248,57 @@
nil
(accidentals note)))))
-;;; table of x offsets (in staff steps) of accendentals.
-;;; The first index represents a notehead or a type of accidental.
-;;; The second index represents a type of accidentsl.
-;;; The third index is a vertical distance, measured in difference
-;;; in staff steps between the two.
-;;; The table entry gives how much the accidental represented by
-;;; the second parameter must be positioned to the left of the
-;;; first one.
-;;; Entries in the table are offset by 5 in the last dimension
-;;; so that vertical distances between -5 and 5 can be represented
-(defparameter *accidental-offset*
- ;;; -5 -4 -3 -2 -1 0 1 2 3 4 5
- #3A((( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - dbl flat
- ( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - flat
- ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - natural
- ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - sharp
- ( 0 0 0 3.5 3.5 3.5 3.5 3.5 0 0 0)) ; notehead - dbl sharp
- (( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - dbl flat
- ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - flat
- ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - natural
- ( 4 4 4 4 4 4 4 4 4 3.5 0) ; dbl flat - sharp
- ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 0 0 0)) ; dbl flat - dbl sharp
- (( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - dbl flat
- ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - flat
- ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - natural
- ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 1.5 0) ; flat - sharp
- ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0 0)) ; flat - dbl sharp
- (( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - dbl flat
- ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - flat
- ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - natural
- ( 2 2 2 2 2 2 2 2 2 2 2) ; natural - sharp
- ( 2 2 2 2 2 2 2 2 1 1 1)) ; natural - dbl sharp
- (( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - dbl flat
- ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - flat
- ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - natural
- ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 2.0) ; sharp - sharp
- ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0)) ; sharp - dbl sharp
- (( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - dbl flat
- ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - flat
- ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - natural
- ( 0 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 0) ; dbl sharp - sharp
- ( 0 0 0 2.8 2.8 2.8 2.8 2.8 0 0 0)))) ; dbl sharp - dbl sharp
+(defmacro define-accidental-kerning (left right table)
+ `(let ((plist (getf (symbol-plist 'accidental-kerning) ',right)))
+ (setf (getf (symbol-plist 'accidental-kerning) ',right)
+ (cons (cons ',left ',table)
+ (remove ',left plist :key #'car)))))
+(defmacro define-default-accidental-kerning (right table)
+ `(define-accidental-kerning default ,right ,table))
+
+(macrolet ((define-kernings (&rest args)
+ `(progn ,@(loop for (left right table) on args by #'cdddr
+ collect `(define-accidental-kerning ,left ,right ,table)))))
+ (define-kernings
+ :double-flat :notehead #( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0)
+ :flat :notehead #( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0)
+ :natural :notehead #( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0)
+ :sharp :notehead #( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0)
+ :double-sharp :notehead #( 0 0 0 3.5 3.5 3.5 3.5 3.5 0 0 0)
+
+ :double-flat :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0)
+ :flat :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0)
+ :natural :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0)
+ :sharp :double-flat #( 4 4 4 4 4 4 4 4 4 3.5 0)
+ :double-sharp :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 0 0 0)
+
+ :double-flat :flat #( 2 2 2 2 2 2 2 2 1.5 1 0)
+ :flat :flat #( 2 2 2 2 2 2 2 2 1.5 1 0)
+ :natural :flat #( 2 2 2 2 2 2 2 2 1.5 1 0)
+ :sharp :flat #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 1.5 0)
+ :double-sharp :flat #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0 0)
+
+ :double-flat :natural #( 2 2 2 2 2 2 2 2 2 1.5 1.5)
+ :flat :natural #( 2 2 2 2 2 2 2 2 2 1.5 1.5)
+ :natural :natural #( 2 2 2 2 2 2 2 2 2 1.5 1.5)
+ :sharp :natural #( 2 2 2 2 2 2 2 2 2 2 2)
+ :double-sharp :natural #( 2 2 2 2 2 2 2 2 1 1 1)
+
+ :double-flat :sharp #( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0)
+ :flat :sharp #( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0)
+ :natural :sharp #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0)
+ :sharp :sharp #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0)
+ :double-sharp :sharp #( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0)
+
+ :double-flat :double-sharp #( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0)
+ :flat :double-sharp #( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0)
+ :natural :double-sharp #( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0)
+ :sharp :double-sharp #( 0 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 0)
+ :double-sharp :double-sharp #( 0 0 0 2.8 2.8 2.8 2.8 2.8 0 0 0)
+ ))
+
+(defvar *default-accidental-kerning*
+ #(4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0))
;;; given 1) a type of accidental 2) its position (in staff steps) 3)
;;; a type of accidental or a type of notehead, and 4) its position,
@@ -297,24 +306,16 @@
;;; steps to the left that it must be moved in order to avoid overlap
;;; with the second one.
(defun accidental-distance (acc1 pos1 acc2 pos2)
- (let ((dist (- pos2 pos1)))
- (if (> (abs dist) 5)
- 0
- (aref *accidental-offset*
- (ecase acc2
- (:notehead 0)
- (:double-flat 1)
- (:flat 2)
- (:natural 3)
- (:sharp 4)
- (:double-sharp 5))
- (ecase acc1
- (:double-flat 0)
- (:flat 1)
- (:natural 2)
- (:sharp 3)
- (:double-sharp 4))
- (+ dist 5)))))
+ (let* ((dist (- pos2 pos1))
+ (right-info (getf (symbol-plist 'accidental-kerning) acc2))
+ (left-right-info (cdr (assoc acc1 right-info)))
+ (default-right-info (cdr (assoc 'default right-info))))
+ (cond
+ ((> (abs dist) 5) 0)
+ ((or (not right-info) (and (not left-right-info) (not default-right-info)))
+ (aref *default-accidental-kerning* (+ dist 5)))
+ ((not left-right-info) (aref default-right-info (+ dist 5)))
+ (t (aref left-right-info (+ dist 5))))))
;;; given two notes (where the first one has an accidental, and the
;;; second one may or may not have an accidental) and the conversion
--- /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/10 08:15:29 1.23
+++ /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/21 11:14:27 1.24
@@ -84,6 +84,8 @@
(set-key 'com-sharper 'cluster-table '((#\#)))
(set-key 'com-flatter 'cluster-table '(#\@))
+(set-key 'com-microsharper 'cluster-table '((#\# :control)))
+(set-key 'com-microflatter 'cluster-table '((#\@ :control :shift)))
(set-key 'com-add-note-c 'cluster-table '(#\C))
(set-key 'com-add-note-d 'cluster-table '(#\D))
(set-key 'com-add-note-e 'cluster-table '(#\E))
--- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 22:40:26 1.31
+++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2007/06/21 11:14:27 1.32
@@ -1009,6 +1009,56 @@
;;;
;;; Accidentals
+(defmethod compute-design ((font font) (shape (eql :semisharp)))
+ (with-slots ((sld staff-line-distance)
+ (slt staff-line-thickness)
+ stem-thickness
+ yoffset) font
+ (let* (;; A factor that determines the space between the vertical
+ ;; bars and the outer edge of the character as a fraction of
+ ;; the staff line distance
+ (edge-distance-multiplier 0.2)
+ ;; A factor that determines the height of the thin part as a
+ ;; fraction of the staff line distance
+ (height-multiplier 2.5)
+ ;; A factor that determines the width of the hole as a fraction of the
+ ;; staff line distance.
+ (hole-width-multiplier 0.33)
+ (hole-width (round (* hole-width-multiplier sld)))
+ ;; Hope that half a pixel will not be visible and will not influence
+ ;; the required distance to the noteheads.
+ ;;
+ ;; FIXME: this is the only real difference between the
+ ;; :semisharp and :sesquisharp glyph calculations, and the
+ ;; :sharp glyph. Find a way to unify the glyph
+ ;; computations in a proper metafonty way.
+ (xoffset (if (oddp hole-width) 0.5 0.5))
+ (edge-distance (* edge-distance-multiplier sld))
+ (width (+ hole-width (* 2 stem-thickness) (* 2 edge-distance)))
+ ;; FIXME: this leads to a blurry glyph at most sizes:
+ ;; choose a coordinate which lies on a pixel boundary in
+ ;; preference.
+ (xleft (* -0.25 width))
+ (xright (- xleft))
+ (yleft (* -0.15 width))
+ (yright (- yleft))
+ ;; The path for the thick part symmetric around (0, 0)
+ (thickpart (mf (complex xleft yleft) -- (complex xright yright)))
+ ;; Determine the y coordinate of the previous path at the
+ ;; cross point of the thin part. Use congruent triangles.
+ (ythin (/ (* (- xright edge-distance) yright) xright))
+ (height (* height-multiplier sld))
+ ;; The path for the thin part symmetric around (0, 0)
+ (thinpart (mf (complex 0 (* 0.5 height)) -- (complex 0 (* -0.5 height)))))
+ (clim:region-union
+ (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2))
+ (clim:region-union (draw-path (translate thickpart
+ (complex xoffset (+ yoffset (* 0.5 sld)))))
+ (draw-path (translate thickpart
+ (complex xoffset (+ yoffset (* -0.5 sld)))))))
+ (with-pen (scale +razor+ stem-thickness)
+ (draw-path (translate thinpart (complex xoffset yoffset))))))))
+
(defmethod compute-design ((font font) (shape (eql :sharp)))
(with-slots ((sld staff-line-distance)
(slt staff-line-thickness)
@@ -1060,6 +1110,58 @@
(* 0.5 stem-thickness))
(+ yoffset ythin))))))))))
+(defmethod compute-design ((font font) (shape (eql :sesquisharp)))
+ (with-slots ((sld staff-line-distance)
+ (slt staff-line-thickness)
+ stem-thickness
+ yoffset) font
+ (let* (;; A factor that determines the space between the vertical
+ ;; bars and the outer edge of the character as a fraction of
+ ;; the staff line distance
+ (edge-distance-multiplier 0.2)
+ ;; A factor that determines the height of the thin part as a
+ ;; fraction of the staff line distance
+ (height-multiplier 2.5)
+ ;; A factor that determines the width of the hole as a fraction of the
+ ;; staff line distance.
+ (hole-width-multiplier 0.33)
+ (hole-width (round (* hole-width-multiplier sld)))
+ ;; Hope that half a pixel will not be visible and will not
+ ;; influence the required distance to the noteheads.
+ ;;
+ ;; FIXME: see note in :semisharp glyph at this point
+ (xoffset (if (oddp hole-width) 0.5 0.5))
+ (edge-distance (* edge-distance-multiplier sld))
+ (width (+ hole-width (* 2 stem-thickness) (* 2 edge-distance)))
+ (xleft (* -0.75 width))
+ (xright (- xleft))
+ (yleft (* -0.15 width))
+ (yright (- yleft))
+ ;; The path for the thick part symmetric around (0, 0)
+ (thickpart (mf (complex xleft yleft) -- (complex xright yright)))
+ ;; Determine the y coordinate of the previous path at the
+ ;; cross point of the thin part. Use congruent triangles.
+ (ythin (/ (* (- xright edge-distance) yright) xright))
+ (height (* height-multiplier sld))
+ ;; The path for the thin part symmetric around (0, 0)
+ (thinpart (mf (complex 0 (* 0.5 height)) -- (complex 0 (* -0.5 height)))))
+ (clim:region-union
+ (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2))
+ (clim:region-union (draw-path (translate thickpart
+ (complex xoffset (+ yoffset (* 0.5 sld)))))
+ (draw-path (translate thickpart
+ (complex xoffset (+ yoffset (* -0.5 sld)))))))
+ (with-pen (scale +razor+ stem-thickness)
+ (clim:region-union
+ (clim:region-union
+ (draw-path (translate thinpart
+ (complex (- xoffset hole-width (* 1 stem-thickness))
+ (- yoffset ythin))))
+ (draw-path (translate thinpart (complex (- xoffset (* 0 stem-thickness)) yoffset))))
+ (draw-path (translate thinpart
+ (complex (+ xoffset hole-width (* 1 stem-thickness))
+ (+ yoffset ythin))))))))))
+
(defmethod compute-design ((font font) (shape (eql :double-sharp)))
(with-slots ((sld staff-line-distance) xoffset yoffset) font
(flet ((c (x y) (complex x y)))
@@ -1075,13 +1177,38 @@
(translate (rotate leg (* pi 1.0)) (c xoffset yoffset))
(translate (rotate leg (* pi 1.5)) (c xoffset yoffset))))))))
+(defmethod compute-design ((font font) (shape (eql :semiflat)))
+ (with-slots ((sld staff-line-distance) stem-thickness) font
+ (flet ((c (x y) (complex x y)))
+ (let* ((outer (xyscale (translate (rotate +half-circle+ pi) #c(-0.5 0))
+ (* 1 sld) (* 1 sld)))
+ ;; FIXME: 1.2 here (and in the :sesquiflat glyph, below)
+ ;; represents the difference in width between the
+ ;; :semiflat bulge and the regular :flat bulge. Find a
+ ;; way to share code between the glyphs.
+ (inner (xyscale (translate (rotate +half-circle+ pi) #c(-0.6 0))
+ (* 0.75 sld) (* (/ 0.75 1.2) sld)))
+ (middle (mf (climi::path-end outer) -- (climi::path-end inner)))
+ (finish (mf (climi::path-start inner) -- (climi::path-start outer)))
+ (combined (climi::close-path
+ (reduce #'clim:region-union
+ (list outer middle (climi::reverse-path inner) finish)))))
+ (clim:region-union (translate (rotate (slant combined 0.6) (- (/ pi 2)))
+ (c (round (- (* -0.2 sld) stem-thickness)) (* -0.5 sld)))
+ (with-pen (scale +razor+ stem-thickness)
+ (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
+ (* 1.5 sld))
+ --
+ (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
+ (* -0.5 sld))))))))))
+
(defmethod compute-design ((font font) (shape (eql :flat)))
(with-slots ((sld staff-line-distance) stem-thickness) font
(flet ((c (x y) (complex x y)))
(let* ((outer (xyscale (translate +half-circle+ #c(-0.5 0))
sld (* 1.2 sld)))
(inner (scale (translate +half-circle+ #c(-0.6 0))
- (* 0.8 sld)))
+ (* 0.75 sld)))
(middle (mf (climi::path-end outer) -- (climi::path-end inner)))
(finish (mf (climi::path-start inner) -- (climi::path-start outer)))
(combined (climi::close-path
@@ -1096,6 +1223,38 @@
(c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
(* -0.5 sld))))))))))
+(defmethod compute-design ((font font) (shape (eql :sesquiflat)))
+ (with-slots ((sld staff-line-distance) stem-thickness) font
+ (flet ((c (x y) (complex x y)))
+ (let* ((outer (xyscale (translate (rotate +half-circle+ pi) #c(-0.5 0))
+ (* 1 sld) (* 1 sld)))
+ (inner (xyscale (translate (rotate +half-circle+ pi) #c(-0.6 0))
+ (* 0.75 sld) (* (/ 0.75 1.2) sld)))
+ (middle (mf (climi::path-end outer) -- (climi::path-end inner)))
+ (finish (mf (climi::path-start inner) -- (climi::path-start outer)))
+ (combined (climi::close-path
+ (reduce #'clim:region-union
+ (list outer middle (climi::reverse-path inner) finish))))
+ (outer1 (xyscale (translate +half-circle+ #c(-0.5 0))
+ sld (* 1.2 sld)))
+ (inner1 (scale (translate +half-circle+ #c(-0.6 0))
+ (* 0.75 sld)))
+ (middle1 (mf (climi::path-end outer1) -- (climi::path-end inner1)))
+ (finish1 (mf (climi::path-start inner1) -- (climi::path-start outer1)))
+ (combined1 (climi::close-path
+ (reduce #'clim:region-union
+ (list outer1 middle1 (climi::reverse-path inner1) finish1)))))
+ (clim:region-union (clim:region-union (translate (rotate (slant combined (* 0.6 1.2)) (- (/ pi 2)))
+ (c (round (- (* -0.2 sld) stem-thickness)) (* -0.5 sld)))
+ (translate (rotate (slant combined1 -0.6) (- (/ pi 2)))
+ (c (round (* -0.2 sld)) (* -0.5 sld))))
+ (with-pen (scale +razor+ stem-thickness)
+ (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
+ (* 1.5 sld))
+ --
+ (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
+ (* -0.5 sld))))))))))
+
(defmethod compute-design ((font font) (shape (eql :double-flat)))
(with-slots ((sld staff-line-distance) stem-thickness) font
(flet ((c (x y) (complex x y)))
More information about the Gsharp-cvs
mailing list