;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; ;;;; Copyright (C) 2006--2015 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 . (define-module (scm paper-system)) (use-modules (lily) (srfi srfi-1) (ice-9 optargs)) (define-public (paper-system-title? system) (equal? #t (ly:prob-property system 'is-title) )) (define (system-stencil system-grob main-stencil) (let* ((padding (ly:grob-property system-grob 'in-note-padding #f)) (in-notes (if padding (ly:grob-property system-grob 'in-note-stencil) empty-stencil)) (in-notes (if in-notes in-notes empty-stencil)) (direction (if padding (ly:grob-property system-grob 'in-note-direction) UP))) (if padding (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding) main-stencil))) (define-public (paper-system-stencil system) (let ((main-stencil (ly:prob-property system 'stencil)) (system-grob (ly:prob-property system 'system-grob))) (if (ly:grob? system-grob) (system-stencil system-grob main-stencil) main-stencil))) (define-public (paper-system-layout system) (let* ((g (paper-system-system-grob system))) (if (ly:grob? g) (ly:grob-layout g) #f))) (define-public (paper-system-system-grob paper-system) (ly:prob-property paper-system 'system-grob)) (define-public (paper-system-extent system axis) (ly:stencil-extent (paper-system-stencil system) axis)) (define-public (paper-system-staff-extents ps) (ly:prob-property ps 'staff-refpoint-extent '(0 . 0))) (define-public (paper-system-annotate-last system layout) (let* ((bottomspace (ly:prob-property system 'bottom-space)) (y-extent (paper-system-extent system Y)) (x-extent (paper-system-extent system X)) (stencil (ly:prob-property system 'stencil)) (arrow (if (number? bottomspace) (annotate-y-interval layout "bottom-space" (cons (- (car y-extent) bottomspace) (car y-extent)) #t) #f))) (if arrow (set! stencil (ly:stencil-add stencil arrow))) (set! (ly:prob-property system 'stencil) stencil) )) ;; Y-ext and next-Y-ext are either skyline-pairs or extents (define*-public (annotate-padding system-Y system-X Y-ext X-ext next-system-Y next-system-X next-Y-ext next-X-ext layout horizon-padding padding #:key (base-color blue)) (let* ((eps 0.001) (skyline (and (ly:skyline-pair? Y-ext) (ly:skyline-pair::skyline Y-ext DOWN))) (next-skyline (and (ly:skyline-pair? next-Y-ext) (ly:skyline-pair::skyline next-Y-ext UP))) (annotation-X (cond ((and skyline next-skyline) (- (ly:skyline::get-touching-point skyline next-skyline horizon-padding) horizon-padding)) (skyline (ly:skyline::get-max-height-position skyline)) (next-skyline (ly:skyline::get-max-height-position next-skyline)) (else (max (cdr X-ext) (cdr next-X-ext))))) (annotation-Y (if skyline (ly:skyline::get-height skyline annotation-X) (car Y-ext))) (next-annotation-Y (if next-skyline (- (+ (ly:skyline::get-height next-skyline (- (+ annotation-X system-X) next-system-X)) next-system-Y) system-Y) (cdr next-Y-ext))) (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps))) (contrast-color (append (cdr base-color) (list (car base-color)))) (color (if padding-blocks contrast-color base-color)) (annotation (ly:stencil-translate-axis (annotate-y-interval layout "padding" `(,(- annotation-Y padding). ,annotation-Y) #t #:color color) annotation-X X))) (if (> padding 0.0) annotation empty-stencil))) (define-public (paper-system-annotate system next-system layout) "Add arrows and texts to indicate which lengths are set." (let* ((grob (ly:prob-property system 'system-grob)) (paper-height (ly:output-def-lookup layout 'paper-height)) (bottom-margin (ly:output-def-lookup layout 'bottom-margin)) (top-margin (ly:output-def-lookup layout 'top-margin)) (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '())) (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '())) (spaceable-staff-annotate (lambda (before-staff after-staff) (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y)) (after-Y (ly:grob-relative-coordinate after-staff grob Y))) (annotate-spacing-spec layout ;; FIXME: Improve `ly:get-spacing-spec' to return the ;; name of the used `XXX-XXX-spacing' property, if ;; possible. Right now we have to use the empty ;; string. "" (ly:get-spacing-spec before-staff after-staff) before-Y after-Y)))) (staff-padding-annotate (lambda (before-staff after-staff) (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y)) (before-X (ly:grob-relative-coordinate before-staff grob X)) (before-X-ext (ly:grob-extent before-staff before-staff X)) (after-Y (ly:grob-relative-coordinate after-staff grob Y)) (after-X (ly:grob-relative-coordinate after-staff grob X)) (after-X-ext (ly:grob-extent after-staff after-staff X)) (skylines (ly:grob-property before-staff 'vertical-skylines)) (after-skylines (ly:grob-property after-staff 'vertical-skylines)) (padding (assoc-get 'padding (ly:get-spacing-spec before-staff after-staff) 0.0)) (horizon-padding (ly:grob-property before-staff 'skyline-horizontal-padding 0.0))) (ly:stencil-translate (annotate-padding before-Y before-X skylines before-X-ext after-Y after-X after-skylines after-X-ext layout horizon-padding padding) (cons before-X before-Y))))) (staff-annotations (if (< 1 (length spaceable-staves)) (map spaceable-staff-annotate (drop-right spaceable-staves 1) (drop spaceable-staves 1)) '())) (staff-padding-annotations (if (< 1 (length all-staves)) (map staff-padding-annotate (drop-right all-staves 1) (drop all-staves 1)) '())) (estimate-extent (if (ly:grob? grob) (annotate-y-interval layout "extent-estimate" (ly:grob-property grob 'pure-Y-extent) #f) #f)) (spacing-spec-sym (cond ((and next-system (paper-system-title? system) (paper-system-title? next-system)) 'markup-markup-spacing) ((paper-system-title? system) 'markup-system-spacing) ((and next-system (paper-system-title? next-system)) 'score-markup-spacing) ((not next-system) 'last-bottom-spacing) ((ly:prob-property system 'last-in-score #f) 'score-system-spacing) (else 'system-system-spacing))) (spacing-spec (ly:output-def-lookup layout spacing-spec-sym)) (last-staff-Y (car (paper-system-staff-extents system))) (system-Y (ly:prob-property system 'Y-offset 0.0)) (system-X (ly:prob-property system 'X-offset 0.0)) (next-system-Y (and next-system (ly:prob-property next-system 'Y-offset 0.0))) (next-system-X (and next-system (ly:prob-property next-system 'X-offset 0.0))) (first-staff-next-system-Y (if next-system (- (+ (cdr (paper-system-staff-extents next-system)) system-Y) next-system-Y) (+ system-Y top-margin bottom-margin (- paper-height)))) (skyline (or (ly:prob-property system 'vertical-skylines #f) (paper-system-extent system Y))) (next-skyline (and next-system (or (ly:prob-property next-system 'vertical-skylines #f) (paper-system-extent next-system Y)))) (horizon-padding (and (ly:grob? grob) (ly:grob-property grob 'skyline-horizontal-padding 0))) (padding-annotation (if (skyline-pair-and-non-empty? next-system) (annotate-padding (- system-Y) system-X skyline (paper-system-extent system X) (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X) layout horizon-padding (assoc-get 'padding spacing-spec 0.0) #:base-color blue) empty-stencil)) (system-annotation (annotate-spacing-spec layout (symbol->string spacing-spec-sym) spacing-spec last-staff-Y first-staff-next-system-Y)) (annotations (ly:stencil-add padding-annotation (stack-stencils Y DOWN 0.0 staff-padding-annotations) (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation)))))) (if estimate-extent (set! annotations (stack-stencils X RIGHT 5.5 (list annotations estimate-extent)))) (if (not (null? annotations)) (set! (ly:prob-property system 'stencil) (ly:stencil-add (ly:prob-property system 'stencil) (ly:make-stencil (ly:stencil-expr annotations) (ly:stencil-extent empty-stencil X) (ly:stencil-extent empty-stencil Y))))) (ly:prob-property system 'stencil)))