X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-lib.scm;h=d29e26498c7f4b7bd4138530e1fed71d61087369;hb=a1c2a3a778efafbb8abbd44eb212a3f52f34c5f9;hp=b2d7bea66b5e52867d7e7b0a7d752708e72f4672;hpb=f0440dedd223df1d1db122a61c0aa52166929438;p=lilypond.git diff --git a/scm/output-lib.scm b/scm/output-lib.scm index b2d7bea66b..d29e26498c 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--2010 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 . ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -46,50 +57,6 @@ (ly:text-interface::interpret-markup layout props text))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; tablature - -;; The TabNoteHead tablatureFormat callback. -;; Compute the text grob-property -(define-public (fret-number-tablature-format string context event) - (let* ((tuning (ly:context-property context 'stringTunings)) - (pitch (ly:event-property event 'pitch)) - (is-harmonic (apply - functional-or - (map - (lambda (ev) - (eq? 'harmonic-event (ly:event-property ev 'class))) - (ly:event-property event 'articulations))))) - - (make-whiteout-markup - (make-vcenter-markup - (format - "~a" - (- (ly:pitch-semitones pitch) - (list-ref tuning - ;; remove 1 because list index starts at 0 - ;;and guitar string at 1. - (1- string)))))))) - -;; The 5-string banjo has got a extra string, the fifth (duh), which -;; starts at the fifth fret on the neck. Frets on the fifth string -;; are referred to relative to the other frets: -;; the "first fret" on the fifth string is really the sixth fret -;; on the banjo neck. -;; We solve this by defining a new fret-number-tablature function: -(define-public (fret-number-tablature-format-banjo string context event) - (let* ((tuning (ly:context-property context 'stringTunings)) - (pitch (ly:event-property event 'pitch))) - - (make-whiteout-markup - (make-vcenter-markup - (let ((fret (- (ly:pitch-semitones pitch) (list-ref tuning (1- string))))) - (number->string (cond - ((and (> fret 0) (= string 5)) - (+ fret 5)) - (else fret)))))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; note heads @@ -120,69 +87,91 @@ ((= 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))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; bar numbers - -(define-public ((every-nth-bar-number-visible n) barnum) - (= 0 (modulo barnum n))) - -(define-public ((modulo-bar-number-visible n m) barnum) (and (> barnum 1) (= m (modulo barnum n)))) - -(define-public ((set-bar-number-visibility n) tr) - (let ((bn (ly:context-property tr 'currentBarNumber))) - (ly:context-set-property! tr 'barNumberVisibility - (modulo-bar-number-visible n (modulo bn n))))) - -(define-public (first-bar-number-invisible barnum) (> barnum 1)) - -(define-public (all-bar-numbers-visible barnum) #t) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; percent repeat counters - -(define-public ((every-nth-repeat-count-visible n) count context) - (= 0 (modulo count n))) - -(define-public (all-repeat-counts-visible count context) #t) + (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 (and (vector? note-names) + (> (vector-length note-names) pitch-index)) + (vector-ref note-names pitch-index) + (string + (integer->char + (+ (modulo (+ pitch-index 2) 7) + (char->integer #\A)))))) + (staff-space (ly:staff-symbol-staff-space grob)) + (line-thickness (ly:staff-symbol-line-thickness grob)) + (stem (ly:grob-object grob 'stem)) + (stem-thickness (* (if (ly:grob? stem) + (ly:grob-property stem 'thickness) + 1.3) + line-thickness)) + (radius (/ (+ staff-space line-thickness) 2)) + (letter (markup #:center-align #:vcenter pitch-string)) + (filled-circle (markup #:draw-circle radius 0 #t))) + + (ly:stencil-translate-axis + (grob-interpret-markup + grob + (if (>= log 2) + (make-combine-markup + filled-circle + (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -229,26 +218,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) @@ -329,7 +329,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 @@ -470,22 +475,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) @@ -655,6 +678,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 @@ -786,21 +830,63 @@ (if (and (pair? live-elts) (interval-sane? (ly:grob-extent grob system Y))) - (begin - (let get-extent ((lst live-elts)) - (if (pair? lst) - (let ((axis-group (car lst))) - - (if (and (ly:spanner? axis-group) - (equal? (ly:spanner-bound axis-group LEFT) - left-bound)) - (set! extent (add-point extent - (ly:grob-relative-coordinate - axis-group system Y)))) - (get-extent (cdr lst))))) - (+ - (ly:self-alignment-interface::y-aligned-on-self grob) - (interval-center extent))) + (let get-extent ((lst live-elts)) + (if (pair? lst) + (let ((axis-group (car lst))) + + (if (and (ly:spanner? axis-group) + (equal? (ly:spanner-bound axis-group LEFT) + left-bound)) + (set! extent (add-point extent + (ly:grob-relative-coordinate + axis-group system Y)))) + (get-extent (cdr lst))))) ;; no live axis group(s) for this instrument name -> remove from system - (ly:grob-suicide! grob)))) + (ly:grob-suicide! grob)) + (+ + (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))