scm/lily-library.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;; for take, drop, take-while, list-index, and find-tail:
  20 (use-modules (srfi srfi-1))
  21
  22 ;; for define-safe-public when byte-compiling using Guile V2
  23 (use-modules (scm safe-utility-defs))
  24
  25 (use-modules (ice-9 pretty-print))
  26
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28 ;; constants.
  29
  30 (define-public X 0)
  31 (define-public Y 1)
  32 (define-safe-public START -1)
  33 (define-safe-public STOP 1)
  34 (define-public LEFT -1)
  35 (define-public RIGHT 1)
  36 (define-public UP 1)
  37 (define-public DOWN -1)
  38 (define-public CENTER 0)
  39
  40 (define-safe-public DOUBLE-FLAT-QTS -4)
  41 (define-safe-public THREE-Q-FLAT-QTS -3)
  42 (define-safe-public FLAT-QTS -2)
  43 (define-safe-public SEMI-FLAT-QTS -1)
  44 (define-safe-public NATURAL-QTS 0)
  45 (define-safe-public SEMI-SHARP-QTS 1)
  46 (define-safe-public SHARP-QTS 2)
  47 (define-safe-public THREE-Q-SHARP-QTS 3)
  48 (define-safe-public DOUBLE-SHARP-QTS 4)
  49 (define-safe-public SEMI-TONE-QTS 2)
  50
  51 (define-safe-public DOUBLE-FLAT  -1)
  52 (define-safe-public THREE-Q-FLAT -3/4)
  53 (define-safe-public FLAT -1/2)
  54 (define-safe-public SEMI-FLAT -1/4)
  55 (define-safe-public NATURAL 0)
  56 (define-safe-public SEMI-SHARP 1/4)
  57 (define-safe-public SHARP 1/2)
  58 (define-safe-public THREE-Q-SHARP 3/4)
  59 (define-safe-public DOUBLE-SHARP 1)
  60 (define-safe-public SEMI-TONE 1/2)
  61
  62 (define-safe-public INFINITY-INT 1000000)
  63
  64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65 ;; moments
  66
  67 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  68
  69 (define-public (moment-min a b)
  70   (if (ly:moment<? a b) a b))
  71
  72 (define-public (moment<=? a b)
  73   (or (equal? a b)
  74       (ly:moment<? a b)))
  75
  76 (define-public (fraction->moment fraction)
  77   (if (null? fraction)
  78       ZERO-MOMENT
  79       (ly:make-moment (car fraction) (cdr fraction))))
  80
  81 (define-public (moment->fraction moment)
  82   (cons (ly:moment-main-numerator moment)
  83         (ly:moment-main-denominator moment)))
  84
  85 (define-public (seconds->moment s context)
  86   "Return a moment equivalent to s seconds at the current tempo."
  87   (ly:moment-mul (ly:context-property context 'tempoWholesPerMinute)
  88                  (ly:make-moment (/ s 60))))
  89
  90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91 ;; durations
  92
  93 (define-public (duration-log-factor lognum)
  94   "Given a logarithmic duration number, return the length of the duration,
  95 as a number of whole notes."
  96   (or (and (exact? lognum) (integer? lognum))
  97       (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f))
  98   (if (<= lognum 0)
  99       (ash 1 (- lognum))
 100       (/ (ash 1 lognum))))
 101
 102 (define-public (duration-dot-factor dotcount)
 103   "Given a count of the dots used to extend a musical duration, return
 104 the numeric factor by which they increase the duration."
 105   (or (and (exact? dotcount) (integer? dotcount) (>= dotcount 0))
 106       (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f))
 107   (- 2 (/ (ash 1 dotcount))))
 108
 109 (define-public (duration-length dur)
 110   "Return the overall length of a duration, as a number of whole
 111 notes.  (Not to be confused with ly:duration-length, which returns a
 112 less-useful moment object.)"
 113   (ly:moment-main (ly:duration-length dur)))
 114
 115 (define-public (duration-visual dur)
 116   "Given a duration object, return the visual part of the duration (base
 117 note length and dot count), in the form of a duration object with
 118 non-visual scale factor 1."
 119   (ly:make-duration (ly:duration-log dur) (ly:duration-dot-count dur) 1))
 120
 121 (define-public (duration-visual-length dur)
 122   "Given a duration object, return the length of the visual part of the
 123 duration (base note length and dot count), as a number of whole notes."
 124   (duration-length (duration-visual dur)))
 125
 126 (define-public (unity-if-multimeasure context dur)
 127   "Given a context and a duration, return @code{1} if the duration is
 128 longer than the @code{measureLength} in that context, and @code{#f} otherwise.
 129 This supports historic use of @code{Completion_heads_engraver} to split
 130 @code{c1*3} into three whole notes."
 131   (if (ly:moment<? (ly:context-property context 'measureLength)
 132                    (ly:duration-length dur))
 133     1
 134     #f))
 135
 136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 137 ;; arithmetic
 138 (define-public (average x . lst)
 139   (/ (+ x (apply + lst)) (1+ (length lst))))
 140
 141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 142 ;; parser <-> output hooks.
 143
 144 (define-public (collect-bookpart-for-book book-part)
 145   "Toplevel book-part handler."
 146   (define (add-bookpart book-part)
 147     (ly:parser-define! 'toplevel-bookparts
 148      (cons book-part (ly:parser-lookup 'toplevel-bookparts))))
 149   ;; If toplevel scores have been found before this \bookpart,
 150   ;; add them first to a dedicated bookpart
 151   (if (pair? (ly:parser-lookup 'toplevel-scores))
 152       (begin
 153         (add-bookpart (ly:make-book-part
 154                        (ly:parser-lookup 'toplevel-scores)))
 155         (ly:parser-define! 'toplevel-scores (list))))
 156   (add-bookpart book-part))
 157
 158 (define-public (collect-scores-for-book score)
 159   (ly:parser-define! 'toplevel-scores
 160    (cons score (ly:parser-lookup 'toplevel-scores))))
 161
 162 (define-public (collect-music-aux score-handler music)
 163   (define (music-property symbol)
 164     (ly:music-property music symbol #f))
 165   (cond ((music-property 'page-marker)
 166          ;; a page marker: set page break/turn permissions or label
 167          (let ((label (music-property 'page-label)))
 168            (if (symbol? label)
 169                (score-handler (ly:make-page-label-marker label))))
 170          (for-each (lambda (symbol)
 171                      (let ((permission (music-property symbol)))
 172                        (if (symbol? permission)
 173                            (score-handler
 174                             (ly:make-page-permission-marker symbol
 175                                                             (if (eq? 'forbid permission)
 176                                                                 '()
 177                                                                 permission))))))
 178                    '(line-break-permission page-break-permission
 179                                            page-turn-permission)))
 180         ((not (music-property 'void))
 181          ;; a regular music expression: make a score with this music
 182          ;; void music is discarded
 183          (score-handler (scorify-music music)))))
 184
 185 (define-public (collect-music-for-book music)
 186   "Top-level music handler."
 187   (collect-music-aux (lambda (score)
 188                        (collect-scores-for-book score))
 189                      music))
 190
 191 (define-public (collect-book-music-for-book book music)
 192   "Book music handler."
 193   (collect-music-aux (lambda (score)
 194                        (ly:book-add-score! book score))
 195                      music))
 196
 197 (define-public (scorify-music music)
 198   "Preprocess @var{music}."
 199   (ly:make-score
 200    (fold (lambda (f m) (f m))
 201          music
 202          toplevel-music-functions)))
 203
 204 (define (get-current-filename book)
 205   "return any suffix value for output filename allowing for settings by
 206 calls to bookOutputName function"
 207   (or (paper-variable book 'output-filename)
 208       (ly:parser-output-name)))
 209
 210 (define (get-current-suffix book)
 211   "return any suffix value for output filename allowing for settings by calls to
 212 bookoutput function"
 213   (let ((book-output-suffix (paper-variable book 'output-suffix)))
 214     (if (not (string? book-output-suffix))
 215         (ly:parser-lookup 'output-suffix)
 216         book-output-suffix)))
 217
 218 (define-public current-outfile-name #f)  ; for use by regression tests
 219
 220 (define (get-outfile-name book)
 221   "return current filename for generating backend output files"
 222   ;; user can now override the base file name, so we have to use
 223   ;; the file-name concatenated with any potential output-suffix value
 224   ;; as the key to out internal a-list
 225   (let* ((base-name (get-current-filename book))
 226          (output-suffix (get-current-suffix book))
 227          (alist-key (format #f "~a~a" base-name output-suffix))
 228          (counter-alist (ly:parser-lookup 'counter-alist))
 229          (output-count (assoc-get alist-key counter-alist 0))
 230          (result base-name))
 231     ;; Allow all ASCII alphanumerics, including accents
 232     (if (string? output-suffix)
 233         (set! result
 234               (format #f "~a-~a"
 235                       result
 236                       (string-regexp-substitute
 237                        "[^-[:alnum:]]"
 238                        "_"
 239                        output-suffix))))
 240
 241     ;; assoc-get call will always have returned a number
 242     (if (> output-count 0)
 243         (set! result (format #f "~a-~a" result output-count)))
 244
 245     (ly:parser-define! 'counter-alist
 246      (assoc-set! counter-alist alist-key (1+ output-count)))
 247     (set! current-outfile-name result)
 248     result))
 249
 250 (define (print-book-with book process-procedure)
 251   (let* ((paper (ly:parser-lookup '$defaultpaper))
 252          (layout (ly:parser-lookup '$defaultlayout))
 253          (outfile-name (get-outfile-name book)))
 254     (process-procedure book paper layout outfile-name)))
 255
 256 (define-public (print-book-with-defaults book)
 257   (print-book-with book ly:book-process))
 258
 259 (define-public (print-book-with-defaults-as-systems book)
 260   (print-book-with book ly:book-process-to-systems))
 261
 262 ;; Add a score to the current bookpart, book or toplevel
 263 (define-public (add-score score)
 264   (cond
 265    ((ly:parser-lookup '$current-bookpart)
 266     ((ly:parser-lookup 'bookpart-score-handler)
 267      (ly:parser-lookup '$current-bookpart) score))
 268    ((ly:parser-lookup '$current-book)
 269     ((ly:parser-lookup 'book-score-handler)
 270      (ly:parser-lookup '$current-book) score))
 271    (else
 272     ((ly:parser-lookup 'toplevel-score-handler) score))))
 273
 274 (define-public paper-variable
 275   (let
 276       ((get-papers
 277         (lambda (book)
 278           (append (if (and book (ly:output-def? (ly:book-paper book)))
 279                       (list (ly:book-paper book))
 280                       '())
 281                   (ly:parser-lookup '$papers)
 282                   (list (ly:parser-lookup '$defaultpaper))))))
 283     (make-procedure-with-setter
 284      (lambda (book symbol)
 285        (any (lambda (p) (ly:output-def-lookup p symbol #f))
 286             (get-papers book)))
 287      (lambda (book symbol value)
 288        (ly:output-def-set-variable!
 289         (car (get-papers book))
 290         symbol value)))))
 291
 292 (define-public (add-text text)
 293   (add-score (list text)))
 294
 295 (define-public (add-music music)
 296   (collect-music-aux (lambda (score)
 297                        (add-score score))
 298                      music))
 299
 300 (define-public (context-mod-from-music music)
 301   (let ((warn #t) (mods (ly:make-context-mod)))
 302     (let loop ((m music))
 303       (if (music-is-of-type? m 'layout-instruction-event)
 304           (let ((symbol (ly:music-property m 'symbol)))
 305             (ly:add-context-mod
 306              mods
 307              (case (ly:music-property m 'name)
 308                ((PropertySet)
 309                 (list 'assign
 310                       symbol
 311                       (ly:music-property m 'value)))
 312                ((PropertyUnset)
 313                 (list 'unset symbol))
 314                ((OverrideProperty)
 315                 (cons* 'push
 316                        symbol
 317                        (ly:music-property m 'grob-value)
 318                        (cond
 319                         ((ly:music-property m 'grob-property #f) => list)
 320                         (else
 321                          (ly:music-property m 'grob-property-path)))))
 322                ((RevertProperty)
 323                 (cons* 'pop
 324                        symbol
 325                        (cond
 326                         ((ly:music-property m 'grob-property #f) => list)
 327                         (else
 328                          (ly:music-property m 'grob-property-path))))))))
 329           (case (ly:music-property m 'name)
 330             ((ApplyContext)
 331              (ly:add-context-mod mods
 332                                  (list 'apply
 333                                        (ly:music-property m 'procedure))))
 334             ((ContextSpeccedMusic)
 335              (loop (ly:music-property m 'element)))
 336             (else
 337              (let ((callback (ly:music-property m 'elements-callback)))
 338                (if (procedure? callback)
 339                    (for-each loop (callback m))
 340                    (if (and warn (ly:duration? (ly:music-property m 'duration)))
 341                        (begin
 342                          (ly:music-warning
 343                           music
 344                           (_ "Music unsuitable for context-mod"))
 345                          (set! warn #f)))))))))
 346     mods))
 347
 348 (define-public (context-defs-from-music output-def music)
 349   (let ((warn #t))
 350     (let loop ((m music) (mods #f))
 351       ;; The parser turns all sets, overrides etc into something
 352       ;; wrapped in ContextSpeccedMusic.  If we ever get a set,
 353       ;; override etc that is not wrapped in ContextSpeccedMusic, the
 354       ;; user has created it in Scheme himself without providing the
 355       ;; required wrapping.  In that case, using #f in the place of a
 356       ;; context modification results in a reasonably recognizable
 357       ;; error.
 358       (if (music-is-of-type? m 'layout-instruction-event)
 359           (ly:add-context-mod
 360            mods
 361            (case (ly:music-property m 'name)
 362              ((PropertySet)
 363               (list 'assign
 364                     (ly:music-property m 'symbol)
 365                     (ly:music-property m 'value)))
 366              ((PropertyUnset)
 367               (list 'unset
 368                     (ly:music-property m 'symbol)))
 369              ((OverrideProperty)
 370               (cons* 'push
 371                      (ly:music-property m 'symbol)
 372                      (ly:music-property m 'grob-value)
 373                      (cond
 374                       ((ly:music-property m 'grob-property #f) => list)
 375                       (else
 376                        (ly:music-property m 'grob-property-path)))))
 377              ((RevertProperty)
 378               (cons* 'pop
 379                      (ly:music-property m 'symbol)
 380                      (cond
 381                       ((ly:music-property m 'grob-property #f) => list)
 382                       (else
 383                        (ly:music-property m 'grob-property-path)))))))
 384           (case (ly:music-property m 'name)
 385             ((ApplyContext)
 386              (ly:add-context-mod mods
 387                                  (list 'apply
 388                                        (ly:music-property m 'procedure))))
 389             ((ContextSpeccedMusic)
 390              ;; Use let* here to let defs catch up with modifications
 391              ;; to the context defs made in the recursion
 392              (let* ((mods (loop (ly:music-property m 'element)
 393                                 (ly:make-context-mod)))
 394                     (defs (ly:output-find-context-def
 395                            output-def (ly:music-property m 'context-type))))
 396                (if (null? defs)
 397                    (ly:music-warning
 398                     music
 399                     (ly:format (_ "Cannot find context-def \\~a")
 400                                (ly:music-property m 'context-type)))
 401                    (for-each
 402                     (lambda (entry)
 403                       (ly:output-def-set-variable!
 404                        output-def (car entry)
 405                        (ly:context-def-modify (cdr entry) mods)))
 406                     defs))))
 407             (else
 408              (let ((callback (ly:music-property m 'elements-callback)))
 409                (if (procedure? callback)
 410                    (fold loop mods (callback m))
 411                    (if (and warn (ly:duration? (ly:music-property m 'duration)))
 412                        (begin
 413                          (ly:music-warning
 414                           music
 415                           (_ "Music unsuitable for output-def"))
 416                          (set! warn #f))))))))
 417       mods)))
 418
 419
 420 ;;;;;;;;;;;;;;;;
 421 ;; alist
 422
 423 (define-public assoc-get ly:assoc-get)
 424
 425 (define-public chain-assoc-get ly:chain-assoc-get)
 426
 427 (define-public (uniqued-alist alist acc)
 428   (if (null? alist) acc
 429       (if (assoc (caar alist) acc)
 430           (uniqued-alist (cdr alist) acc)
 431           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 432
 433 (define-public (alist<? x y)
 434   (string<? (symbol->string (car x))
 435             (symbol->string (car y))))
 436
 437 (define (map-alist-vals func list)
 438   "map FUNC over the vals of LIST, leaving the keys."
 439   (if (null?  list)
 440       '()
 441       (cons (cons  (caar list) (func (cdar list)))
 442             (map-alist-vals func (cdr list)))))
 443
 444 (define (map-alist-keys func list)
 445   "map FUNC over the keys of an alist LIST, leaving the vals."
 446   (if (null?  list)
 447       '()
 448       (cons (cons (func (caar list)) (cdar list))
 449             (map-alist-keys func (cdr list)))))
 450
 451 (define-public (first-member members lst)
 452   "Return first successful member (of member) from @var{members} in
 453 @var{lst}."
 454   (any (lambda (m) (member m lst)) members))
 455
 456 (define-public (first-assoc keys lst)
 457   "Return first successful assoc of key from @var{keys} in @var{lst}."
 458   (any (lambda (k) (assoc k lst)) keys))
 459
 460 (define-public (flatten-alist alist)
 461   (if (null? alist)
 462       '()
 463       (cons (caar alist)
 464             (cons (cdar alist)
 465                   (flatten-alist (cdr alist))))))
 466
 467 (define-public (map-selected-alist-keys function keys alist)
 468   "Return @var{alist} with @var{function} applied to all of the values
 469 in list @var{keys}.
 470
 471 For example:
 472 @example
 473 @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
 474 @code{((a . -1) (b . 2) (c . 3) (d . 4)}
 475 @end example"
 476   (define (map-selected-alist-keys-helper key alist)
 477     (map
 478      (lambda (pair)
 479        (if (equal? key (car pair))
 480            (cons key (function (cdr pair)))
 481            pair))
 482      alist))
 483   (fold map-selected-alist-keys-helper alist keys))
 484
 485 ;;;;;;;;;;;;;;;;
 486 ;; vector
 487
 488 (define-public (vector-for-each proc vec)
 489   (do
 490       ((i 0 (1+ i)))
 491       ((>= i (vector-length vec)) vec)
 492     (vector-set! vec i (proc (vector-ref vec i)))))
 493
 494 ;;;;;;;;;;;;;;;;
 495 ;; hash
 496
 497 (define-public (hash-table->alist t)
 498   (hash-fold acons '() t))
 499
 500 ;; todo: code dup with C++.
 501 (define-safe-public (alist->hash-table lst)
 502   "Convert alist to table"
 503   (let ((m (make-hash-table (length lst))))
 504     (for-each (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 505     m))
 506
 507 ;;;;;;;;;;;;;;;;
 508 ;; list
 509
 510 (define (functional-or . rest)
 511   (any identity rest))
 512
 513 (define (functional-and . rest)
 514   (every identity rest))
 515
 516 (define (split-list lst n)
 517   "Split LST in N equal sized parts"
 518
 519   (define (helper todo acc-vector k)
 520     (if (null? todo)
 521         acc-vector
 522         (begin
 523           (if (< k 0)
 524               (set! k (+ n k)))
 525
 526           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 527           (helper (cdr todo) acc-vector (1- k)))))
 528
 529   (helper lst (make-vector n '()) (1- n)))
 530
 531 (define (list-element-index lst x)
 532   (list-index (lambda (m) (equal? m x)) lst))
 533
 534 (define-public (count-list lst)
 535   "Given @var{lst} as @code{(E1 E2 .. )}, return
 536 @code{((E1 . 1) (E2 . 2) ... )}."
 537   (map cons lst (iota (length lst) 1)))
 538
 539 (define-public (list-join lst intermediate)
 540   "Put @var{intermediate} between all elts of @var{lst}."
 541
 542   (fold-right
 543    (lambda (elem prev)
 544      (if (pair? prev)
 545          (cons  elem (cons intermediate prev))
 546          (list elem)))
 547    '() lst))
 548
 549 (define-public filtered-map filter-map)
 550
 551 (define-public (flatten-list x)
 552   "Unnest list."
 553   (let loop ((x x) (tail '()))
 554     (cond ((list? x) (fold-right loop tail x))
 555           ((not (pair? x)) (cons x tail))
 556           (else (loop (car x) (loop (cdr x) tail))))))
 557
 558 (define (list-minus a b)
 559   "Return list of elements in A that are not in B."
 560   (lset-difference eq? a b))
 561
 562 (define-public (uniq-list lst)
 563   "Uniq @var{lst}, assuming that it is sorted.  Uses @code{equal?}
 564 for comparisons."
 565
 566   (reverse!
 567    (fold (lambda (x acc)
 568            (if (null? acc)
 569                (list x)
 570                (if (equal? x (car acc))
 571                    acc
 572                    (cons x acc))))
 573          '() lst) '()))
 574
 575 (define (split-at-predicate pred lst)
 576   "Split LST into two lists at the first element that returns #f for
 577   (PRED previous_element element).  Return the two parts as a pair.
 578   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 579   (let ((i (and (pair? lst)
 580                 (list-index (lambda (x y) (not (pred x y)))
 581                             lst
 582                             (cdr lst)))))
 583     (if i
 584         (call-with-values
 585             (lambda () (split-at lst (1+ i)))
 586           cons)
 587         (list lst))))
 588
 589 (define-public (split-list-by-separator lst pred)
 590   "Split @var{lst} at each element that satisfies @var{pred}, and return
 591 the parts (with the separators removed) as a list of lists.  For example,
 592 executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns
 593 @samp{((a) (b c) (d))}."
 594   (call-with-values (lambda () (break pred lst))
 595     (lambda (head tail)
 596       (cons head
 597             (if (null? tail)
 598                 tail
 599                 (split-list-by-separator (cdr tail) pred))))))
 600
 601 (define-public (offset-add a b)
 602   (cons (+ (car a) (car b))
 603         (+ (cdr a) (cdr b))))
 604
 605 (define-public (offset-flip-y o)
 606   (cons (car o) (- (cdr o))))
 607
 608 (define-public (offset-scale o scale)
 609   (cons (* (car o) scale)
 610         (* (cdr o) scale)))
 611
 612 (define-public (ly:list->offsets accum coords)
 613   (if (null? coords)
 614       accum
 615       (cons (cons (car coords) (cadr coords))
 616             (ly:list->offsets accum (cddr coords)))))
 617
 618 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 619 ;; intervals
 620
 621 (define-public empty-interval '(+inf.0 . -inf.0))
 622
 623 (define-public (symmetric-interval expr)
 624   (cons (- expr) expr))
 625
 626 (define-public (interval-length x)
 627   "Length of the number-pair @var{x}, if an interval."
 628   (max 0 (- (cdr x) (car x))))
 629
 630 (define-public (ordered-cons a b)
 631   (cons (min a b)
 632         (max a b)))
 633
 634 (define-public (interval-bound interval dir)
 635   ((if (= dir RIGHT) cdr car) interval))
 636
 637 (define-public (interval-index interval dir)
 638   "Interpolate @var{interval} between between left (@var{dir}=-1) and
 639 right (@var{dir}=+1)."
 640
 641   (* (+  (interval-start interval) (interval-end interval)
 642          (* dir (- (interval-end interval) (interval-start interval))))
 643      0.5))
 644
 645 (define-public (interval-center x)
 646   "Center the number-pair @var{x}, if an interval."
 647   (if (interval-empty? x)
 648       0.0
 649       (/ (+ (car x) (cdr x)) 2)))
 650
 651 (define-public interval-start car)
 652
 653 (define-public interval-end cdr)
 654
 655 (define (other-axis a)
 656   (remainder (+ a 1) 2))
 657
 658 (define-public (interval-scale iv factor)
 659   (cons (* (car iv) factor)
 660         (* (cdr iv) factor)))
 661
 662 (define-public (interval-widen iv amount)
 663   (cons (- (car iv) amount)
 664         (+ (cdr iv) amount)))
 665
 666 (define-public (interval-empty? iv)
 667   (> (car iv) (cdr iv)))
 668
 669 (define-public (interval-union i1 i2)
 670   (cons
 671    (min (car i1) (car i2))
 672    (max (cdr i1) (cdr i2))))
 673
 674 (define-public (interval-intersection i1 i2)
 675   (cons
 676    (max (car i1) (car i2))
 677    (min (cdr i1) (cdr i2))))
 678
 679 (define-public (interval-sane? i)
 680   (not (or  (nan? (car i))
 681             (inf? (car i))
 682             (nan? (cdr i))
 683             (inf? (cdr i))
 684             (> (car i) (cdr i)))))
 685
 686 (define-public (add-point interval p)
 687   (cons (min (interval-start interval) p)
 688         (max (interval-end interval) p)))
 689
 690 (define-public (reverse-interval iv)
 691   (cons (cdr iv) (car iv)))
 692
 693 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 694 ;; coordinates
 695
 696 (define coord-x car)
 697 (define coord-y cdr)
 698
 699 (define (coord-operation operator operand coordinate)
 700   (if (pair? operand)
 701       (cons (operator (coord-x operand) (coord-x coordinate))
 702             (operator (coord-y operand) (coord-y coordinate)))
 703       (cons (operator operand (coord-x coordinate))
 704             (operator operand (coord-y coordinate)))))
 705
 706 (define (coord-apply function coordinate)
 707   (if (pair? function)
 708       (cons
 709        ((coord-x function) (coord-x coordinate))
 710        ((coord-y function) (coord-y coordinate)))
 711       (cons
 712        (function (coord-x coordinate))
 713        (function (coord-y coordinate)))))
 714
 715 (define-public (coord-translate coordinate amount)
 716   (coord-operation + amount coordinate))
 717
 718 (define-public (coord-scale coordinate amount)
 719   (coord-operation * amount coordinate))
 720
 721 (define-public (coord-rotate coordinate degrees-in-radians)
 722   (let*
 723       ((coordinate
 724         (cons
 725          (exact->inexact (coord-x coordinate))
 726          (exact->inexact (coord-y coordinate))))
 727        (radius
 728         (sqrt
 729          (+ (* (coord-x coordinate) (coord-x coordinate))
 730             (* (coord-y coordinate) (coord-y coordinate)))))
 731        (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
 732     (cons
 733      (* radius (cos (+ angle degrees-in-radians)))
 734      (* radius (sin (+ angle degrees-in-radians))))))
 735
 736 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 737 ;; trig
 738
 739 (define-public PI (* 4 (atan 1)))
 740
 741 (define-public TWO-PI (* 2 PI))
 742
 743 (define-public PI-OVER-TWO (/ PI 2))
 744
 745 (define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
 746
 747 (define-public (cyclic-base-value value cycle)
 748   "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
 749   (if (< value 0)
 750       (cyclic-base-value (+ value cycle) cycle)
 751       (if (>= value cycle)
 752           (cyclic-base-value (- value cycle) cycle)
 753           value)))
 754
 755 (define-public (angle-0-2pi angle)
 756   "Take @var{angle} (in radians) and maps it between 0 and 2pi."
 757   (cyclic-base-value angle TWO-PI))
 758
 759 (define-public (angle-0-360 angle)
 760   "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
 761   (cyclic-base-value angle 360.0))
 762
 763 (define-public PI-OVER-180  (/ PI 180))
 764
 765 (define-public (degrees->radians angle-degrees)
 766   "Convert the given angle from degrees to radians."
 767   (* angle-degrees PI-OVER-180))
 768
 769 (define-public (ellipse-radius x-radius y-radius angle)
 770   (/
 771    (* x-radius y-radius)
 772    (sqrt
 773     (+ (* (expt y-radius 2)
 774           (* (cos angle) (cos angle)))
 775        (* (expt x-radius 2)
 776           (* (sin angle) (sin angle)))))))
 777
 778 (define-public (polar->rectangular radius angle-in-degrees)
 779   "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
 780 as rectangular coordinates @ode{(x-length . y-length)}."
 781
 782   (let ((complex (make-polar
 783                   radius
 784                   (degrees->radians angle-in-degrees))))
 785     (cons
 786      (real-part complex)
 787      (imag-part complex))))
 788
 789 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 790 ;; string
 791
 792 (define-public (string-endswith s suffix)
 793   (equal? suffix (substring s
 794                             (max 0 (- (string-length s) (string-length suffix)))
 795                             (string-length s))))
 796
 797 (define-public (string-startswith s prefix)
 798   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 799
 800 (define-public (string-encode-integer i)
 801   (cond
 802    ((= i  0) "o")
 803    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 804    (else (string-append
 805           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 806           (string-encode-integer (quotient i 26))))))
 807
 808 (define (number->octal-string x)
 809   (let* ((n (inexact->exact x))
 810          (n64 (quotient n 64))
 811          (n8 (quotient (- n (* n64 64)) 8)))
 812     (string-append
 813      (number->string n64)
 814      (number->string n8)
 815      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 816
 817 (define-public (ly:inexact->string x radix)
 818   (let ((n (inexact->exact x)))
 819     (number->string n radix)))
 820
 821 (define-public (ly:number-pair->string c)
 822   (string-append (ly:number->string (car c)) " "
 823                  (ly:number->string (cdr c))))
 824
 825 (define-public (dir-basename file . rest)
 826   "Strip suffixes in @var{rest}, but leave directory component for
 827 @var{file}."
 828   (define (inverse-basename x y) (basename y x))
 829   (simple-format #f "~a/~a" (dirname file)
 830                  (fold inverse-basename file rest)))
 831
 832 (define-public (write-me message x)
 833   "Return @var{x}.  Display @var{message} and write @var{x}.
 834 Handy for debugging, possibly turned off."
 835   (display message) (write x) (newline) x)
 836 ;;  x)
 837
 838 (define-public (stderr string . rest)
 839   (apply format (current-error-port) string rest)
 840   (force-output (current-error-port)))
 841
 842 (define-public (debugf string . rest)
 843   (if #f
 844       (apply stderr string rest)))
 845
 846 (define (index-cell cell dir)
 847   (if (equal? dir 1)
 848       (cdr cell)
 849       (car cell)))
 850
 851 (define (cons-map f x)
 852   "map F to contents of X"
 853   (cons (f (car x)) (f (cdr x))))
 854
 855 (define-public (list-insert-separator lst between)
 856   "Create new list, inserting @var{between} between elements of @var{lst}."
 857   (define (conc x y )
 858     (if (eq? y #f)
 859         (list x)
 860         (cons x  (cons between y))))
 861   (fold-right conc #f lst))
 862
 863 (define-public (string-regexp-substitute a b str)
 864   (regexp-substitute/global #f a str 'pre b 'post))
 865
 866 (define (regexp-split str regex)
 867   (define matches '())
 868   (define end-of-prev-match 0)
 869   (define (notice match)
 870
 871     (set! matches (cons (substring (match:string match)
 872                                    end-of-prev-match
 873                                    (match:start match))
 874                         matches))
 875     (set! end-of-prev-match (match:end match)))
 876
 877   (regexp-substitute/global #f regex str notice 'post)
 878
 879   (if (< end-of-prev-match (string-length str))
 880       (set!
 881        matches
 882        (cons (substring str end-of-prev-match (string-length str)) matches)))
 883
 884   (reverse matches))
 885
 886 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 887 ;; numbering styles
 888
 889 (define-public (number-format number-type num . custom-format)
 890   "Print NUM accordingly to the requested NUMBER-TYPE.
 891 Choices include @code{roman-lower} (by default),
 892 @code{roman-upper}, @code{arabic} and @code{custom}.
 893 In the latter case, CUSTOM-FORMAT must be supplied
 894 and will be applied to NUM."
 895  (cond
 896    ((equal? number-type 'roman-lower)
 897     (fancy-format #f "~(~@r~)" num))
 898    ((equal? number-type 'roman-upper)
 899     (fancy-format #f "~@r" num))
 900    ((equal? number-type 'arabic)
 901     (fancy-format #f "~d" num))
 902    ((equal? number-type 'custom)
 903     (fancy-format #f (car custom-format) num))
 904    (else (fancy-format #f "~(~@r~)" num))))
 905
 906 ;;;;;;;;;;;;;;;;
 907 ;; other
 908
 909 (define (sign x)
 910   (if (= x 0)
 911       0
 912       (if (< x 0) -1 1)))
 913
 914 (define-public (binary-search start end getter target-val)
 915   (_i "Find the index between @var{start} and @var{end} (an integer)
 916 which produces the closest match to @var{target-val} if
 917 applied to function @var{getter}.")
 918   (if (<= end start)
 919       start
 920       (let* ((compare (quotient (+ start end) 2))
 921              (get-val (getter compare)))
 922         (cond
 923          ((< target-val get-val)
 924           (set! end (1- compare)))
 925          ((< get-val target-val)
 926           (set! start (1+ compare))))
 927         (binary-search start end getter target-val))))
 928
 929 (define-public (car< a b)
 930   (< (car a) (car b)))
 931
 932 (define-public (car<= a b)
 933   (<= (car a) (car b)))
 934
 935 (define-public (symbol<? lst r)
 936   (string<? (symbol->string lst) (symbol->string r)))
 937
 938 (define-public (symbol-key<? lst r)
 939   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 940
 941 (define-public (eval-carefully symbol module . default)
 942   "Check whether all symbols in expr @var{symbol} are reachable
 943 in module @var{module}.  In that case evaluate, otherwise
 944 print a warning and set an optional @var{default}."
 945   (let* ((unavailable? (lambda (sym)
 946                          (not (module-defined? module sym))))
 947          (sym-unavailable
 948           (filter
 949            unavailable?
 950            (filter symbol? (flatten-list symbol)))))
 951     (if (null? sym-unavailable)
 952         (eval symbol module)
 953         (let* ((def (and (pair? default) (car default))))
 954           (ly:programming-error
 955            "cannot evaluate ~S in module ~S, setting to ~S"
 956            (object->string symbol)
 957            (object->string module)
 958            (object->string def))
 959           def))))
 960
 961 (define (self-evaluating? x)
 962   (or (number? x) (string? x) (procedure? x) (boolean? x)))
 963
 964 (define (ly-type? x)
 965   (any (lambda (p) ((car p) x)) lilypond-exported-predicates))
 966
 967 (define-public (pretty-printable? val)
 968   (and (not (self-evaluating? val))
 969        (not (symbol? val))
 970        (not (hash-table? val))
 971        (not (ly-type? val))))
 972
 973 (define-public (scm->string val)
 974   (let* ((quote-style (if (string? val)
 975                         'double
 976                         (if (or (null? val) ; (ly-type? '()) => #t
 977                                 (and (not (self-evaluating? val))
 978                                      (not (vector? val))
 979                                      (not (hash-table? val))
 980                                      (not (ly-type? val))))
 981                           'single
 982                           'none)))
 983          ; don't confuse users with #<procedure ...> syntax
 984          (str (if (and (procedure? val)
 985                        (symbol? (procedure-name val)))
 986                 (symbol->string (procedure-name val))
 987                 (call-with-output-string
 988                   (if (pretty-printable? val)
 989                     ; property values in PDF hit margin after 64 columns
 990                     (lambda (port)
 991                       (pretty-print val port #:width (case quote-style
 992                                                        ((single) 63)
 993                                                        (else 64))))
 994                     (lambda (port) (display val port)))))))
 995     (case quote-style
 996       ((single) (string-append
 997                   "'"
 998                   (string-regexp-substitute "\n " "\n  " str)))
 999       ((double) (string-append "\"" str "\""))
1000       (else str))))
1001
1002 (define-public (!= lst r)
1003   (not (= lst r)))
1004
1005 (define-public lily-unit->bigpoint-factor
1006   (cond
1007    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
1008    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
1009    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
1010
1011 (define-public lily-unit->mm-factor
1012   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
1013
1014 ;;; FONT may be font smob, or pango font string...
1015 (define-public (font-name-style font)
1016   (if (string? font)
1017       (string-downcase font)
1018       (let* ((font-name (ly:font-name font))
1019              (full-name (if font-name font-name (ly:font-file-name font))))
1020         (string-downcase full-name))))
1021
1022 (define-public (modified-font-metric-font-scaling font)
1023   (let* ((designsize (ly:font-design-size font))
1024          (magnification (* (ly:font-magnification font)))
1025          (scaling (* magnification designsize)))
1026     (debugf "scaling:~S\n" scaling)
1027     (debugf "magnification:~S\n" magnification)
1028     (debugf "design:~S\n" designsize)
1029     scaling))
1030
1031 (define-public (version-not-seen-message input-file-name)
1032   (ly:warning-located
1033    (ly:format "~a:1" input-file-name)
1034    (_ "no \\version statement found, please add~afor future compatibility")
1035    (format #f "\n\n\\version ~s\n\n" (lilypond-version))))