Index: scm/paper-system.scm |
diff --git a/scm/paper-system.scm b/scm/paper-system.scm |
deleted file mode 100644 |
index 83ec918cf40ae5750a3a29ba1dda2e2a8039a926..0000000000000000000000000000000000000000 |
--- a/scm/paper-system.scm |
+++ /dev/null |
@@ -1,270 +0,0 @@ |
-;;;; This file is part of LilyPond, the GNU music typesetter. |
-;;;; |
-;;;; Copyright (C) 2006--2019 Han-Wen Nienhuys <hanwen@xs4all.nl> |
-;;;; |
-;;;; 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 <http://www.gnu.org/licenses/>. |
- |
-(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))) |