X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=025590e5bae0e001db8f089a96b811485faa1198;hb=4a03918c90866800b208ad12ffc019f577c8ab83;hp=68c338dfb8cc3e28fe6e8e3e6db72b5a9a985659;hpb=b3f0c2f6c352a850f03dc44a947776199eb3fa0b;p=lilypond.git

diff --git a/scm/output-lib.scm b/scm/output-lib.scm
index 68c338dfb8..025590e5ba 100644
--- a/scm/output-lib.scm
+++ b/scm/output-lib.scm
@@ -1,9 +1,20 @@
-;;;; output-lib.scm -- implement Scheme output helper functions
+;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;;  source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -16,15 +27,14 @@
   (pair? (ly:grob-basic-properties grob)))
 
 (define-public (make-stencil-boxer thickness padding callback)
-
   "Return function that adds a box around the grob passed as argument."
   (lambda (grob)
     (box-stencil (callback grob) thickness padding)))
 
 (define-public (make-stencil-circler thickness padding callback)
   "Return function that adds a circle around the grob passed as argument."
-
-  (lambda (grob) (circle-stencil (callback grob) thickness padding)))
+  (lambda (grob)
+    (circle-stencil (callback grob) thickness padding)))
 
 (define-public (print-circled-text-callback grob)
   (grob-interpret-markup grob (make-circle-markup
@@ -76,54 +86,69 @@
      ((= log -1) 1)
      (else 0))))
 
