-;;
-;; paper-system.scm -- implement paper-system objects.
-;;
-;; source file of the GNU LilyPond music typesetter
-;;
-;; (c) 2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
-;;
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2006--2015 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))
+(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)
- (ly:prob-property system 'stencil))
+ (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)))
+ (ly:grob-layout g)
+ #f)))
(define-public (paper-system-system-grob paper-system)
(ly:prob-property paper-system 'system-grob))
(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))
+ (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* ((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))))))))
-
- (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"))
+
+ (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 0.5
- (list annotations
- 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)))))
+ (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)))
projects / lilypond.git / blobdiff