X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fpaper-system.scm;h=9b8d97f34d4af9a2cede2df9e0e508ed36121701;hb=b872748c6aa8bb721ced458691b38ac2fac5dfc8;hp=8269c77e1881e01cc6df806573ecaaa88ebe1226;hpb=0d1e65a22f4689d6f497243cf65df1a8d3fc8561;p=lilypond.git diff --git a/scm/paper-system.scm b/scm/paper-system.scm index 8269c77e18..9b8d97f34d 100644 --- a/scm/paper-system.scm +++ b/scm/paper-system.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2006--2012 Han-Wen Nienhuys +;;;; 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 @@ -18,12 +18,12 @@ (define-module (scm paper-system)) (use-modules (lily) - (srfi srfi-1) - (ice-9 optargs)) + (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)) @@ -31,8 +31,8 @@ (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))) + (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)) @@ -46,8 +46,8 @@ ((g (paper-system-system-grob system))) (if (ly:grob? g) - (ly:grob-layout g) - #f))) + (ly:grob-layout g) + #f))) (define-public (paper-system-system-grob paper-system) (ly:prob-property paper-system 'system-grob)) @@ -64,199 +64,207 @@ (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))) - + (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! stencil + (ly:stencil-add stencil arrow))) (set! (ly:prob-property system 'stencil) - 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)) + 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))) + (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))) + 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 - (ly:get-spacing-spec before-staff after-staff) - before-Y - after-Y)))) + (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-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)) + (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 (cond ((and next-system - (paper-system-title? system) - (paper-system-title? next-system)) - (ly:output-def-lookup layout 'markup-markup-spacing)) - ((paper-system-title? system) - (ly:output-def-lookup layout 'markup-system-spacing)) - ((and next-system - (paper-system-title? next-system)) - (ly:output-def-lookup layout 'score-markup-spacing)) - ((not next-system) - (ly:output-def-lookup layout 'last-bottom-spacing)) - ((ly:prob-property system 'last-in-score #f) - (ly:output-def-lookup layout 'score-system-spacing)) - (else - (ly:output-def-lookup layout 'system-system-spacing)))) - (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)))) + (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)) + (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 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)))))) + (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 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))) + (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)))