scm/paper-system.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2006--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (define-module (scm paper-system))
  19
  20 (use-modules (lily)
  21              (srfi srfi-1)
  22              (ice-9 optargs))
  23
  24 (define-public (paper-system-title? system)
  25   (equal? #t (ly:prob-property system 'is-title)
  26           ))
  27
  28 (define (system-stencil system-grob main-stencil)
  29   (let* ((padding (ly:grob-property system-grob 'in-note-padding #f))
  30          (in-notes (if padding (ly:grob-property system-grob 'in-note-stencil) empty-stencil))
  31          (in-notes (if in-notes in-notes empty-stencil))
  32          (direction (if padding (ly:grob-property system-grob 'in-note-direction) UP)))
  33     (if padding
  34         (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding)
  35         main-stencil)))
  36
  37 (define-public (paper-system-stencil system)
  38   (let ((main-stencil (ly:prob-property system 'stencil))
  39         (system-grob (ly:prob-property system 'system-grob)))
  40     (if (ly:grob? system-grob)
  41         (system-stencil system-grob main-stencil)
  42         main-stencil)))
  43
  44 (define-public (paper-system-layout system)
  45   (let*
  46       ((g (paper-system-system-grob system)))
  47
  48     (if (ly:grob? g)
  49         (ly:grob-layout  g)
  50         #f)))
  51
  52 (define-public (paper-system-system-grob paper-system)
  53   (ly:prob-property paper-system 'system-grob))
  54
  55 (define-public (paper-system-extent system axis)
  56   (ly:stencil-extent (paper-system-stencil system) axis))
  57
  58 (define-public (paper-system-staff-extents ps)
  59   (ly:prob-property ps 'staff-refpoint-extent '(0 . 0)))
  60
  61 (define-public (paper-system-annotate-last system layout)
  62   (let*
  63       ((bottomspace (ly:prob-property system 'bottom-space))
  64        (y-extent (paper-system-extent system Y))
  65        (x-extent (paper-system-extent system X))
  66        (stencil (ly:prob-property system 'stencil))
  67
  68        (arrow (if (number? bottomspace)
  69                   (annotate-y-interval layout
  70                                        "bottom-space"
  71                                        (cons (- (car y-extent) bottomspace)
  72                                              (car y-extent))
  73                                        #t)
  74                   #f)))
  75
  76     (if arrow
  77         (set! stencil
  78               (ly:stencil-add stencil arrow)))
  79
  80     (set! (ly:prob-property system 'stencil)
  81           stencil)
  82     ))
  83
  84
  85 ;; Y-ext and next-Y-ext are either skyline-pairs or extents
  86 (define*-public (annotate-padding system-Y system-X Y-ext X-ext
  87                                   next-system-Y next-system-X next-Y-ext next-X-ext
  88                                   layout horizon-padding padding #:key (base-color blue))
  89   (let* ((eps 0.001)
  90          (skyline (and (ly:skyline-pair? Y-ext)
  91                        (ly:skyline-pair::skyline Y-ext DOWN)))
  92          (next-skyline (and (ly:skyline-pair? next-Y-ext)
  93                             (ly:skyline-pair::skyline next-Y-ext UP)))
  94          (annotation-X (cond
  95                         ((and skyline next-skyline)
  96                          (-
  97                           (ly:skyline::get-touching-point skyline next-skyline horizon-padding)
  98                           horizon-padding))
  99                         (skyline
 100                          (ly:skyline::get-max-height-position skyline))
 101                         (next-skyline
 102                          (ly:skyline::get-max-height-position next-skyline))
 103                         (else
 104                          (max (cdr X-ext)
 105                               (cdr next-X-ext)))))
 106          (annotation-Y (if skyline
 107                            (ly:skyline::get-height skyline annotation-X)
 108                            (car Y-ext)))
 109          (next-annotation-Y (if next-skyline
 110                                 (- (+ (ly:skyline::get-height next-skyline
 111                                                               (- (+ annotation-X system-X)
 112                                                                  next-system-X))
 113                                       next-system-Y)
 114                                    system-Y)
 115                                 (cdr next-Y-ext)))
 116          (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps)))
 117          (contrast-color (append (cdr base-color) (list (car base-color))))
 118          (color (if padding-blocks contrast-color base-color))
 119          (annotation (ly:stencil-translate-axis
 120                       (annotate-y-interval
 121                        layout
 122                        "padding"
 123                        `(,(- annotation-Y padding). ,annotation-Y)
 124                        #t
 125                        #:color color)
 126                       annotation-X X)))
 127     (if (> padding 0.0)
 128         annotation
 129         empty-stencil)))
 130
 131
 132 (define-public (paper-system-annotate system next-system layout)
 133   "Add arrows and texts to indicate which lengths are set."
 134
 135   (let* ((grob (ly:prob-property system 'system-grob))
 136          (paper-height (ly:output-def-lookup layout 'paper-height))
 137          (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
 138          (top-margin (ly:output-def-lookup layout 'top-margin))
 139          (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '()))
 140          (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '()))
 141          (spaceable-staff-annotate
 142           (lambda (before-staff after-staff)
 143             (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
 144                   (after-Y (ly:grob-relative-coordinate after-staff grob Y)))
 145               (annotate-spacing-spec
 146                layout
 147                ;; FIXME: Improve `ly:get-spacing-spec' to return the
 148                ;; name of the used `XXX-XXX-spacing' property, if
 149                ;; possible.  Right now we have to use the empty
 150                ;; string.
 151                ""
 152                (ly:get-spacing-spec before-staff after-staff)
 153                before-Y
 154                after-Y))))
 155
 156          (staff-padding-annotate
 157           (lambda (before-staff after-staff)
 158             (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
 159                   (before-X (ly:grob-relative-coordinate before-staff grob X))
 160                   (before-X-ext (ly:grob-extent before-staff before-staff X))
 161                   (after-Y (ly:grob-relative-coordinate after-staff grob Y))
 162                   (after-X (ly:grob-relative-coordinate after-staff grob X))
 163                   (after-X-ext (ly:grob-extent after-staff after-staff X))
 164                   (skylines (ly:grob-property before-staff 'vertical-skylines))
 165                   (after-skylines (ly:grob-property after-staff 'vertical-skylines))
 166                   (padding (assoc-get 'padding
 167                                       (ly:get-spacing-spec before-staff after-staff)
 168                                       0.0))
 169                   (horizon-padding (ly:grob-property before-staff
 170                                                      'skyline-horizontal-padding
 171                                                      0.0)))
 172               (ly:stencil-translate
 173                (annotate-padding
 174                 before-Y before-X skylines before-X-ext
 175                 after-Y after-X after-skylines after-X-ext
 176                 layout horizon-padding padding)
 177                (cons before-X before-Y)))))
 178
 179          (staff-annotations (if (< 1 (length spaceable-staves))
 180                                 (map spaceable-staff-annotate
 181                                      (drop-right spaceable-staves 1)
 182                                      (drop spaceable-staves 1))
 183                                 '()))
 184          (staff-padding-annotations (if (< 1 (length all-staves))
 185                                         (map staff-padding-annotate
 186                                              (drop-right all-staves 1)
 187                                              (drop all-staves 1))
 188                                         '()))
 189          (estimate-extent (if (ly:grob? grob)
 190                               (annotate-y-interval layout
 191                                                    "extent-estimate"
 192                                                    (ly:grob-property grob 'pure-Y-extent)
 193                                                    #f)
 194                               #f))
 195
 196          (spacing-spec-sym (cond ((and next-system
 197                                        (paper-system-title? system)
 198                                        (paper-system-title? next-system))
 199                                   'markup-markup-spacing)
 200                                  ((paper-system-title? system)
 201                                   'markup-system-spacing)
 202                                  ((and next-system
 203                                        (paper-system-title? next-system))
 204                                   'score-markup-spacing)
 205                                  ((not next-system)
 206                                   'last-bottom-spacing)
 207                                  ((ly:prob-property system 'last-in-score #f)
 208                                   'score-system-spacing)
 209                                  (else
 210                                   'system-system-spacing)))
 211          (spacing-spec (ly:output-def-lookup layout spacing-spec-sym))
 212          (last-staff-Y (car (paper-system-staff-extents system)))
 213          (system-Y (ly:prob-property system 'Y-offset 0.0))
 214          (system-X (ly:prob-property system 'X-offset 0.0))
 215          (next-system-Y (and next-system
 216                              (ly:prob-property next-system 'Y-offset 0.0)))
 217          (next-system-X (and next-system
 218                              (ly:prob-property next-system 'X-offset 0.0)))
 219          (first-staff-next-system-Y (if next-system
 220                                         (- (+ (cdr (paper-system-staff-extents next-system))
 221                                               system-Y)
 222                                            next-system-Y)
 223                                         (+ system-Y top-margin bottom-margin (- paper-height))))
 224
 225          (skyline (or
 226                    (ly:prob-property system 'vertical-skylines #f)
 227                    (paper-system-extent system Y)))
 228          (next-skyline (and next-system
 229                             (or
 230                              (ly:prob-property next-system 'vertical-skylines #f)
 231                              (paper-system-extent next-system Y))))
 232          (horizon-padding (and
 233                            (ly:grob? grob)
 234                            (ly:grob-property grob 'skyline-horizontal-padding 0)))
 235          (padding-annotation (if (skyline-pair-and-non-empty? next-system)
 236                                  (annotate-padding
 237                                   (- system-Y) system-X skyline (paper-system-extent system X)
 238                                   (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X)
 239                                   layout
 240                                   horizon-padding
 241                                   (assoc-get 'padding spacing-spec 0.0)
 242                                   #:base-color blue)
 243                                  empty-stencil))
 244
 245          (system-annotation (annotate-spacing-spec
 246                              layout
 247                              (symbol->string spacing-spec-sym)
 248                              spacing-spec
 249                              last-staff-Y
 250                              first-staff-next-system-Y))
 251          (annotations (ly:stencil-add
 252                        padding-annotation
 253                        (stack-stencils Y DOWN 0.0 staff-padding-annotations)
 254                        (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation))))))
 255
 256     (if estimate-extent
 257         (set! annotations
 258               (stack-stencils X RIGHT 5.5
 259                               (list annotations
 260                                     estimate-extent))))
 261
 262     (if (not (null? annotations))
 263         (set! (ly:prob-property system 'stencil)
 264               (ly:stencil-add
 265                (ly:prob-property system 'stencil)
 266                (ly:make-stencil
 267                 (ly:stencil-expr annotations)
 268                 (ly:stencil-extent empty-stencil X)
 269                 (ly:stencil-extent empty-stencil Y)))))
 270     (ly:prob-property system 'stencil)))