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