X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fpaper-system.scm;h=6a391a3a0f41099739022ab74027e33b287e8f66;hb=0b19893c69df343145301d5b639fbeef9bfd5b8e;hp=e72795516e490ba827f1d59dc84aa934ac7b7c1c;hpb=0fa943af67565b567d7f99946b6d3cce9188f830;p=lilypond.git diff --git a/scm/paper-system.scm b/scm/paper-system.scm index e72795516e..6a391a3a0f 100644 --- a/scm/paper-system.scm +++ b/scm/paper-system.scm @@ -17,11 +17,22 @@ (define-public (paper-system-stencil system) (ly:prob-property system '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 'refpoint-Y-extent '(0 . 0))) + (ly:prob-property ps 'staff-refpoint-extent '(0 . 0))) (define-public (paper-system-annotate-last system layout) (let* @@ -46,59 +57,105 @@ stencil) )) -(define-public (paper-system-annotate system layout) +(define-public (paper-system-annotate system next-system layout) "Add arrows and texts to indicate which lengths are set." - (let* - ((annotations (ly:make-stencil '() (cons 0 2) (cons 0 0))) - (append-stencil - (lambda (a b) - (ly:stencil-combine-at-edge a X RIGHT b 0.5 0))) - - (annotate-property - (lambda (name extent is-length?) - (set! annotations - (append-stencil annotations - (annotate-y-interval layout - name extent is-length?))))) + (let* ((annotations (list)) + (annotate-extent-and-space + (lambda (extent-accessor next-space + extent-name next-space-name after-space-name) + (let* ((extent-annotations (list)) + (this-extent (extent-accessor system)) + (next-extent (and next-system (extent-accessor next-system))) + (push-annotation (lambda (stil) + (set! extent-annotations + (cons stil extent-annotations)))) + (color (if (paper-system-title? system) darkblue blue)) + (space-color (if (paper-system-title? system) darkred red))) + (if (and (number-pair? this-extent) + (not (= (interval-start this-extent) + (interval-end this-extent)))) + (push-annotation (annotate-y-interval + layout extent-name this-extent #f + #:color color))) + (if next-system + (push-annotation (annotate-y-interval + layout next-space-name + (interval-translate (cons (- next-space) 0) + (if (number-pair? this-extent) + (interval-start this-extent) + 0)) + #t + #:color color))) + (if (and next-system + (number-pair? this-extent) + (number-pair? next-extent)) + (let ((space-after + (- (+ (ly:prob-property next-system 'Y-offset) + (interval-start this-extent)) + (ly:prob-property system 'Y-offset) + (interval-end next-extent) + next-space))) + (if (> space-after 0.01) + (push-annotation (annotate-y-interval + layout + after-space-name + (interval-translate + (cons (- space-after) 0) + (- (interval-start this-extent) + next-space)) + #t + #:color space-color))))) + (if (not (null? extent-annotations)) + (set! annotations + (stack-stencils X RIGHT 0.5 + (list annotations + (ly:make-stencil '() (cons 0 1) (cons 0 0)) + (apply ly:stencil-add + extent-annotations)))))))) - (bbox-extent (paper-system-extent system Y)) - (refp-extent (ly:prob-property system 'refpoint-Y-extent)) - (next-space (ly:prob-property system 'next-space - (ly:output-def-lookup layout 'betweensystemspace) - )) - (next-padding (ly:prob-property system 'next-padding - (ly:output-def-lookup layout 'betweensystempadding) - )) - - ) - - (if (number-pair? bbox-extent) - (begin - (annotate-property "Y-extent" - bbox-extent #f) - (annotate-property "next-padding" - (interval-translate (cons (- next-padding) 0) (car bbox-extent)) - #t))) - - ;; titles don't have a refpoint-Y-extent. - (if (number-pair? refp-extent) - (begin - (annotate-property "refpoint-Y-extent" - refp-extent #f) - - (annotate-property "next-space" - (interval-translate (cons (- next-space) 0) (car refp-extent)) - #t))) - - - - (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) - ))) - - )) + (grob (ly:prob-property system 'system-grob)) + (estimate-extent (if (ly:grob? grob) + (annotate-y-interval layout + "extent-estimate" + (ly:grob-property grob 'pure-Y-extent) + #f) + #f))) + (let ((next-space (ly:prob-property + system 'next-space + (cond ((and next-system + (paper-system-title? system) + (paper-system-title? next-system)) + (ly:output-def-lookup layout 'between-title-space)) + ((paper-system-title? system) + (ly:output-def-lookup layout 'after-title-space)) + ((and next-system + (paper-system-title? next-system)) + (ly:output-def-lookup layout 'before-title-space)) + (else + (ly:output-def-lookup layout 'between-system-space))))) + (next-padding (ly:prob-property + system 'next-padding + (ly:output-def-lookup layout 'between-system-padding)))) + (annotate-extent-and-space (lambda (sys) + (paper-system-extent sys Y)) + next-padding + "Y-extent" "next-padding" "space after next-padding") + (annotate-extent-and-space paper-system-staff-extents + (+ next-space next-padding) + "staff-refpoint-extent" "next-space+padding" + "space after next-space+padding")) + (if estimate-extent + (set! annotations + (stack-stencils X RIGHT 0.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)))