From d0dbc0b1be6af21f9f08f53e7782a39c05d21967 Mon Sep 17 00:00:00 2001 From: Nicolas Sceaux Date: Sat, 3 Jun 2006 09:53:24 +0000 Subject: [PATCH] * scm/define-markup-commands.scm (whiteout): do not force foreground color of argument markup to black. * scm/stencil.scm (annotate-y-interval): put arrow dimension at the left of the arrow, instead of below the arrow name, so that, when two little arrows are vertically stacked, their dimensions and name should not overlap. Add a color key parameter. * scm/paper-system.scm (paper-system-annotate): Annotate next-space+next-padding instead of next-space. Annotate space between next-padding and next-space+padding, respectively, and following system extent and refpoint-Y-extent. Use colors. * scm/page.scm (annotate-page): translate annotations slightly to the right. --- ChangeLog | 18 +++++ scm/define-markup-commands.scm | 3 +- scm/page.scm | 26 +++---- scm/paper-system.scm | 126 +++++++++++++++++++++------------ scm/stencil.scm | 74 +++++++++---------- 5 files changed, 144 insertions(+), 103 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0f352fd289..d03acc1600 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,21 @@ +2006-05-28 Nicolas Sceaux + + * scm/define-markup-commands.scm (whiteout): do not force + foreground color of argument markup to black. + + * scm/stencil.scm (annotate-y-interval): put arrow dimension at + the left of the arrow, instead of below the arrow name, so that, + when two little arrows are vertically stacked, their dimensions + and name should not overlap. Add a color key parameter. + + * scm/paper-system.scm (paper-system-annotate): Annotate + next-space+next-padding instead of next-space. Annotate space + between next-padding and next-space+padding, respectively, and + following system extent and refpoint-Y-extent. Use colors. + + * scm/page.scm (annotate-page): translate annotations slightly to + the right. + 2006-06-03 Han-Wen Nienhuys * buildscripts/output-distance.py diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index 1a940b1383..83c5750010 100644 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -126,8 +126,7 @@ circle of diameter 0 (ie sharp corners)." (define-markup-command (whiteout layout props arg) (markup?) "Provide a white underground for @var{arg}" - (let* ((stil (interpret-markup layout props - (make-with-color-markup black arg))) + (let* ((stil (interpret-markup layout props arg)) (white (interpret-markup layout props (make-with-color-markup diff --git a/scm/page.scm b/scm/page.scm index 041edd3a72..23ee840792 100644 --- a/scm/page.scm +++ b/scm/page.scm @@ -85,37 +85,31 @@ (page-property page 'configuration)))) (define (annotate-page layout stencil) - (let* - ((top-margin (ly:output-def-lookup layout 'top-margin)) - (paper-height (ly:output-def-lookup layout 'paper-height)) - (bottom-margin (ly:output-def-lookup layout 'bottom-margin)) - (add-stencil (lambda (y) - (set! stencil - (ly:stencil-add stencil y)) - ))) - + (let ((top-margin (ly:output-def-lookup layout 'top-margin)) + (paper-height (ly:output-def-lookup layout 'paper-height)) + (bottom-margin (ly:output-def-lookup layout 'bottom-margin)) + (add-stencil (lambda (y) + (set! stencil + (ly:stencil-add stencil + (ly:stencil-translate-axis y 6 X)))))) (add-stencil (ly:stencil-translate-axis (annotate-y-interval layout "paper-height" (cons (- paper-height) 0) #t) 1 X)) - - (add-stencil (ly:stencil-translate-axis (annotate-y-interval layout "top-margin" (cons (- top-margin) 0) #t) 2 X)) - (add-stencil (ly:stencil-translate-axis (annotate-y-interval layout "bottom-margin" (cons (- paper-height) (- bottom-margin paper-height)) #t) 2 X)) - stencil)) (define (annotate-space-left page) @@ -324,8 +318,10 @@ create offsets. (ly:output-def-lookup layout 'annotatesystems #f)) (begin - (for-each (lambda (sys) (paper-system-annotate sys layout)) - lines) + (for-each (lambda (sys next-sys) + (paper-system-annotate sys next-sys layout)) + lines + (append (cdr lines) (list #f))) (paper-system-annotate-last (car (last-pair lines)) layout))) (set! page-stencil (ly:stencil-combine-at-edge diff --git a/scm/paper-system.scm b/scm/paper-system.scm index d414285d9d..43711a4ee1 100644 --- a/scm/paper-system.scm +++ b/scm/paper-system.scm @@ -49,57 +49,89 @@ 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?))))) - - (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 'between-system-space) - )) - (next-padding (ly:prob-property system 'next-padding - (ly:output-def-lookup layout 'between-system-padding) - )) - ) - - (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))) - + (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))))))))) + (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) + "refpoint-Y-extent" "next-space+padding" + "space after next-space+padding")) (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:stencil-extent empty-stencil Y)))))) diff --git a/scm/stencil.scm b/scm/stencil.scm index bb919346c8..39f16ea526 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -179,52 +179,48 @@ encloses the contents. ;; spacing variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-public (annotate-y-interval layout name extent is-length) - (let* - ((text-props (cons - '((font-size . -3) - (font-family . typewriter)) - (layout-extract-page-properties layout))) - (annotation #f) - ) - +(define*-public (annotate-y-interval layout name extent is-length + #:key (color darkblue)) + (let ((text-props (cons '((font-size . -3) + (font-family . typewriter)) + (layout-extract-page-properties layout))) + (annotation #f)) + (define (center-stencil-on-extent stil) + (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER) + (cons 0 (interval-center extent)))) ;; do something sensible for 0,0 intervals. (set! extent (interval-widen extent 0.001)) (if (not (interval-sane? extent)) - (set! annotation (interpret-markup layout text-props - (make-simple-markup (format "~a: NaN/inf" name)))) - (let* - ((text-stencil (interpret-markup - layout text-props - (make-column-markup - (list - (make-whiteout-markup (make-simple-markup name)) - (make-whiteout-markup - (make-simple-markup - (cond - ((interval-empty? extent) "empty") - (is-length (format "~$" (interval-length extent))) - (else - (format "(~$,~$)" (car extent) - (cdr extent)))))))))) - (arrows - (ly:stencil-translate-axis - (dimension-arrows (cons 0 (interval-length extent))) - (interval-start extent) Y))) - + (set! annotation (interpret-markup + layout text-props + (make-simple-markup (format "~a: NaN/inf" name)))) + (let ((text-stencil (interpret-markup + layout text-props + (markup #:whiteout #:simple name))) + (dim-stencil (interpret-markup + layout text-props + (markup #:whiteout + #:simple (cond + ((interval-empty? extent) + (format "empty")) + (is-length + (format "~$" (interval-length extent))) + (else + (format "(~$,~$)" + (car extent) (cdr extent))))))) + (arrows (ly:stencil-translate-axis + (dimension-arrows (cons 0 (interval-length extent))) + (interval-start extent) Y))) (set! annotation - (ly:stencil-aligned-to text-stencil Y CENTER)) - - (set! annotation (ly:stencil-translate - annotation - (cons 0 (interval-center extent)))) - - + (center-stencil-on-extent text-stencil)) (set! annotation (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0)) - (set! annotation - (ly:make-stencil (ly:stencil-expr annotation) + (ly:stencil-combine-at-edge annotation X LEFT + (center-stencil-on-extent dim-stencil) + 0.5 0)) + (set! annotation + (ly:make-stencil (list 'color color (ly:stencil-expr annotation)) (ly:stencil-extent annotation X) (cons 10000 -10000))))) annotation)) -- 2.39.2