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