-;; silly, use alist?
+;; Kept separate from note-head::calc-glyph-name to allow use by
+;; markup commands \note and \note-by-number
+(define-public (select-head-glyph style log)
+  "Select a note head glyph string based on note head style @var{style}
+and duration-log @var{log}."
+  (case style
+    ;; "default" style is directly handled in note-head.cc as a
+    ;; special case (HW says, mainly for performance reasons).
+    ;; Therefore, style "default" does not appear in this case
+    ;; statement.  -- jr
+    ((xcircle) "2xcircle")
+    ((harmonic) "0harmonic")
+    ((harmonic-black) "2harmonic")
+    ((harmonic-mixed) (if (<= log 1) "0harmonic"
+			  "2harmonic"))
+    ((baroque)
+     ;; Oops, I actually would not call this "baroque", but, for
+     ;; backwards compatibility to 1.4, this is supposed to take
+     ;; brevis, longa and maxima from the neo-mensural font and all
+     ;; other note heads from the default font.  -- jr
+     (if (< log 0)
+	 (string-append (number->string log) "neomensural")
+	 (number->string log)))
+    ((altdefault)
+     ;; Like default, but brevis is drawn with double vertical lines
+     (if (= log -1)
+	 (string-append (number->string log) "double")
+	 (number->string log)))
+    ((mensural)
+     (string-append (number->string log) (symbol->string style)))
+    ((petrucci)
+     (if (< log 0)
+	 (string-append (number->string log) "mensural")
+	 (string-append (number->string log) (symbol->string style))))
+    ((blackpetrucci)
+     (if (< log 0)
+	 (string-append (number->string log) "blackmensural")
+	 (string-append (number->string log) (symbol->string style))))
+    ((semipetrucci)
+     (if (< log 0)
+	 (string-append (number->string log) "semimensural")
+	 (string-append (number->string log) "petrucci")))
+    ((neomensural)
+     (string-append (number->string log) (symbol->string style)))
+    (else
+     (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style))
+	 (symbol->string style)
+	 (string-append (number->string (max 0 log))
+			(symbol->string style))))))
+
 (define-public (note-head::calc-glyph-name grob)
   (let ((style (ly:grob-property grob 'style))
 	(log (min 2 (ly:grob-property grob 'duration-log))))
 
-    (case style
-      ;; "default" style is directly handled in note-head.cc as a
-      ;; special case (HW says, mainly for performance reasons).
-      ;; Therefore, style "default" does not appear in this case
-      ;; statement.  -- jr
-      ((xcircle) "2xcircle")
-      ((harmonic) "0harmonic")
-      ((harmonic-black) "2harmonic")
-      ((harmonic-mixed) (if (<= log 1) "0harmonic"
-			    "2harmonic"))
-      ((baroque)
-       ;; Oops, I actually would not call this "baroque", but, for
-       ;; backwards compatibility to 1.4, this is supposed to take
-       ;; brevis, longa and maxima from the neo-mensural font and all
-       ;; other note heads from the default font.  -- jr
-       (if (< log 0)
-	   (string-append (number->string log) "neomensural")
-	   (number->string log)))
-      ((altdefault)
-       ;; Like default, but brevis is drawn with double vertical lines
-       (if (= log -1)
-	   (string-append (number->string log) "double")
-	   (number->string log)))
-      ((mensural)
-       (string-append (number->string log) (symbol->string style)))
-      ((petrucci)
-       (if (< log 0)
-	   (string-append (number->string log) "mensural")
-	   (string-append (number->string log) (symbol->string style))))
-      ((neomensural)
-       (string-append (number->string log) (symbol->string style)))
-      (else
-       (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style))
-	   (symbol->string style)
-	   (string-append (number->string (max 0 log))
-			  (symbol->string style)))))))
+    (select-head-glyph style log)))
 
 (define-public (note-head::brew-ez-stencil grob)
   (let* ((log (ly:grob-property grob 'duration-log))
 	 (pitch (ly:event-property (event-cause grob) 'pitch))
 	 (pitch-index (ly:pitch-notename pitch))
 	 (note-names (ly:grob-property grob 'note-names))
-	 (pitch-string (if (vector? note-names)
+	 (pitch-string (if (and (vector? note-names)
+				(> (vector-length note-names) pitch-index))
 			   (vector-ref note-names pitch-index)
 			   (string
 			    (integer->char
@@ -140,18 +165,70 @@
 	 (letter (markup #:center-align #:vcenter pitch-string))
 	 (filled-circle (markup #:draw-circle radius 0 #t)))
 
-    (grob-interpret-markup
-     grob
-     (if (>= log 2)
-	 (make-combine-markup
-	  filled-circle
-	  (make-with-color-markup white letter))
-	 (make-combine-markup
+    (ly:stencil-translate-axis
+     (grob-interpret-markup
+      grob
+      (if (>= log 2)
 	  (make-combine-markup
 	   filled-circle
-	   (make-with-color-markup white (make-draw-circle-markup
-					  (- radius stem-thickness) 0 #t)))
-	  letter)))))
+	   (make-with-color-markup white letter))
+	  (make-combine-markup
+	   (make-combine-markup
+	    filled-circle
+	    (make-with-color-markup white (make-draw-circle-markup
+					   (- radius stem-thickness) 0 #t)))
+	   letter)))
+     radius X)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; clipping
+
+(define-public (make-rhythmic-location bar-num num den)
+  (cons
+   bar-num (ly:make-moment num den)))
+
+(define-public (rhythmic-location? a)
+  (and (pair? a)
+       (integer? (car a))
+       (ly:moment? (cdr a))))
+
+(define-public (make-graceless-rhythmic-location loc)
+  (make-rhythmic-location
+   (car loc)
+   (ly:moment-main-numerator (rhythmic-location-measure-position loc))
+   (ly:moment-main-denominator (rhythmic-location-measure-position loc))))
+
+(define-public rhythmic-location-measure-position cdr)
+(define-public rhythmic-location-bar-number car)
+
+(define-public (rhythmic-location<? a b)
+  (cond
+   ((< (car a) (car b)) #t)
+   ((> (car a) (car b)) #f)
+   (else
+    (ly:moment<? (cdr a) (cdr b)))))
+
+(define-public (rhythmic-location<=? a b)
+  (not (rhythmic-location<? b a)))
+(define-public (rhythmic-location>=? a b)
+  (rhythmic-location<? a b))
+(define-public (rhythmic-location>? a b)
+  (rhythmic-location<? b a))
+
+(define-public (rhythmic-location=? a b)
+  (and (rhythmic-location<=? a b)
+       (rhythmic-location<=? b a)))
+
+(define-public (rhythmic-location->file-string a)
+  (ly:format "~a.~a.~a"
+	     (car a)
+	     (ly:moment-main-numerator (cdr a))
+	     (ly:moment-main-denominator (cdr a))))
+
+(define-public (rhythmic-location->string a)
+  (ly:format "bar ~a ~a"
+	     (car a)
+	     (ly:moment->string (cdr a))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; break visibility
@@ -164,6 +241,13 @@
 (define-public center-visible          #(#f #t #f))
 (define-public end-of-line-visible     #(#t #f #f))
 (define-public all-invisible           #(#f #f #f))
+(define-public (inherit-x-parent-visibility grob)
+  (let ((parent (ly:grob-parent grob X)))
+    (ly:grob-property parent 'break-visibility all-invisible)))
+(define-public (inherit-y-parent-visibility grob)
+  (let ((parent (ly:grob-parent grob X)))
+    (ly:grob-property parent 'break-visibility)))
+
 
 (define-public spanbar-begin-of-line-invisible #(#t #f #f))
 
@@ -197,26 +281,37 @@
     ("'" . ("'" . ()))
     ("empty" . (() . ()))
     ("brace" . (() . "brace"))
-    ("bracket" . (() . "bracket"))))
+    ("bracket" . (() . "bracket"))
+
+    ;; segno bar lines
+    ("S" . ("||" . "S"))
+    ("|S" . ("|" . "S"))
+    ("S|" . ("S" . ()))
+    (":|S" . (":|" . "S"))
+    (":|S." . (":|S" . ()))
+    ("S|:" . ("S" . "|:"))
+    (".S|:" . ("|" . "S|:"))
+    (":|S|:" . (":|" . "S|:"))
+    (":|S.|:" . (":|S" . "|:"))))
 
 (define-public (bar-line::calc-glyph-name grob)
   (let* ((glyph (ly:grob-property grob 'glyph))
 	 (dir (ly:item-break-dir grob))
-	 (result (assoc glyph  bar-glyph-alist))
+	 (result (assoc-get glyph bar-glyph-alist))
 	 (glyph-name (if (= dir CENTER)
 			 glyph
 		         (if (and result
-				  (string? (index-cell (cdr result) dir)))
-			     (index-cell (cdr result) dir)
+				  (string? (index-cell result dir)))
+			     (index-cell result dir)
 			     #f))))
     glyph-name))
 
 (define-public (bar-line::calc-break-visibility grob)
   (let* ((glyph (ly:grob-property grob 'glyph))
-	 (result (assoc glyph bar-glyph-alist)))
+	 (result (assoc-get glyph bar-glyph-alist)))
 
     (if result
-	(vector (string? (cadr result)) #t (string? (cddr result)))
+	(vector (string? (car result)) #t (string? (cdr result)))
 	all-invisible)))
 
 (define-public (shift-right-at-line-begin g)
@@ -229,13 +324,16 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Tuplets
 
+(define-public (tuplet-number::calc-direction grob)
+  (ly:tuplet-bracket::calc-direction (ly:grob-object grob 'bracket)))
+
 (define-public (tuplet-number::calc-denominator-text grob)
   (number->string (ly:event-property (event-cause grob) 'denominator)))
 
 (define-public (tuplet-number::calc-fraction-text grob)
   (let ((ev (event-cause grob)))
 
-    (format "~a:~a"
+    (format #f "~a:~a"
 	    (ly:event-property ev 'denominator)
 	    (ly:event-property ev 'numerator))))
 
@@ -265,7 +363,7 @@
          (den (if denominator denominator (ly:event-property ev 'denominator)))
          (num (if numerator numerator (ly:event-property ev 'numerator))))
 
-    (format "~a:~a" den num)))
+    (format #f "~a:~a" den num)))
 
 ;; Print a tuplet fraction with note durations appended to the numerator and the
 ;; denominator
@@ -287,17 +385,22 @@
          (num (if numerator numerator (ly:event-property ev 'numerator))))
 
     (make-concat-markup (list
-			 (make-simple-markup (format "~a" den))
+			 (make-simple-markup (format #f "~a" den))
 			 (markup #:fontsize -5 #:note denominatornote UP)
 			 (make-simple-markup " : ")
-			 (make-simple-markup (format "~a" num))
+			 (make-simple-markup (format #f "~a" num))
 			 (markup #:fontsize -5 #:note numeratornote UP)))))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Color
 
-(define-public color? list?)
+(define-public (color? x)
+  (and (list? x)
+       (= 3 (length x))
+       (apply eq? #t (map number? x))
+       (apply eq? #t (map (lambda (y) (<= 0 y 1)) x))))
+
 (define-public (rgb-color r g b) (list r g b))
 
 ; predefined colors
@@ -364,6 +467,25 @@
 	(+ c0 p))))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; annotations
+
+(define-public (numbered-footnotes int)
+  (markup #:tiny (number->string (+ 1 int))))
+
+(define-public (symbol-footnotes int)
+  (define (helper symbols out idx n)
+    (if (< n 1)
+        out
+        (helper symbols
+                (string-append out (list-ref symbols idx))
+                idx
+                (- n 1))))
+  (markup #:tiny (helper '("*" "†" "‡" "§" "¶")
+                          ""
+                          (remainder int 5)
+                          (+ 1 (quotient int 5)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; accidentals
 
@@ -438,22 +560,40 @@
     (list lp rp)))
 
 (define-public (parentheses-item::calc-angled-bracket-stencils grob)
-  (let* ((font (ly:grob-default-font grob))
-	 (lp (ly:stencil-aligned-to (ly:stencil-aligned-to
-				     (grob-interpret-markup
-				      grob
-				      (ly:wide-char->utf-8 #x2329))
-				     Y CENTER)
-				    X RIGHT))
-	 (rp (ly:stencil-aligned-to (ly:stencil-aligned-to
-				     (grob-interpret-markup
-				      grob
-				      (ly:wide-char->utf-8 #x232A))
-				     Y CENTER)
-				    X LEFT)))
-
+  (let* ((parent (ly:grob-parent grob Y))
+         (y-extent (ly:grob-extent parent parent Y))
+         (half-thickness 0.05) ; should it be a property?
+         (width 0.5) ; should it be a property?
+         (angularity 1.5)  ; makes angle brackets
+         (white-padding 0.1) ; should it be a property?
+	 (lp (ly:stencil-aligned-to
+                 (ly:stencil-aligned-to
+                   (make-parenthesis-stencil y-extent
+                                             half-thickness
+                                             (- width)
+                                             angularity)
+                   Y CENTER)
+                 X RIGHT))
+         (lp-x-extent
+           (interval-widen (ly:stencil-extent lp X) white-padding))
+	 (rp (ly:stencil-aligned-to
+                 (ly:stencil-aligned-to
+                   (make-parenthesis-stencil y-extent
+                                             half-thickness
+                                             width
+                                             angularity)
+                   Y CENTER)
+                 X LEFT))
+          (rp-x-extent
+            (interval-widen (ly:stencil-extent rp X) white-padding)))
+    (set! lp (ly:make-stencil (ly:stencil-expr lp)
+                              lp-x-extent
+                              (ly:stencil-extent lp Y)))
+    (set! rp (ly:make-stencil (ly:stencil-expr rp)
+                              rp-x-extent
+                              (ly:stencil-extent rp Y)))
     (list (stencil-whiteout lp)
-	  (stencil-whiteout rp))))
+          (stencil-whiteout rp))))
 
 (define (parenthesize-elements grob . rest)
   (let* ((refp (if (null? rest)
@@ -471,7 +611,7 @@
      (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X))))
 
 
-(define (parentheses-item::print me)
+(define-public (parentheses-item::print me)
   (let* ((elts (ly:grob-object me 'elements))
 	 (y-ref (ly:grob-common-refpoint-of-array me elts Y))
 	 (x-ref (ly:grob-common-refpoint-of-array me elts X))
@@ -623,6 +763,27 @@
       START
       STOP))
 
+(define-public (dynamic-text-spanner::before-line-breaking grob)
+  "Monitor left bound of @code{DynamicTextSpanner} for absolute dynamics.
+If found, ensure @code{DynamicText} does not collide with spanner text by
+changing @code{'attach-dir} and @code{'padding}.  Reads the
+@code{'right-padding} property of @code{DynamicText} to fine tune space
+between the two text elements."
+  (let ((left-bound (ly:spanner-bound grob LEFT)))
+    (if (grob::has-interface left-bound 'dynamic-text-interface)
+	(let* ((details (ly:grob-property grob 'bound-details))
+	       (left-details (ly:assoc-get 'left details))
+	       (my-padding (ly:assoc-get 'padding left-details))
+	       (script-padding (ly:grob-property left-bound 'right-padding 0)))
+
+	  (and (number? my-padding)
+	       (ly:grob-set-nested-property! grob
+					     '(bound-details left attach-dir)
+					     RIGHT)
+	       (ly:grob-set-nested-property! grob
+					     '(bound-details left padding)
+					     (+ my-padding script-padding)))))))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; lyrics
@@ -734,18 +895,10 @@
 (define-public (system-start-text::calc-y-offset grob)
 
   (define (live-elements-list me)
-    (let* ((elements (ly:grob-object me 'elements))
-	   (elts-length (ly:grob-array-length elements))
-	   (live-elements '()))
-
-      (let get-live ((len elts-length))
-	(if (> len 0)
-	    (let ((elt (ly:grob-array-ref elements (1- len))))
+    (let ((elements (ly:grob-object me 'elements)))
 
-	      (if (grob::is-live? elt)
-		  (set! live-elements (cons elt live-elements)))
-	      (get-live (1- len)))))
-      live-elements))
+      (filter! grob::is-live?
+               (ly:grob-array->list elements))))
 
   (let* ((left-bound (ly:spanner-bound grob LEFT))
 	 (live-elts (live-elements-list grob))
@@ -806,3 +959,12 @@
 	(begin
 	  (ly:grob-suicide! grob)
 	  (list)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;  laissez-vibrer tie
+;;
+;;  needed so we can make laissez-vibrer a pure print
+;;
+(define-public (laissez-vibrer::print grob)
+ (ly:tie::print grob))
+