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