scm/layout-page-dump.scm

   1 ;;;; layout-page-tweaks.scm -- page breaking and page layout
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2006 Han-Wen Nienhuys <hanwen@cs.uu.nl>
   6
   7 (define-module (scm layout-page-dump)
   8   #:use-module (srfi srfi-1)
   9   #:use-module (ice-9 pretty-print)
  10   #:use-module (scm paper-system)
  11   #:use-module (scm page)
  12   #:use-module (lily)
  13   #:export (write-page-breaks))
  14
  15
  16 (define (record-tweaks what property-pairs tweaks)
  17   (let ((key (ly:output-def-lookup (ly:grob-layout what)
  18                                    'tweak-key
  19                                    "tweaks"))
  20         (when (ly:grob-property what 'when)))
  21     (if (not (hash-ref tweaks key))
  22         (hash-set! tweaks key '()))
  23     (hash-set! tweaks key
  24                (acons when property-pairs
  25                       (hash-ref tweaks key)))))
  26
  27 (define (graceless-moment mom)
  28   (ly:make-moment (ly:moment-main-numerator mom)
  29                   (ly:moment-main-denominator mom)
  30                   0 0))
  31
  32 (define (moment->skip mom)
  33   (let ((main (if (> (ly:moment-main-numerator mom) 0)
  34                   (format "\\skip 1*~a/~a"
  35                           (ly:moment-main-numerator mom)
  36                           (ly:moment-main-denominator mom))
  37                     ""))
  38         (grace (if (< (ly:moment-grace-numerator mom) 0)
  39                    (format "\\grace { \\skip 1*~a/~a }"
  40                            (- (ly:moment-grace-numerator mom))
  41                            (ly:moment-grace-denominator mom))
  42                    "")))
  43     (format "~a~a" main grace)))
  44
  45 (define (dump-tweaks out-port tweak-list last-moment)
  46   (if (not (null? tweak-list))
  47       (let* ((now (caar tweak-list))
  48              (diff (ly:moment-sub now last-moment))
  49              (these-tweaks (cdar tweak-list))
  50              (skip (moment->skip diff))
  51              (line-break-str (if (assoc-get 'line-break these-tweaks #f)
  52                                  "\\break\n"
  53                                  ""))
  54              (page-break-str (if (assoc-get 'page-break these-tweaks #f)
  55                                  "\\pageBreak\n"
  56                                  ""))
  57              (space-tweaks (format "\\spacingTweaks #'~a\n"
  58                                    (with-output-to-string
  59                                      (lambda ()
  60                                        (pretty-print
  61                                         (assoc-get 'spacing-parameters
  62                                                    these-tweaks '()))))))
  63              (base (format "~a~a~a"
  64                            line-break-str
  65                            page-break-str
  66                            space-tweaks)))
  67         (format out-port "~a\n~a\n" skip base)
  68         (dump-tweaks out-port (cdr tweak-list) (graceless-moment now)))))
  69
  70 (define (dump-all-tweaks pages tweaks)
  71   (let* ((paper (ly:paper-book-paper (page-property  (car pages) 'paper-book)))
  72          (parser (ly:output-def-parser paper))
  73          (name  (format "~a-page-layout.ly"
  74                         (ly:parser-output-name parser)))
  75          (out-port (open-output-file name)))
  76     (ly:progress "Writing page layout to ~a" name)
  77     (hash-for-each
  78      (lambda (key val)
  79        (format out-port "~a = {" key)
  80        (dump-tweaks out-port (reverse val) (ly:make-moment 0 1))
  81        (display "}" out-port))
  82      tweaks)
  83     (close-port out-port)))
  84
  85 (define (write-page-breaks pages)
  86   "Dump page breaks"
  87   (let ((tweaks (make-hash-table 23)))
  88     (define (handle-page page)
  89       (define index 0)
  90       (define music-system-heights
  91         (map-in-order (lambda (sys)
  92                         (* -1 (car (paper-system-extent sys Y))))
  93                       (remove (lambda (sys)
  94                                 (ly:prob-property? sys 'is-title))
  95                               (page-lines page))))
  96       (define (handle-system sys)
  97         (let* ((props `((line-break . #t)
  98                         (spacing-parameters
  99                          . ((system-Y-extent . ,(paper-system-extent sys Y))
 100                             (system-refpoint-Y-extent . ,(paper-system-staff-extents sys))
 101                             (system-index . ,index)
 102                             (music-system-heights . ,music-system-heights)
 103                             (page-system-count . ,(length (page-lines page)))
 104                             (page-printable-height . ,(page-printable-height page))
 105                             (page-space-left . ,(page-property page 'space-left)))))))
 106           (if (equal? (car (page-lines page)) sys)
 107               (set! props (cons '(page-break . #t)
 108                                 props)))
 109           (if (not (ly:prob-property? sys 'is-title))
 110               (record-tweaks (ly:spanner-bound (ly:prob-property sys 'system-grob) LEFT)
 111                             props
 112                             tweaks))
 113           (set! index (1+ index))))
 114       (for-each handle-system (page-lines page)))
 115     (for-each handle-page pages)
 116     (dump-all-tweaks pages tweaks)))