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