Restore a comment

[lilypond.git] / scm / output-lib.scm

diff --git a/scm/output-lib.scm b/scm/output-lib.scm
index 5f257844542297c5924a0f8e12804310c3a6756f..048e84db3037ab3c96a64d0430f90c6d01c364fd 100644 (file)
--- a/scm/output-lib.scm
+++ b/scm/output-lib.scm
@@ -26,6 +26,9 @@
 (define-public (grob::is-live? grob)
   (pair? (ly:grob-basic-properties grob)))
 
+(define-public (grob::x-parent-width grob)
+  (ly:grob-property (ly:grob-parent grob X) 'X-extent))
+
 (define-public (make-stencil-boxer thickness padding callback)
   "Return function that adds a box around the grob passed as argument."
   (lambda (grob)
@@ -56,6 +59,48 @@
     (ly:text-interface::interpret-markup layout props text)))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; beam slope
+
+;; calculates each slope of a broken beam individually
+(define-public (beam::place-broken-parts-individually grob)
+  (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
+
+;; calculates the slope of a beam as a single unit,
+;; even if it is broken.  this assures that the beam
+;; will pick up where it left off after a line break
+(define-public (beam::align-with-broken-parts grob)
+  (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
+
+;; uses the broken beam style from edition peters combines the
+;; values of place-broken-parts-individually and align-with-broken-parts above,
+;; favoring place-broken-parts-individually when the beam naturally has a steeper
+;; incline and align-with-broken-parts when the beam is flat
+(define-public (beam::slope-like-broken-parts grob)
+  (define (slope y x)
+    (/ (- (cdr y) (car y)) (- (cdr x) (car x))))
+  (let* ((quant1 (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
+         (original (ly:grob-original grob))
+         (siblings (if (ly:grob? original)
+                       (ly:spanner-broken-into original)
+                       '())))
+    (if (null? siblings)
+        quant1
+        (let* ((quant2 (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
+               (x-span (ly:grob-property grob 'X-positions))
+               (slope1 (slope quant1 x-span))
+               (slope2 (slope quant2 x-span))
+               (quant2 (if (not (= (sign slope1) (sign slope2)))
+                           '(0 . 0)
+                           quant2))
+               (factor (/ (atan (abs slope1)) PI-OVER-TWO))
+               (base (cons-map
+                       (lambda (x)
+                         (+ (* (x quant1) (- 1 factor))
+                            (* (x quant2) factor)))
+                       (cons car cdr))))
+          (ly:beam::quanting grob base #f)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; cross-staff stuff
 
@@ -72,16 +117,21 @@
   (ly:duration-log
    (ly:event-property (event-cause grob) 'duration)))
 
-(define-public (stem::length val)
-  (lambda (grob)
-    (let* ((d (ly:grob-property grob 'direction))
-           (ss (ly:staff-symbol-staff-space grob))
-           (beg (ly:stem::calc-stem-begin-position grob))
-           (y1 (* beg (* 0.5 ss)))
-           (y2 (* ((if (eqv? d DOWN) - +) beg val) (* 0.5 ss))))
-      (if (eqv? d DOWN)
-          (cons y2 y1)
-          (cons y1 y2)))))
+(define-public (stem::length grob)
+  (let* ((ss (ly:staff-symbol-staff-space grob))
+         (beg (ly:grob-property grob 'stem-begin-position))
+         (beam (ly:grob-object grob 'beam)))
+    (if (null? beam)
+        (abs (- (ly:stem::calc-stem-end-position grob) beg))
+        (begin
+          (ly:programming-error
+            "stem::length called but will not be used for beamed stem.")
+          0.0))))
+
+(define-public (stem::pure-length grob beg end)
+  (let* ((ss (ly:staff-symbol-staff-space grob))
+         (beg (ly:grob-pure-property grob 'stem-begin-position 0 1000)))
+    (abs (- (ly:stem::pure-calc-stem-end-position grob 0 2147483646) beg))))
 
 (define-public (note-head::calc-duration-log grob)
   (min 2
@@ -340,6 +390,46 @@ and duration-log @var{log}."
           (equal? (ly:item-break-dir g) RIGHT))
       (ly:grob-translate-axis! g 3.5 X)))
 
+(define-public (pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line grob)
+  (if (= 1 (ly:item-break-dir grob))
+      (pure-from-neighbor-interface::extra-spacing-height grob)
+      (cons -0.1 0.1)))
+
+(define-public (pure-from-neighbor-interface::extra-spacing-height grob)
+  (let* ((height (ly:grob::stencil-height grob))
+         (from-neighbors (interval-union
+                            height
+                            (ly:axis-group-interface::pure-height
+                              grob
+                              0
+                              10000000))))
+    (coord-operation - from-neighbors height)))
+
+(define-public (pure-from-neighbor-interface::account-for-span-bar grob)
+  (define (other-op x) (x (cons cdr car)))
+  (let* ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
+         (hsb (ly:grob-property grob 'has-span-bar)))
+    (if (pair? hsb)
+      (cons-map
+        (lambda (x)
+          (if (and ((other-op x) hsb)
+                   (not (and (eq? x car)
+                             (not (ly:grob-property grob 'allow-span-bar)))))
+              (x esh)
+              (x (cons -1.01 1.01))))
+        (cons car cdr))
+      ;; sufficient height to prevent ledger lines from moving over/under
+      '(-1.01 . 1.01))))
+
+(define-public (pure-from-neighbor-interface::extra-spacing-height-including-staff grob)
+  (let ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
+        (to-staff (coord-operation -
+                                   (interval-widen
+                                     '(0 . 0)
+                                     (ly:staff-symbol-staff-radius grob))
+                                   (ly:grob::stencil-height grob))))
+    (interval-union esh to-staff)))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Tuplets