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