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-05-28 Nicolas Sceaux <nicolas.sceaux@free.fr>
+
+ * 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 <hanwen@lilypond.org>
* buildscripts/output-distance.py
(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
(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)
(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
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))))))
;; 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))
projects / lilypond.git / commitdiff