scm/page.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 page)
  19
  20   #:export (make-page
  21             page-property
  22             page-set-property!
  23             page-prev
  24             page-printable-height
  25             layout->page-init
  26             page-force
  27             page-penalty
  28             page-configuration
  29             page-lines
  30             page-page-number
  31             page-system-numbers
  32             page-stencil
  33             page-free-height
  34             page?
  35             ))
  36
  37 (use-modules (lily)
  38              (scm paper-system)
  39              (srfi srfi-1))
  40
  41
  42 (define (annotate? layout)
  43   (eq? #t (ly:output-def-lookup layout 'annotate-spacing)))
  44
  45
  46 (define page-module (current-module))
  47
  48 (define (make-page paper-book  . args)
  49   (let*
  50       ((p (apply ly:make-prob (append
  51                                (list 'page (layout->page-init (ly:paper-book-paper paper-book))
  52                                      'paper-book paper-book)
  53                                args))))
  54
  55     (page-set-property! p 'head-stencil (page-header p))
  56     (page-set-property! p 'foot-stencil (page-footer p))
  57
  58     p))
  59
  60 (define page-property ly:prob-property)
  61 (define page-set-property! ly:prob-set-property!)
  62 (define (page-property? page sym)
  63   (eq? #t (page-property page sym)))
  64 (define (page? x)  (ly:prob-type? x 'page))
  65
  66
  67 ;; define accessors.
  68 (for-each
  69  (lambda (j)
  70    (module-define!
  71     page-module
  72     (string->symbol (format #f "page-~a" j))
  73     (lambda (pg)
  74       (page-property pg j))))
  75
  76  '(page-number prev lines force penalty lines))
  77
  78 (define (page-system-numbers page)
  79   (map (lambda (ps) (ly:prob-property ps 'number))
  80        (page-lines page)))
  81
  82 (define (page-translate-systems page)
  83   (for-each
  84
  85    (lambda (sys off)
  86      (if (not (number? (ly:prob-property sys 'Y-offset)))
  87          (ly:prob-set-property! sys 'Y-offset off)))
  88
  89    (page-property page 'lines)
  90    (page-property page 'configuration)))
  91
  92 (define (annotate-top-space first-system layout header-stencil stencil)
  93   (let* ((top-margin (ly:output-def-lookup layout 'top-margin))
  94          (sym (if (paper-system-title? first-system)
  95                   'top-markup-spacing
  96                   'top-system-spacing))
  97          (spacing-spec (ly:output-def-lookup layout sym))
  98          (X-offset (ly:prob-property first-system 'X-offset 5))
  99          (header-extent (ly:stencil-extent header-stencil Y)))
 100
 101     (set! stencil
 102           (ly:stencil-add stencil
 103                           (ly:stencil-translate-axis
 104                            (annotate-spacing-spec layout
 105                                                   (symbol->string sym)
 106                                                   spacing-spec
 107                                                   (- top-margin)
 108                                                   (car header-extent)
 109                                                   #:base-color red)
 110                            X-offset X)))
 111     stencil))
 112
 113
 114 (define (annotate-page layout stencil)
 115   (let ((top-margin (ly:output-def-lookup layout 'top-margin))
 116         (paper-height (ly:output-def-lookup layout 'paper-height))
 117         (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
 118         (add-stencil (lambda (y)
 119                        (set! stencil
 120                              (ly:stencil-add stencil
 121                                              (ly:stencil-translate-axis y 6 X))))))
 122     (add-stencil
 123      (ly:stencil-translate-axis
 124       (annotate-y-interval layout "paper-height"
 125                            (cons (- paper-height) 0)
 126                            #t)
 127       1 X))
 128     (add-stencil
 129      (ly:stencil-translate-axis
 130       (annotate-y-interval layout "top-margin"
 131                            (cons (- top-margin) 0)
 132                            #t)
 133       2 X))
 134     (add-stencil
 135      (ly:stencil-translate-axis
 136       (annotate-y-interval layout "bottom-margin"
 137                            (cons (- paper-height) (- bottom-margin paper-height))
 138                            #t)
 139       2 X))
 140     stencil))
 141
 142 (define (annotate-space-left page)
 143   (let*
 144       ((paper-book (page-property page 'paper-book))
 145        (layout (ly:paper-book-paper paper-book))
 146        (arrow (annotate-y-interval layout
 147                                    "space left"
 148                                    (cons (- 0.0
 149                                             (page-property page 'bottom-edge)
 150                                             (let ((foot (page-property page 'foot-stencil)))
 151                                               (if (and (ly:stencil? foot)
 152                                                        (not (ly:stencil-empty? foot)))
 153                                                   (car (ly:stencil-extent foot Y))
 154                                                   0.0)))
 155                                          (page-property page  'bottom-system-edge))
 156                                    #t)))
 157
 158     (set! arrow (ly:stencil-translate-axis arrow 8 X))
 159
 160     arrow))
 161
 162
 163 (define (page-header-or-footer page dir)
 164   (let*
 165       ((paper-book (page-property page 'paper-book))
 166        (layout (ly:paper-book-paper paper-book))
 167        (scopes (ly:paper-book-scopes paper-book))
 168        (number (page-page-number page))
 169        (is-last-bookpart (page-property page 'is-last-bookpart))
 170        (is-bookpart-last-page (page-property page 'is-bookpart-last-page))
 171        (sym (if (= dir UP)
 172                 'make-header
 173                 'make-footer))
 174        (header-proc (ly:output-def-lookup layout sym)))
 175
 176     (if (procedure? header-proc)
 177         (header-proc layout scopes number is-last-bookpart is-bookpart-last-page)
 178         #f)))
 179
 180
 181 (define (page-header page)
 182   (page-header-or-footer page UP))
 183
 184 (define (page-footer page)
 185   (page-header-or-footer page DOWN))
 186
 187 (define (layout->page-init layout)
 188   "Alist of settings for page layout"
 189   (let*
 190       ((paper-height (ly:output-def-lookup layout 'paper-height))
 191        (paper-width (ly:output-def-lookup layout 'paper-width))
 192        (left-margin (ly:output-def-lookup layout 'left-margin))
 193        (right-margin (ly:output-def-lookup layout 'right-margin))
 194        (bottom-edge (- paper-height
 195                        (ly:output-def-lookup layout 'bottom-margin)) )
 196        (top-margin (ly:output-def-lookup layout 'top-margin))
 197        )
 198
 199     `((paper-height . ,paper-height)
 200       (paper-width . ,paper-width)
 201       (left-margin . ,left-margin)
 202       (right-margin . ,right-margin)
 203       (top-margin . ,top-margin)
 204       (bottom-edge . ,bottom-edge)
 205       )))
 206
 207 (define (make-page-stencil page)
 208   "Construct a stencil representing the page from PAGE."
 209
 210
 211   (page-translate-systems page)
 212   (let*
 213       ((paper-book (page-property page 'paper-book))
 214        (prop (lambda (sym) (page-property page sym)))
 215        (layout (ly:paper-book-paper paper-book))
 216        (scopes (ly:paper-book-scopes paper-book))
 217        (lines (page-lines page))
 218        (number (page-page-number page))
 219
 220        ;; TODO: naming paper-height/paper-width not analogous to TeX.
 221
 222        (system-xoffset (ly:output-def-lookup layout 'horizontal-shift 0.0))
 223        (system-separator-markup (ly:output-def-lookup layout 'system-separator-markup))
 224        (system-separator-stencil (if (markup? system-separator-markup)
 225                                      (interpret-markup layout
 226                                                        (layout-extract-page-properties layout)
 227                                                        system-separator-markup)
 228                                      #f))
 229
 230        (page-stencil empty-stencil)
 231
 232        (last-system #f)
 233        (last-y 0.0)
 234        (add-to-page (lambda (stencil x y)
 235                       (set! page-stencil
 236                             (ly:stencil-add page-stencil
 237                                             (ly:stencil-translate stencil
 238                                                                   (cons
 239                                                                    (+ system-xoffset x)
 240                                                                    (- 0 y (prop 'top-margin)))
 241
 242                                                                   )))))
 243        (add-system
 244         (lambda (system)
 245           (let* ((stencil (paper-system-stencil system))
 246                  (extra-offset (ly:prob-property system 'extra-offset '(0 . 0)))
 247                  (x (+ (ly:prob-property system 'X-offset 0.0)
 248                        (car extra-offset)))
 249                  (y (+ (ly:prob-property system 'Y-offset 0.0)
 250                        (cdr extra-offset)))
 251                  (is-title (paper-system-title?
 252                             system)))
 253             (add-to-page stencil x y)
 254             (if (and (ly:stencil? system-separator-stencil)
 255                      last-system
 256                      (not (paper-system-title? system))
 257                      (not (paper-system-title? last-system)))
 258                 (add-to-page
 259                  system-separator-stencil
 260                  0
 261                  (average (- last-y
 262                              (car (paper-system-staff-extents last-system)))
 263                           (- y
 264                              (cdr (paper-system-staff-extents system))))))
 265             (set! last-system system)
 266             (set! last-y y))))
 267        (head (prop 'head-stencil))
 268        (foot (prop 'foot-stencil))
 269        )
 270
 271     (if (and
 272          (ly:stencil? head)
 273          (not (ly:stencil-empty? head)))
 274         (begin
 275           ;; Ensure that the top of the header just touches the top margin.
 276           (set! head (ly:stencil-translate-axis head
 277                                                 (- 0 (cdr (ly:stencil-extent head Y)) (prop 'top-margin)) Y))
 278           (set! page-stencil (ly:stencil-add page-stencil head))))
 279
 280     (if (and
 281          (annotate? layout)
 282          (pair? lines))
 283
 284         (begin
 285           (set! page-stencil (annotate-top-space (car lines) layout head page-stencil))
 286
 287           (for-each (lambda (sys next-sys)
 288                       (paper-system-annotate sys next-sys layout))
 289                     lines
 290                     (append (cdr lines) (list #f)))
 291           (paper-system-annotate-last (car (last-pair lines)) layout)))
 292
 293     (for-each add-system lines)
 294
 295
 296     (ly:prob-set-property! page 'bottom-system-edge
 297                            (car (ly:stencil-extent page-stencil Y)))
 298     (ly:prob-set-property! page 'space-left
 299                            (+ (prop 'bottom-edge)
 300                               (prop 'bottom-system-edge)
 301                               (if (and (ly:stencil? foot)
 302                                        (not (ly:stencil-empty? foot)))
 303                                   (car (ly:stencil-extent foot Y))
 304                                   0.0)))
 305
 306     (if (annotate? layout)
 307         (set! page-stencil
 308               (ly:stencil-add page-stencil
 309                               (annotate-space-left page))))
 310
 311     (if (and (ly:stencil? foot)
 312              (not (ly:stencil-empty? foot)))
 313         (set! page-stencil
 314               (ly:stencil-add
 315                page-stencil
 316                (ly:stencil-translate
 317                 foot
 318                 (cons 0
 319                       (+ (- (prop 'bottom-edge))
 320                          (- (car (ly:stencil-extent foot Y)))))))))
 321
 322     (if (ly:output-def-lookup layout 'two-sided #f)
 323         (set! page-stencil
 324               (ly:stencil-translate page-stencil
 325                                     (cons (prop (if (even? number)
 326                                                     'left-margin
 327                                                     'right-margin))
 328                                           0)))
 329         (set! page-stencil
 330               (ly:stencil-translate page-stencil (cons (prop 'left-margin) 0))))
 331
 332     ;; annotation.
 333     (if (annotate? layout)
 334         (set! page-stencil (annotate-page layout page-stencil)))
 335
 336     page-stencil))
 337
 338
 339 (define-public (page-stencil page)
 340   (if (not (ly:stencil? (page-property page 'stencil)))
 341
 342       ;; todo: make tweakable.
 343       ;; via property + callbacks.
 344
 345       (page-set-property! page 'stencil (make-page-stencil page)))
 346   (page-property page 'stencil))
 347
 348 (define (calc-printable-height page)
 349   "Printable area for music and titles; matches default-page-make-stencil."
 350   (let*
 351       ((paper-book (page-property page 'paper-book))
 352        (layout (ly:paper-book-paper paper-book))
 353        (h (- (ly:output-def-lookup layout 'paper-height)
 354              (ly:output-def-lookup layout 'top-margin)
 355              (ly:output-def-lookup layout 'bottom-margin)))
 356
 357        (head (page-property page 'head-stencil))
 358        (foot (page-property page 'foot-stencil))
 359        (available
 360         (- h (if (ly:stencil? head)
 361                  (interval-length (ly:stencil-extent head Y))
 362                  0)
 363            (if (ly:stencil? foot)
 364                (interval-length (ly:stencil-extent foot Y))
 365                0))))
 366
 367     ;; (display (list "\n available" available head foot))
 368     available))
 369
 370 (define (page-printable-height page)
 371   (if (not (number? (page-property page 'printable-height)))
 372       (page-set-property! page 'printable-height (calc-printable-height page)))
 373
 374   (page-property page 'printable-height))