scm/page-layout.scm

   1 ;;;; page-layout.scm -- page layout functions
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7
   8 (define-public (page-properties paper)
   9   (list (append `((linewidth . ,(ly:paper-get-number
  10                                  paper 'linewidth)))
  11                 (ly:output-def-lookup paper 'text-font-defaults))))
  12
  13 (define-public (plain-header paper page-number)
  14   (let ((props (page-properties paper) ))
  15     (interpret-markup paper props
  16                       (markup #:fill-line
  17                               ("" #:bold (number->string page-number))))))
  18
  19 (define-public (plain-footer paper page-number)
  20   (let ((props (page-properties paper)))
  21
  22     (interpret-markup paper props
  23                       (markup #:fill-line ("" (number->string page-number))))))
  24
  25
  26 (define TAGLINE
  27   (string-append "Engraved by LilyPond (version " (lilypond-version) ")"))
  28
  29 (define-public (TAGLINE-or-tagline-from-header paper scopes)
  30   (let* ((props (page-properties paper))
  31          (tagline-var (ly:modules-lookup scopes 'tagline))
  32          (tagline (if (markup? tagline-var) tagline-var TAGLINE)))
  33
  34     (cond ((string? tagline)
  35            (if (not (equal? tagline ""))
  36                (interpret-markup paper props
  37                                  (markup #:fill-line (tagline "")))))
  38           ((markup? tagline) (interpret-markup paper props tagline)))))
  39
  40 (define-public (copyright-from-header paper scopes)
  41   (let ((props (page-properties paper))
  42         (copyright (ly:modules-lookup scopes 'copyright)))
  43
  44     (cond ((string? copyright)
  45            (if (not (equal? copyright ""))
  46                (interpret-markup paper props
  47                                  (markup #:fill-line (copyright "")))))
  48           ((markup? copyright) (interpret-markup paper props copyright)))))
  49
  50
  51 ;;; optimal page breaking
  52
  53 ;;; This is not optimal page breaking, this is optimal distribution of
  54 ;;; lines over pages; line breaks are a given.
  55
  56 ;;; TODO:
  57 ;;;    - user tweaking:
  58 ;;;       + \pagebreak, \nopagebreak
  59 ;;;       + #pages?
  60 ;;;    - short circut SCORE=-1 (dismiss path)
  61 ;;;    - density scoring
  62
  63
  64 (use-modules (oop goops describe))
  65
  66 (define-class <break-node> ()
  67   (prev #:init-value '() #:accessor node-prev #:init-keyword #:prev)
  68   (line #:init-value 'barf #:accessor node-line #:init-keyword #:line)
  69   (page #:init-value 0 #:accessor node-page #:init-keyword #:page)
  70   (score #:init-value 0 #:accessor node-score #:init-keyword #:score)
  71   (height #:init-value 0 #:accessor node-height #:init-keyword #:height))
  72
  73 (define INFINITY 1e9)
  74
  75 (define (robust-paper-line-number line)
  76   (if (null? line) 0
  77       (ly:paper-line-number line)))
  78
  79 (define (robust-line-height line)
  80   (if (null? line) 0
  81       (ly:paper-line-extent line Y)))
  82
  83 (define (robust-line-number node)
  84   (if (null? node) 0
  85       (robust-paper-line-number (node-line node))))
  86
  87 (define (robust-break-score node)
  88   (let ((line (node-line node)))
  89     (if (null? line) 0
  90         (ly:paper-line-break-score line))))
  91
  92 (define (make-node prev line page score . height)
  93   (make <break-node> #:prev prev #:line line #:page page #:score score
  94         #:height (if (null? height) 0 (car height))))
  95
  96 ;; max density %
  97 (define MAX-CRAMP 0.05)
  98
  99 (define-public (ly:optimal-page-breaks lines
 100                                        paper-book
 101                                        text-height
 102                                        first-diff last-diff)
 103   "DOCME"
 104   ;; FIXME: may need some tweaking: square, cubic
 105   (define (height-score available used)
 106     (let* ((empty (- available used))
 107            (norm-empty (* empty (/ 100 available))))
 108       (if (< norm-empty 0)
 109           (if (> (* -1 (/ empty available)) MAX-CRAMP)
 110               ;; cannot fill more than MAX-CRAMP
 111               -1
 112               ;; overfull page is still worse by a power
 113               ;; -- which means it never happens
 114               ;; let's try a factor 2
 115               ;;(* -1 norm-empty norm-empty norm-empty))
 116               (* 2 norm-empty norm-empty))
 117           (* norm-empty norm-empty))))
 118
 119   (define (page-height page-number page-count)
 120     (let ((h text-height))
 121       (if (= page-number 1)
 122           (set! h (+ h first-diff)))
 123       (if (= page-number page-count)
 124        (set! h (+ h last-diff)))
 125       h))
 126
 127   (define (cumulative-height lines)
 128     (apply + (map robust-line-height lines)))
 129
 130   (define (get-path node)
 131     (if (null? node) '() (cons node (get-path (node-prev node)))))
 132
 133   (define (add-scores . lst)
 134     (if (null? (filter (lambda (x) (> 0 x)) lst)) (apply + lst) -1))
 135
 136   (define (density-variance nodes)
 137     (define (sqr x) (* x x))
 138     (define (density node)
 139       (let ((p (page-height (node-page node) (node-page (car nodes))))
 140             (h (node-height node)))
 141         (if (and p h) (/ h p) 0)))
 142
 143     (let* ((height-nodes (reverse
 144                           ;; reverse makes for handier debugging
 145                           (filter (lambda (x) (> (node-height x) 0)) nodes)))
 146            (densities (map density height-nodes))
 147            (p-heights (map (lambda (x) (page-height (node-page x)
 148                                                     (node-page (car nodes))))
 149                            height-nodes))
 150            (heights (map node-height height-nodes))
 151            (mean (/ (apply + densities) (length densities)))
 152            (diff (map (lambda (x) (- x mean)) densities))
 153            (var (map sqr (map (lambda (x) (* (car p-heights) x)) diff))))
 154       (apply + var)))
 155
 156   (define (walk-paths best node lines nodes paths)
 157     (let* ((height (cumulative-height lines))
 158            (next-page (+ (if (null? paths) 0 (node-page (car paths))) 1))
 159            (page (page-height (node-page node) next-page))
 160            (hh (make-node '() (node-line node) 0 0 height))
 161            (break-score (robust-break-score node))
 162            (density-score (if (null? paths) 0
 163                               ;; TODO: find out why we need density
 164                               ;;       use other height-score parameters?
 165                               ;; See: input/test/page-breaks.ly
 166                               (* 1 (density-variance
 167                                     (cons hh (get-path (car paths)))))))
 168            (page-score (height-score page height))
 169            (this-score (add-scores page-score break-score density-score))
 170            (path-score (if (null? paths) 0 (node-score (car paths))))
 171            (score (add-scores path-score this-score)))
 172
 173       (if (and (>= score 0)
 174                (or (<= score (node-score best))
 175                    (= (node-score best) -1)))
 176           (begin
 177             (set! (node-score best) score)
 178             (set! (node-page best) next-page)
 179             (set! (node-height best) height)
 180             (set! (node-prev best) (car paths))))
 181
 182       (if (or (null? nodes)
 183               ;; short circuit
 184               (and (= path-score -1)
 185                    (> (- (/ height page) 1) MAX-CRAMP)))
 186           best
 187           (walk-paths best (car nodes)
 188                       (cons (node-line (car paths)) lines)
 189                       (cdr nodes) (cdr paths)))))
 190
 191   (define (walk-lines lines nodes paths)
 192     (if (null? (cdr lines))
 193         paths
 194         (let* ((prev (node-prev (car nodes)))
 195                (this (make-node prev (car lines) 0 INFINITY))
 196                (next (make-node this (cadr lines) 0 0))
 197                (best (walk-paths this prev (list (node-line (car nodes)))
 198                                  (cddr nodes) paths)))
 199           (walk-lines (cdr lines) (cons next nodes) (cons best paths)))))
 200
 201   (let* ((dummy (make-node '() '() 0 0))
 202          (this (make-node dummy (car lines) 0 0))
 203          (result (walk-lines lines (list this dummy) (list dummy)))
 204          (path (get-path (car result)))
 205          ;; CDR: junk dummy node
 206          (breaks (cdr (reverse (map robust-line-number path)))))
 207
 208     (if (ly:get-option 'verbose)
 209         (begin
 210           (format (current-error-port) "breaks: ~S\n" breaks)
 211           (force-output (current-error-port))))
 212
 213     ;; TODO: if solution is bad return no breaks and revert to
 214     ;;       ragged bottom
 215     (list->vector breaks)))
 216
 217
 218
 219 ;;;;;;;;;;;;;;;;;;
 220 ; titling.
 221 (define-public (default-book-title paper scopes)
 222   "Generate book title from header strings."
 223
 224
 225   (define (get sym)
 226     (let ((x (ly:modules-lookup scopes sym)))
 227       (if (markup? x) x "")))
 228   (define (has sym)
 229     (markup?  (ly:modules-lookup scopes sym)))
 230
 231   (let ((props (page-properties paper)))
 232
 233     (interpret-markup
 234      paper props
 235      (make-override-markup
 236        '(baseline-skip . 4)
 237        (make-column-markup
 238         (append
 239          (if (has 'dedication)
 240              (list (markup #:fill-line
 241                      (#:normalsize (get 'dedication))))
 242              '())
 243
 244          (if (has 'title)
 245             (list (markup (#:fill-line
 246                            (#:huge #:bigger #:bigger #:bigger #:bigger #:bold (get 'title)))))
 247             '())
 248
 249          (if (or (has 'subtitle) (has 'subsubtitle))
 250              (list
 251               (make-override-markup
 252                '(baseline-skip . 3)
 253               (make-column-markup
 254                (list
 255                (markup #:fill-line
 256                        (#:large #:bigger #:bigger #:bold (get 'subtitle))
 257                        #:fill-line (#:bigger #:bigger #:bold (get 'subsubtitle)))
 258                (markup #:override '(baseline-skip . 5)
 259                        #:column ("")))
 260
 261                ))
 262              )
 263              '())
 264
 265          (list
 266           (make-override-markup
 267           '(baseline-skip . 2.5)
 268           (make-column-markup
 269             (append
 270              (if (or (has 'poet) (has 'composer))
 271                 (list (markup #:fill-line
 272                               (#:bigger (get 'poet) #:large #:bigger #:caps (get 'composer))))
 273                 '())
 274              (if (or (has 'texttranslator) (has 'opus))
 275                  (list
 276                   (markup
 277                    #:fill-line (#:bigger (get 'texttranslator) #:bigger (get 'opus))))
 278                  '())
 279              (if (or (has 'meter) (has 'arranger))
 280                  (list
 281                   (markup #:fill-line
 282                           (#:bigger (get 'meter) #:bigger (get 'arranger))))
 283                  '())
 284
 285              (if (has 'instrument)
 286                  (list ""
 287                        (markup #:fill-line (#:large #:bigger (get 'instrument))))
 288                  '())
 289              (if (has 'piece)
 290                  (list ""
 291                        (markup #:fill-line (#:large #:bigger #:caps (get 'piece) "")))
 292                  '())
 293              )))))))
 294      )))
 295
 296
 297 (define-public (default-user-title paper markup)
 298   "Generate book title from header markup."
 299   (if (markup? markup)
 300       (let ((props (page-properties paper))
 301             (baseline-skip (chain-assoc-get 'baseline-skip props 2)) )
 302         (stack-lines DOWN 0 BASELINE-SKIP
 303                      (list (interpret-markup paper props markup))))))
 304
 305 (define-public (default-score-title paper scopes)
 306   "Generate score title from header strings."
 307
 308   (define (get sym)
 309     (let ((x (ly:modules-lookup scopes sym)))
 310       (if (markup? x) x "")))
 311
 312   (define (has sym)
 313     (markup? (ly:modules-lookup scopes sym)))
 314
 315   (let ((props (page-properties paper)))
 316
 317     (interpret-markup
 318      paper props
 319       (make-override-markup
 320        '(baseline-skip . 4)
 321        (make-column-markup
 322         (append
 323          (if (has 'opus)
 324              (list (markup #:fill-line ("" (get 'opus))))
 325              '())
 326          (if (has 'piece)
 327              (list (markup #:fill-line (#:large #:bigger #:caps (get 'piece) "")))
 328              '()))
 329
 330         )))))