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