Implement straight flags in scheme

diff --git a/Documentation/topdocs/NEWS.tely b/Documentation/topdocs/NEWS.tely
index 0632df85786ec992a32926328f4d410c98a810dd..f18656a179add6f7ddfdb9860c3f96076c6988c3 100644 (file)
--- a/Documentation/topdocs/NEWS.tely
+++ b/Documentation/topdocs/NEWS.tely
@@ -62,6 +62,19 @@ which scares away people.
 
 @end ignore
 
+@item
+Straight flags (used in old scores of e.g. Bach, but also in different form in 
+modern scores of e.g. Stockhausen) are now implemented:
+@lilypond
+\relative c'' {
+  \override Stem #'flag = #modern-straight-flag
+  c,16 \acciaccatura {c'8} d4 d32 
+  \bar":"
+  \override Stem #'flag = #old-straight-flag
+  c,16 \acciaccatura {c'8} d4 d32 
+}
+@end lilypond
+
 @item
 @code{\bookpart} blocks may be used to split a book into several parts,
 separated by a page break, in order to ease the page breaking, or to use

diff --git a/input/regression/flags-straight.ly b/input/regression/flags-straight.ly
new file mode 100644 (file)
index 0000000..92688c7
--- /dev/null
+++ b/input/regression/flags-straight.ly
@@ -0,0 +1,30 @@
+\version "2.11.57"
+
+\header {
+  texidoc = "Straight flag styles."
+}
+
+
+% test notes, which will be shown in different styles:
+testnotes = { \autoBeamOff c'8 d'16 c'32 d'64 \acciaccatura {c'8} d'64 
+   c''8 d''16 c''32 d''64 \acciaccatura {\stemDown c''8 \stemNeutral} d''64  }
+
+{
+  \override Score.RehearsalMark #'self-alignment-X = #LEFT
+  \time 2/4
+  \mark "modern straight"
+  \override Stem #'flag = #modern-straight-flag
+  \testnotes
+
+  \mark "old straight (large angles)"
+  \override Stem #'flag = #old-straight-flag
+  \testnotes
+%
+%   \mark "custom slant"
+% %   Custom straight flag. The parameters are: 
+% %                flag thickness and spacing
+%                up-flag angle and length
+%                down-flag angle and length
+%   \override Stem #'flag = #(straight-flag 0.35 0.8 -5 0.5 60 2.0)
+%   \testnotes
+}

diff --git a/scm/flag-styles.scm b/scm/flag-styles.scm
index acdc38108fcb4d4d84cad692f8f85a72b138d80c..83ee50e97d5d42e71d948fc58686bc0fc4ca214f 100644 (file)
--- a/scm/flag-styles.scm
+++ b/scm/flag-styles.scm
@@ -13,41 +13,87 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-;; ;; TODO
-;; (define-public (add-stroke-straight stencil dir stroke-style)
-;;   stencil
-;; )
-;;
-;; ;; Create a stencil for a straight flag
-;; ;; flag-thickness, -spacing are given in staff spaces
-;; ;; *flag-length are given in black notehead widths
-;; ;; TODO
-;; (define-public (straight-flag flag-thickness flag-spacing
-;;                        upflag-angle upflag-length
-;;                        downflag-angle downflag-length)
-;;   (lambda (stem-grob)
-;;     (let* ((log (ly:grob-property stem-grob 'duration-log))
-;;            (staff-space 1) ; TODO
-;;            (black-notehead-width 1) ; TODO
-;;            (stem-thickness 1) ; TODO: get rid of
-;;            (half-stem-thickness (/ stem-thickness 2))
-;;            (staff-space 1) ; TODO
-;;            (up-length (+ (* upflag-length black-notehead-width) half-stem-thickness))
-;;            (down-length (+ (* downflag-length black-notehead-width) half-stem-thickness))
-;;            (thickness (* flag-thickness staff-space))
-;;            (spacing (* flag-spacing staff-space)))
-;;       empty-stencil
-;;     )
-;;   )
-;; )
-;;
-;; ;; Modern straight flags: angles are not so large as with the old style
-;; (define-public (modern-straight-flag stem-grob)
-;;   ((straight-flag 0.55 0.9 -18 0.95 22 1.0) stem-grob))
-;;
-;; ;; Old-straight flags (Bach, etc.): quite large flag angles
-;; (define-public (old-straight-flag stem-grob)
-;;   ((straight-flag 0.55 0.9 -45 0.95 45 1.0) stem-grob))
+(define-public (add-stroke-straight stencil stem-grob stem-up? log stroke-style offset length thickness stroke-thickness)
+  "Add the stroke for acciaccatura to the given flag stencil."
+  (let* ((udmult (if stem-up? 1 -1))
+         (start (offset-add offset (cons 0  (* (/ length 2) udmult))))
+         (end (offset-add (cons 0 (cdr offset)) 
+                          (cons (- (/ (car offset) 2)) (* (- (+ thickness (car offset))) udmult))))
+         (stroke (make-line-stencil stroke-thickness (car start) (cdr start) (car end) (cdr end))))
+  (ly:stencil-add stencil stroke)))
+
+(define (polar->rectangular radius angle-in-degrees)
+  "Convert polar coordinate @code{radius} and @code{angle-in-degrees}
+   to (x-length . y-length)"
+  (let* ((conversion-constant (/ (atan 1 1) 45))
+         (complex (make-polar
+                    radius
+                    (* conversion-constant angle-in-degrees))))
+     (cons
+       (real-part complex)
+       (imag-part complex))))
+
+(define (buildflag flag-stencil remain curr-stencil spacing)
+  (if (> remain 0)
+      (let* ((translated-stencil (ly:stencil-translate-axis curr-stencil spacing Y))
+             (new-stencil (ly:stencil-add flag-stencil translated-stencil)))
+        (buildflag new-stencil (- remain 1) translated-stencil spacing))
+      flag-stencil))
+
+(define-public (straight-flag flag-thickness flag-spacing
+                       upflag-angle upflag-length
+                       downflag-angle downflag-length)
+    "Create a stencil for a straight flag.
+     flag-thickness, -spacing are given in staff spaces,
+     *flag-angle is given in degree,
+     *flag-length is given in staff spaces"
+  (lambda (stem-grob)
+    (let* ((log (ly:grob-property stem-grob 'duration-log))
+           (layout (ly:grob-layout stem-grob))
+           (stem-up? (eqv? (ly:grob-property stem-grob 'direction) UP))
+           ; scale with the note size (e.g. for grace notes). Default fontsize 
+           ; is fs==0, each step is ~12.246% larger / smaller
+           (fs (ly:grob-property stem-grob 'font-size))
+           (factor (if (number? fs) (expt 1.12246 fs) 1))
+           (grob-stem-thickness (ly:grob-property stem-grob 'thickness))
+           (line-thickness (ly:output-def-lookup layout 'line-thickness))
+           (half-stem-thickness (/ (* grob-stem-thickness line-thickness) 2))
+           (up-length (+ (* upflag-length factor) half-stem-thickness))
+           (up-off (polar->rectangular up-length upflag-angle))
+           (down-length (+ (* downflag-length factor) half-stem-thickness))
+           (down-off (polar->rectangular down-length downflag-angle))
+           (thickness (* flag-thickness factor))
+           (offset (cons 0 (if stem-up? (- thickness) thickness)))
+           (spacing (* flag-spacing factor (if stem-up? -1 1)))
+           (start (cons (- half-stem-thickness) (if stem-up? half-stem-thickness (- half-stem-thickness))))
+           (points (if stem-up? (list start up-off
+                                      (offset-add up-off offset)
+                                      (offset-add start offset))
+                                (list start
+                                      (offset-add start offset)
+                                      (offset-add down-off offset)
+                                      down-off)))
+           (stencil (ly:round-filled-polygon points half-stem-thickness))
+           ; Log for 1/8 is 3, so we need to subtract 3
+           (flag-stencil (buildflag stencil (- log 3) stencil spacing))
+           (stroke-style (ly:grob-property stem-grob 'stroke-style)))
+    (if (null? stroke-style)
+      flag-stencil
+      (add-stroke-straight flag-stencil stem-grob
+                           stem-up? log
+                           stroke-style
+                           (if stem-up? up-off down-off)
+                           (if stem-up? up-length down-length)
+                           thickness
+                           (* half-stem-thickness 2))))))
+
+;; Modern straight flags: angles are not as large as in the old style
+(define-public (modern-straight-flag stem-grob)
+  ((straight-flag 0.55 1 -18 1.1 22 1.2) stem-grob))
+
+;; Old-straight flags (Bach, etc.): quite large flag angles
+(define-public (old-straight-flag stem-grob)
+  ((straight-flag 0.55 1 -45 1.2 45 1.4) stem-grob))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;