X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=400506a8a5f119d84abdeacab8efd7abd876c1e4;hb=1c846b2c2348b4e0ca4a3c2e8fb267047ba2d203;hp=f210bb6dc6d3ea97c82c7861adcebe6e6309f1eb;hpb=b7a0cffbf9d1069860368f289a5b50e9d1d90ba8;p=lilypond.git

diff --git a/scm/output-lib.scm b/scm/output-lib.scm
index f210bb6dc6..400506a8a5 100644
--- a/scm/output-lib.scm
+++ b/scm/output-lib.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (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
@@ -87,54 +87,61 @@
      ((= 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))))
+    ((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
@@ -166,6 +173,55 @@
 	   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
@@ -178,6 +234,10 @@
 (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 spanbar-begin-of-line-invisible #(#t #f #f))
 
@@ -211,7 +271,18 @@
     ("'" . ("'" . ()))
     ("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))
@@ -311,7 +382,12 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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
@@ -452,22 +528,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)
@@ -637,6 +731,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
@@ -748,18 +863,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))
@@ -820,3 +927,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))
+