1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2006--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
18 (define-module (scm paper-system))
24 (define-public (paper-system-title? system)
25 (equal? #t (ly:prob-property system 'is-title)
28 (define (system-stencil system-grob main-stencil)
29 (let* ((padding (ly:grob-property system-grob 'in-note-padding #f))
30 (in-notes (if padding (ly:grob-property system-grob 'in-note-stencil) empty-stencil))
31 (in-notes (if in-notes in-notes empty-stencil))
32 (direction (if padding (ly:grob-property system-grob 'in-note-direction) UP)))
34 (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding)
37 (define-public (paper-system-stencil system)
38 (let ((main-stencil (ly:prob-property system 'stencil))
39 (system-grob (ly:prob-property system 'system-grob)))
40 (if (ly:grob? system-grob)
41 (system-stencil system-grob main-stencil)
44 (define-public (paper-system-layout system)
46 ((g (paper-system-system-grob system)))
52 (define-public (paper-system-system-grob paper-system)
53 (ly:prob-property paper-system 'system-grob))
55 (define-public (paper-system-extent system axis)
56 (ly:stencil-extent (paper-system-stencil system) axis))
58 (define-public (paper-system-staff-extents ps)
59 (ly:prob-property ps 'staff-refpoint-extent '(0 . 0)))
61 (define-public (paper-system-annotate-last system layout)
63 ((bottomspace (ly:prob-property system 'bottom-space))
64 (y-extent (paper-system-extent system Y))
65 (x-extent (paper-system-extent system X))
66 (stencil (ly:prob-property system 'stencil))
68 (arrow (if (number? bottomspace)
69 (annotate-y-interval layout
71 (cons (- (car y-extent) bottomspace)
78 (ly:stencil-add stencil arrow)))
80 (set! (ly:prob-property system 'stencil)
85 ;; Y-ext and next-Y-ext are either skyline-pairs or extents
86 (define*-public (annotate-padding system-Y system-X Y-ext X-ext
87 next-system-Y next-system-X next-Y-ext next-X-ext
88 layout horizon-padding padding #:key (base-color blue))
90 (skyline (and (ly:skyline-pair? Y-ext)
91 (ly:skyline-pair::skyline Y-ext DOWN)))
92 (next-skyline (and (ly:skyline-pair? next-Y-ext)
93 (ly:skyline-pair::skyline next-Y-ext UP)))
95 ((and skyline next-skyline)
97 (ly:skyline::get-touching-point skyline next-skyline horizon-padding)
100 (ly:skyline::get-max-height-position skyline))
102 (ly:skyline::get-max-height-position next-skyline))
106 (annotation-Y (if skyline
107 (ly:skyline::get-height skyline annotation-X)
109 (next-annotation-Y (if next-skyline
110 (- (+ (ly:skyline::get-height next-skyline
111 (- (+ annotation-X system-X)
116 (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps)))
117 (contrast-color (append (cdr base-color) (list (car base-color))))
118 (color (if padding-blocks contrast-color base-color))
119 (annotation (ly:stencil-translate-axis
123 `(,(- annotation-Y padding). ,annotation-Y)
132 (define-public (paper-system-annotate system next-system layout)
133 "Add arrows and texts to indicate which lengths are set."
135 (let* ((grob (ly:prob-property system 'system-grob))
136 (paper-height (ly:output-def-lookup layout 'paper-height))
137 (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
138 (top-margin (ly:output-def-lookup layout 'top-margin))
139 (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '()))
140 (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '()))
141 (spaceable-staff-annotate
142 (lambda (before-staff after-staff)
143 (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
144 (after-Y (ly:grob-relative-coordinate after-staff grob Y)))
145 (annotate-spacing-spec
147 ;; FIXME: Improve `ly:get-spacing-spec' to return the
148 ;; name of the used `XXX-XXX-spacing' property, if
149 ;; possible. Right now we have to use the empty
152 (ly:get-spacing-spec before-staff after-staff)
156 (staff-padding-annotate
157 (lambda (before-staff after-staff)
158 (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
159 (before-X (ly:grob-relative-coordinate before-staff grob X))
160 (before-X-ext (ly:grob-extent before-staff before-staff X))
161 (after-Y (ly:grob-relative-coordinate after-staff grob Y))
162 (after-X (ly:grob-relative-coordinate after-staff grob X))
163 (after-X-ext (ly:grob-extent after-staff after-staff X))
164 (skylines (ly:grob-property before-staff 'vertical-skylines))
165 (after-skylines (ly:grob-property after-staff 'vertical-skylines))
166 (padding (assoc-get 'padding
167 (ly:get-spacing-spec before-staff after-staff)
169 (horizon-padding (ly:grob-property before-staff
170 'skyline-horizontal-padding
172 (ly:stencil-translate
174 before-Y before-X skylines before-X-ext
175 after-Y after-X after-skylines after-X-ext
176 layout horizon-padding padding)
177 (cons before-X before-Y)))))
179 (staff-annotations (if (< 1 (length spaceable-staves))
180 (map spaceable-staff-annotate
181 (drop-right spaceable-staves 1)
182 (drop spaceable-staves 1))
184 (staff-padding-annotations (if (< 1 (length all-staves))
185 (map staff-padding-annotate
186 (drop-right all-staves 1)
189 (estimate-extent (if (ly:grob? grob)
190 (annotate-y-interval layout
192 (ly:grob-property grob 'pure-Y-extent)
196 (spacing-spec-sym (cond ((and next-system
197 (paper-system-title? system)
198 (paper-system-title? next-system))
199 'markup-markup-spacing)
200 ((paper-system-title? system)
201 'markup-system-spacing)
203 (paper-system-title? next-system))
204 'score-markup-spacing)
206 'last-bottom-spacing)
207 ((ly:prob-property system 'last-in-score #f)
208 'score-system-spacing)
210 'system-system-spacing)))
211 (spacing-spec (ly:output-def-lookup layout spacing-spec-sym))
212 (last-staff-Y (car (paper-system-staff-extents system)))
213 (system-Y (ly:prob-property system 'Y-offset 0.0))
214 (system-X (ly:prob-property system 'X-offset 0.0))
215 (next-system-Y (and next-system
216 (ly:prob-property next-system 'Y-offset 0.0)))
217 (next-system-X (and next-system
218 (ly:prob-property next-system 'X-offset 0.0)))
219 (first-staff-next-system-Y (if next-system
220 (- (+ (cdr (paper-system-staff-extents next-system))
223 (+ system-Y top-margin bottom-margin (- paper-height))))
226 (ly:prob-property system 'vertical-skylines #f)
227 (paper-system-extent system Y)))
228 (next-skyline (and next-system
230 (ly:prob-property next-system 'vertical-skylines #f)
231 (paper-system-extent next-system Y))))
232 (horizon-padding (and
234 (ly:grob-property grob 'skyline-horizontal-padding 0)))
235 (padding-annotation (if (skyline-pair-and-non-empty? next-system)
237 (- system-Y) system-X skyline (paper-system-extent system X)
238 (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X)
241 (assoc-get 'padding spacing-spec 0.0)
245 (system-annotation (annotate-spacing-spec
247 (symbol->string spacing-spec-sym)
250 first-staff-next-system-Y))
251 (annotations (ly:stencil-add
253 (stack-stencils Y DOWN 0.0 staff-padding-annotations)
254 (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation))))))
258 (stack-stencils X RIGHT 5.5
262 (if (not (null? annotations))
263 (set! (ly:prob-property system 'stencil)
265 (ly:prob-property system 'stencil)
267 (ly:stencil-expr annotations)
268 (ly:stencil-extent empty-stencil X)
269 (ly:stencil-extent empty-stencil Y)))))
270 (ly:prob-property system 'stencil)))