scm/lily-library.scm

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