scm/page.scm

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