X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=400506a8a5f119d84abdeacab8efd7abd876c1e4;hb=1c846b2c2348b4e0ca4a3c2e8fb267047ba2d203;hp=444f77df06965be181cb0f660dbef72cb85914b7;hpb=2ab74d973d0b3ade2b5e0a669a22415b56edb5d3;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index 444f77df06..400506a8a5 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 +;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys +;;;; +;;;; 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 . ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -76,49 +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))) - ((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 @@ -135,18 +158,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 (car a) (car b)) #f) + (else + (ly:moment=? a b) + (rhythmic-location? a b) + (rhythmic-locationfile-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 @@ -159,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)) @@ -192,26 +271,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) @@ -292,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 @@ -433,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) @@ -618,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 @@ -729,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 ((elements (ly:grob-object me 'elements))) - (let get-live ((len elts-length)) - (if (> len 0) - (let ((elt (ly:grob-array-ref elements (1- len)))) - - (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)) @@ -766,3 +892,47 @@ (+ (ly:self-alignment-interface::y-aligned-on-self grob) (interval-center extent)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ambitus + +(define-public (ambitus::print grob) + (let ((heads (ly:grob-object grob 'note-heads))) + + (if (and (ly:grob-array? heads) + (= (ly:grob-array-length heads) 2)) + (let* ((common (ly:grob-common-refpoint-of-array grob heads Y)) + (head-down (ly:grob-array-ref heads 0)) + (head-up (ly:grob-array-ref heads 1)) + (gap (ly:grob-property grob 'gap 0.35)) + (point-min (+ (interval-end (ly:grob-extent head-down common Y)) + gap)) + (point-max (- (interval-start (ly:grob-extent head-up common Y)) + gap))) + + (if (< point-min point-max) + (let* ((layout (ly:grob-layout grob)) + (line-thick (ly:output-def-lookup layout 'line-thickness)) + (blot (ly:output-def-lookup layout 'blot-diameter)) + (grob-thick (ly:grob-property grob 'thickness 2)) + (width (* line-thick grob-thick)) + (x-ext (symmetric-interval (/ width 2))) + (y-ext (cons point-min point-max)) + (line (ly:round-filled-box x-ext y-ext blot)) + (y-coord (ly:grob-relative-coordinate grob common Y))) + + (ly:stencil-translate-axis line (- y-coord) Y)) + empty-stencil)) + (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)) +