scm/page.scm

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