scm/paper-system.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2006--2011 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-public (paper-system-stencil system)
  29   (ly:prob-property system 'stencil))
  30
  31 (define-public (paper-system-layout system)
  32   (let*
  33       ((g (paper-system-system-grob system)))
  34
  35     (if (ly:grob? g)
  36         (ly:grob-layout  g)
  37         #f)))
  38
  39 (define-public (paper-system-system-grob paper-system)
  40   (ly:prob-property paper-system 'system-grob))
  41
  42 (define-public (paper-system-extent system axis)
  43   (ly:stencil-extent (paper-system-stencil system) axis))
  44
  45 (define-public (paper-system-staff-extents ps)
  46   (ly:prob-property ps 'staff-refpoint-extent '(0 . 0)))
  47
  48 (define-public (paper-system-annotate-last system layout)
  49   (let*
  50       ((bottomspace (ly:prob-property system 'bottom-space))
  51        (y-extent (paper-system-extent system Y))
  52        (x-extent (paper-system-extent system X))
  53        (stencil (ly:prob-property system 'stencil))
  54
  55        (arrow (if (number? bottomspace)
  56                (annotate-y-interval layout
  57                                     "bottom-space"
  58                                     (cons (- (car y-extent) bottomspace)
  59                                           (car y-extent))
  60                                     #t)
  61                #f)))
  62
  63     (if arrow
  64         (set! stencil
  65               (ly:stencil-add stencil arrow)))
  66
  67     (set! (ly:prob-property system 'stencil)
  68           stencil)
  69   ))
  70
  71
  72 ;; Y-ext and next-Y-ext are either skyline-pairs or extents
  73 (define*-public (annotate-padding system-Y system-X Y-ext X-ext
  74                                   next-system-Y next-system-X next-Y-ext next-X-ext
  75                                   layout horizon-padding padding #:key (base-color blue))
  76   (let* ((eps 0.001)
  77          (skyline (and (ly:skyline-pair? Y-ext)
  78                        (ly:skyline-pair::skyline Y-ext DOWN)))
  79          (next-skyline (and (ly:skyline-pair? next-Y-ext)
  80                             (ly:skyline-pair::skyline next-Y-ext UP)))
  81          (annotation-X (cond
  82                         ((and skyline next-skyline)
  83                          (-
  84                           (ly:skyline::get-touching-point skyline next-skyline horizon-padding)
  85                           horizon-padding))
  86                         (skyline
  87                          (ly:skyline::get-max-height-position skyline))
  88                         (next-skyline
  89                          (ly:skyline::get-max-height-position next-skyline))
  90                         (else
  91                          (max (cdr X-ext)
  92                               (cdr next-X-ext)))))
  93          (annotation-Y (if skyline
  94                            (ly:skyline::get-height skyline annotation-X)
  95                            (car Y-ext)))
  96          (next-annotation-Y (if next-skyline
  97                                 (- (+ (ly:skyline::get-height next-skyline
  98                                                               (- (+ annotation-X system-X)
  99                                                                  next-system-X))
 100                                       next-system-Y)
 101                                    system-Y)
 102                                 (cdr next-Y-ext)))
 103          (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps)))
 104          (contrast-color (append (cdr base-color) (list (car base-color))))
 105          (color (if padding-blocks contrast-color base-color))
 106          (annotation (ly:stencil-translate-axis
 107                       (annotate-y-interval
 108                        layout
 109                        "padding"
 110                        `(,(- annotation-Y padding). ,annotation-Y)
 111                        #t
 112                        #:color color)
 113                       annotation-X X)))
 114     (if (> padding 0.0)
 115         annotation
 116         empty-stencil)))
 117
 118
 119 (define-public (paper-system-annotate system next-system layout)
 120   "Add arrows and texts to indicate which lengths are set."
 121
 122   (let* ((grob (ly:prob-property system 'system-grob))
 123          (paper-height (ly:output-def-lookup layout 'paper-height))
 124          (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
 125          (top-margin (ly:output-def-lookup layout 'top-margin))
 126          (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '()))
 127          (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '()))
 128          (spaceable-staff-annotate
 129           (lambda (before-staff after-staff)
 130             (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
 131                   (after-Y (ly:grob-relative-coordinate after-staff grob Y)))
 132               (annotate-spacing-spec
 133                layout
 134                (ly:get-spacing-spec before-staff after-staff)
 135                before-Y
 136                after-Y))))
 137
 138          (staff-padding-annotate
 139           (lambda (before-staff after-staff)
 140             (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
 141                   (before-X (ly:grob-relative-coordinate before-staff grob X))
 142                   (before-X-ext (ly:grob-extent before-staff before-staff X))
 143                   (after-Y (ly:grob-relative-coordinate after-staff grob Y))
 144                   (after-X (ly:grob-relative-coordinate after-staff grob X))
 145                   (after-X-ext (ly:grob-extent after-staff after-staff X))
 146                   (skylines (ly:grob-property before-staff 'vertical-skylines))
 147                   (after-skylines (ly:grob-property after-staff 'vertical-skylines))
 148                   (padding (assoc-get 'padding
 149                                       (ly:get-spacing-spec before-staff after-staff)
 150                                       0.0))
 151                   (horizon-padding (ly:grob-property before-staff
 152                                                      'skyline-horizontal-padding
 153                                                      0.0)))
 154               (ly:stencil-translate
 155                (annotate-padding
 156                 before-Y before-X skylines before-X-ext
 157                 after-Y after-X after-skylines after-X-ext
 158                 layout horizon-padding padding)
 159                (cons before-X before-Y)))))
 160
 161          (staff-annotations (if (< 1 (length spaceable-staves))
 162                                 (map spaceable-staff-annotate
 163                                      (drop-right spaceable-staves 1)
 164                                      (drop spaceable-staves 1))
 165                                 '()))
 166          (staff-padding-annotations (if (< 1 (length all-staves))
 167                                         (map staff-padding-annotate
 168                                              (drop-right all-staves 1)
 169                                              (drop all-staves 1))
 170                                         '()))
 171          (estimate-extent (if (ly:grob? grob)
 172                               (annotate-y-interval layout
 173                                                    "extent-estimate"
 174                                                    (ly:grob-property grob 'pure-Y-extent)
 175                                                    #f)
 176                               #f))
 177
 178          (spacing-spec (cond ((and next-system
 179                                    (paper-system-title? system)
 180                                    (paper-system-title? next-system))
 181                               (ly:output-def-lookup layout 'markup-markup-spacing))
 182                              ((paper-system-title? system)
 183                               (ly:output-def-lookup layout 'markup-system-spacing))
 184                              ((and next-system
 185                                    (paper-system-title? next-system))
 186                               (ly:output-def-lookup layout 'score-markup-spacing))
 187                              ((not next-system)
 188                               (ly:output-def-lookup layout 'last-bottom-spacing))
 189                              ((ly:prob-property system 'last-in-score #f)
 190                               (ly:output-def-lookup layout 'score-system-spacing))
 191                              (else
 192                               (ly:output-def-lookup layout 'system-system-spacing))))
 193          (last-staff-Y (car (paper-system-staff-extents system)))
 194          (system-Y (ly:prob-property system 'Y-offset 0.0))
 195          (system-X (ly:prob-property system 'X-offset 0.0))
 196          (next-system-Y (and next-system
 197                              (ly:prob-property next-system 'Y-offset 0.0)))
 198          (next-system-X (and next-system
 199                              (ly:prob-property next-system 'X-offset 0.0)))
 200          (first-staff-next-system-Y (if next-system
 201                                         (- (+ (cdr (paper-system-staff-extents next-system))
 202                                               system-Y)
 203                                            next-system-Y)
 204                                         (+ system-Y top-margin bottom-margin (- paper-height))))
 205
 206          (skyline (or
 207                    (ly:prob-property system 'vertical-skylines #f)
 208                    (paper-system-extent system Y)))
 209          (next-skyline (and next-system
 210                             (or
 211                              (ly:prob-property next-system 'vertical-skylines #f)
 212                              (paper-system-extent next-system Y))))
 213          (horizon-padding (and
 214                            (ly:grob? grob)
 215                            (ly:grob-property grob 'skyline-horizontal-padding 0)))
 216          (padding-annotation (if next-system
 217                                  (annotate-padding
 218                                    (- system-Y) system-X skyline (paper-system-extent system X)
 219                                    (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X)
 220                                    layout
 221                                    horizon-padding
 222                                    (assoc-get 'padding spacing-spec 0.0)
 223                                    #:base-color blue)
 224                                  empty-stencil))
 225
 226          (system-annotation (annotate-spacing-spec
 227                              layout spacing-spec
 228                              last-staff-Y
 229                              first-staff-next-system-Y))
 230          (annotations (ly:stencil-add
 231                        padding-annotation
 232                        (stack-stencils Y DOWN 0.0 staff-padding-annotations)
 233                        (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation))))))
 234
 235      (if estimate-extent
 236         (set! annotations
 237               (stack-stencils X RIGHT 5.5
 238                               (list annotations
 239                                     estimate-extent))))
 240
 241      (if (not (null? annotations))
 242          (set! (ly:prob-property system 'stencil)
 243                (ly:stencil-add
 244                 (ly:prob-property system 'stencil)
 245                 (ly:make-stencil
 246                  (ly:stencil-expr annotations)
 247                  (ly:stencil-extent empty-stencil X)
 248                  (ly:stencil-extent empty-stencil Y)))))
 249      (ly:prob-property system 'stencil)))