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-defs-from-music parser output-def music)
 261   (let ((bottom 'Voice) (warn #t))
 262     (define (get-bottom sym)
 263       (or
 264        (let ((def (ly:output-def-lookup output-def sym #f)))
 265         (and def
 266              (let ((def-child (ly:context-def-lookup def 'default-child #f)))
 267                (and def-child
 268                     (get-bottom def-child)))))
 269        sym))
 270     (let loop ((m music) (mods #f))
 271       ;; The parser turns all sets, overrides etc into something
 272       ;; wrapped in ContextSpeccedMusic.  If we ever get a set,
 273       ;; override etc that is not wrapped in ContextSpeccedMusic, the
 274       ;; user has created it in Scheme himself without providing the
 275       ;; required wrapping.  In that case, using #f in the place of a
 276       ;; context modification results in a reasonably recognizable
 277       ;; error.
 278       (if (music-is-of-type? m 'layout-instruction-event)
 279           (ly:add-context-mod
 280            mods
 281            (case (ly:music-property m 'name)
 282              ((PropertySet)
 283               (list 'assign
 284                     (ly:music-property m 'symbol)
 285                     (ly:music-property m 'value)))
 286              ((PropertyUnset)
 287               (list 'unset
 288                     (ly:music-property m 'symbol)))
 289              ((OverrideProperty)
 290               (list 'push
 291                     (ly:music-property m 'symbol)
 292                     (ly:music-property m 'grob-value)
 293                     (ly:music-property m 'grob-property-path)))
 294              ((RevertProperty)
 295               (list 'pop
 296                     (ly:music-property m 'symbol)
 297                     (ly:music-property m 'grob-property-path)))))
 298           (case (ly:music-property m 'name)
 299             ((SequentialMusic SimultaneousMusic)
 300              (fold loop mods (ly:music-property m 'elements)))
 301             ((ContextSpeccedMusic)
 302              (let ((sym (ly:music-property m 'context-type)))
 303                (if (eq? sym 'Bottom)
 304                    (set! sym bottom)
 305                    (set! bottom (get-bottom sym)))
 306                (let ((def (ly:output-def-lookup output-def sym)))
 307                  (if (ly:context-def? def)
 308                      (ly:output-def-set-variable!
 309                       output-def sym
 310                       (ly:context-def-modify
 311                        def
 312                        (loop (ly:music-property m 'element)
 313                              (ly:make-context-mod))))
 314                      (ly:music-warning
 315                       music
 316                       (ly:format (_ "Cannot find context-def \\~a") sym))))))
 317             (else (if (and warn (ly:duration? (ly:music-property m 'duration)))
 318                       (begin
 319                         (ly:music-warning
 320                          music
 321                          (_ "Music unsuitable for output-def"))
 322                         (set! warn #f))))))
 323       mods)))
 324
 325
 326 ;;;;;;;;;;;;;;;;
 327 ;; alist
 328
 329 (define-public assoc-get ly:assoc-get)
 330
 331 (define-public chain-assoc-get ly:chain-assoc-get)
 332
 333 (define-public (uniqued-alist alist acc)
 334   (if (null? alist) acc
 335       (if (assoc (caar alist) acc)
 336           (uniqued-alist (cdr alist) acc)
 337           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 338
 339 (define-public (alist<? x y)
 340   (string<? (symbol->string (car x))
 341             (symbol->string (car y))))
 342
 343 (define (map-alist-vals func list)
 344   "map FUNC over the vals of  LIST, leaving the keys."
 345   (if (null?  list)
 346       '()
 347       (cons (cons  (caar list) (func (cdar list)))
 348             (map-alist-vals func (cdr list)))))
 349
 350 (define (map-alist-keys func list)
 351   "map FUNC over the keys of an alist LIST, leaving the vals."
 352   (if (null?  list)
 353       '()
 354       (cons (cons (func (caar list)) (cdar list))
 355             (map-alist-keys func (cdr list)))))
 356
 357 (define-public (first-member members lst)
 358   "Return first successful member (of member) from @var{members} in
 359 @var{lst}."
 360   (if (null? members)
 361       #f
 362       (let ((m (member (car members) lst)))
 363         (if m m (first-member (cdr members) lst)))))
 364
 365 (define-public (first-assoc keys lst)
 366   "Return first successful assoc of key from @var{keys} in @var{lst}."
 367   (if (null? keys)
 368       #f
 369       (let ((k (assoc (car keys) lst)))
 370         (if k k (first-assoc (cdr keys) lst)))))
 371
 372 (define-public (flatten-alist alist)
 373   (if (null? alist)
 374       '()
 375       (cons (caar alist)
 376             (cons (cdar alist)
 377                   (flatten-alist (cdr alist))))))
 378
 379 (define (assoc-remove key alist)
 380   "Remove key (and its corresponding value) from an alist.
 381    Different than assoc-remove! because it is non-destructive."
 382   (define (assoc-crawler key l r)
 383     (if (null? r)
 384         l
 385         (if (equal? (caar r) key)
 386             (append l (cdr r))
 387             (assoc-crawler key (append l `(,(car r))) (cdr r)))))
 388   (assoc-crawler key '() alist))
 389
 390 (define-public (map-selected-alist-keys function keys alist)
 391   "Return @var{alist} with @var{function} applied to all of the values
 392 in list @var{keys}.
 393
 394 For example:
 395 @example
 396 @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
 397 @code{((a . -1) (b . 2) (c . 3) (d . 4)}
 398 @end example"
 399    (define (map-selected-alist-keys-helper function key alist)
 400      (map
 401      (lambda (pair)
 402        (if (equal? key (car pair))
 403            (cons key (function (cdr pair)))
 404            pair))
 405      alist))
 406    (if (null? keys)
 407        alist
 408        (map-selected-alist-keys
 409          function
 410          (cdr keys)
 411          (map-selected-alist-keys-helper function (car keys) alist))))
 412
 413 ;;;;;;;;;;;;;;;;
 414 ;; vector
 415
 416 (define-public (vector-for-each proc vec)
 417   (do
 418       ((i 0 (1+ i)))
 419       ((>= i (vector-length vec)) vec)
 420     (vector-set! vec i (proc (vector-ref vec i)))))
 421
 422 ;;;;;;;;;;;;;;;;
 423 ;; hash
 424
 425 (define-public (hash-table->alist t)
 426   (hash-fold (lambda (k v acc) (acons  k v  acc))
 427              '() t))
 428
 429 ;; todo: code dup with C++.
 430 (define-safe-public (alist->hash-table lst)
 431   "Convert alist to table"
 432   (let ((m (make-hash-table (length lst))))
 433     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 434     m))
 435
 436 ;;;;;;;;;;;;;;;;
 437 ;; list
 438
 439 (define (functional-or . rest)
 440   (if (pair? rest)
 441       (or (car rest)
 442            (apply functional-or (cdr rest)))
 443       #f))
 444
 445 (define (functional-and . rest)
 446   (if (pair? rest)
 447       (and (car rest)
 448            (apply functional-and (cdr rest)))
 449       #t))
 450
 451 (define (split-list lst n)
 452   "Split LST in N equal sized parts"
 453
 454   (define (helper todo acc-vector k)
 455     (if (null? todo)
 456         acc-vector
 457         (begin
 458           (if (< k 0)
 459               (set! k (+ n k)))
 460
 461           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 462           (helper (cdr todo) acc-vector (1- k)))))
 463
 464   (helper lst (make-vector n '()) (1- n)))
 465
 466 (define (list-element-index lst x)
 467   (define (helper todo k)
 468     (cond
 469      ((null? todo) #f)
 470      ((equal? (car todo) x) k)
 471      (else
 472       (helper (cdr todo) (1+ k)))))
 473
 474   (helper lst 0))
 475
 476 (define-public (count-list lst)
 477   "Given @var{lst} as @code{(E1 E2 .. )}, return
 478 @code{((E1 . 1) (E2 . 2) ... )}."
 479
 480   (define (helper l acc count)
 481     (if (pair? l)
 482         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 483         acc))
 484
 485
 486   (reverse (helper lst '() 1)))
 487
 488 (define-public (list-join lst intermediate)
 489   "Put @var{intermediate} between all elts of @var{lst}."
 490
 491   (fold-right
 492    (lambda (elem prev)
 493             (if (pair? prev)
 494                 (cons  elem (cons intermediate prev))
 495                 (list elem)))
 496           '() lst))
 497
 498 (define-public (filtered-map proc lst)
 499   (filter
 500    (lambda (x) x)
 501    (map proc lst)))
 502
 503 (define-public (flatten-list x)
 504   "Unnest list."
 505   (cond ((null? x) '())
 506         ((not (pair? x)) (list x))
 507         (else (append (flatten-list (car x))
 508                       (flatten-list (cdr x))))))
 509
 510 (define (list-minus a b)
 511   "Return list of elements in A that are not in B."
 512   (lset-difference eq? a b))
 513
 514 (define-public (uniq-list lst)
 515   "Uniq @var{lst}, assuming that it is sorted.  Uses @code{equal?}
 516 for comparisons."
 517
 518   (reverse!
 519    (fold (lambda (x acc)
 520            (if (null? acc)
 521                (list x)
 522                (if (equal? x (car acc))
 523                    acc
 524                    (cons x acc))))
 525          '() lst) '()))
 526
 527 (define (split-at-predicate pred lst)
 528   "Split LST into two lists at the first element that returns #f for
 529   (PRED previous_element element).  Return the two parts as a pair.
 530   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 531   (if (null? lst)
 532       (list lst)
 533       (let ((i (list-index (lambda (x y) (not (pred x y)))
 534                            lst
 535                            (cdr lst))))
 536         (if i
 537             (cons (take lst (1+ i)) (drop lst (1+ i)))
 538             (list lst)))))
 539
 540 (define-public (split-list-by-separator lst pred)
 541   "Split @var{lst} at each element that satisfies @var{pred}, and return
 542 the parts (with the separators removed) as a list of lists.  For example,
 543 executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns
 544 @samp{((a) (b c) (d))}."
 545   (let loop ((result '()) (lst lst))
 546     (if (and lst (not (null? lst)))
 547         (loop
 548           (append result
 549                   (list (take-while (lambda (x) (not (pred x))) lst)))
 550           (let ((tail (find-tail pred lst)))
 551             (if tail (cdr tail) #f)))
 552        result)))
 553
 554 (define-public (offset-add a b)
 555   (cons (+ (car a) (car b))
 556         (+ (cdr a) (cdr b))))
 557
 558 (define-public (offset-flip-y o)
 559   (cons (car o) (- (cdr o))))
 560
 561 (define-public (offset-scale o scale)
 562   (cons (* (car o) scale)
 563         (* (cdr o) scale)))
 564
 565 (define-public (ly:list->offsets accum coords)
 566   (if (null? coords)
 567       accum
 568       (cons (cons (car coords) (cadr coords))
 569             (ly:list->offsets accum (cddr coords)))))
 570
 571 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 572 ;; intervals
 573
 574 (define-public empty-interval '(+inf.0 . -inf.0))
 575
 576 (define-public (symmetric-interval expr)
 577   (cons (- expr) expr))
 578
 579 (define-public (interval-length x)
 580   "Length of the number-pair @var{x}, if an interval."
 581   (max 0 (- (cdr x) (car x))))
 582
 583 (define-public (ordered-cons a b)
 584   (cons (min a b)
 585         (max a b)))
 586
 587 (define-public (interval-bound interval dir)
 588   ((if (= dir RIGHT) cdr car) interval))
 589
 590 (define-public (interval-index interval dir)
 591   "Interpolate @var{interval} between between left (@var{dir}=-1) and
 592 right (@var{dir}=+1)."
 593
 594   (* (+  (interval-start interval) (interval-end interval)
 595          (* dir (- (interval-end interval) (interval-start interval))))
 596      0.5))
 597
 598 (define-public (interval-center x)
 599   "Center the number-pair @var{x}, if an interval."
 600   (if (interval-empty? x)
 601       0.0
 602       (/ (+ (car x) (cdr x)) 2)))
 603
 604 (define-public interval-start car)
 605
 606 (define-public interval-end cdr)
 607
 608 (define (other-axis a)
 609   (remainder (+ a 1) 2))
 610
 611 (define-public (interval-widen iv amount)
 612   (cons (- (car iv) amount)
 613     (+ (cdr iv) amount)))
 614
 615 (define-public (interval-empty? iv)
 616    (> (car iv) (cdr iv)))
 617
 618 (define-public (interval-union i1 i2)
 619   (cons
 620     (min (car i1) (car i2))
 621     (max (cdr i1) (cdr i2))))
 622
 623 (define-public (interval-intersection i1 i2)
 624    (cons
 625      (max (car i1) (car i2))
 626      (min (cdr i1) (cdr i2))))
 627
 628 (define-public (interval-sane? i)
 629   (not (or  (nan? (car i))
 630             (inf? (car i))
 631             (nan? (cdr i))
 632             (inf? (cdr i))
 633             (> (car i) (cdr i)))))
 634
 635 (define-public (add-point interval p)
 636   (cons (min (interval-start interval) p)
 637         (max (interval-end interval) p)))
 638
 639 (define-public (reverse-interval iv)
 640   (cons (cdr iv) (car iv)))
 641
 642 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 643 ;; coordinates
 644
 645 (define coord-x car)
 646 (define coord-y cdr)
 647
 648 (define (coord-operation operator operand coordinate)
 649   (if (pair? operand)
 650     (cons (operator (coord-x operand) (coord-x coordinate))
 651           (operator (coord-y operand) (coord-y coordinate)))
 652     (cons (operator operand (coord-x coordinate))
 653           (operator operand (coord-y coordinate)))))
 654
 655 (define (coord-apply function coordinate)
 656   (if (pair? function)
 657     (cons
 658       ((coord-x function) (coord-x coordinate))
 659       ((coord-y function) (coord-y coordinate)))
 660     (cons
 661       (function (coord-x coordinate))
 662       (function (coord-y coordinate)))))
 663
 664 (define-public (coord-translate coordinate amount)
 665   (coord-operation + amount coordinate))
 666
 667 (define-public (coord-scale coordinate amount)
 668   (coord-operation * amount coordinate))
 669
 670 (define-public (coord-rotate coordinate degrees-in-radians)
 671   (let*
 672     ((coordinate
 673       (cons
 674         (exact->inexact (coord-x coordinate))
 675         (exact->inexact (coord-y coordinate))))
 676      (radius
 677       (sqrt
 678         (+ (* (coord-x coordinate) (coord-x coordinate))
 679            (* (coord-y coordinate) (coord-y coordinate)))))
 680     (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
 681    (cons
 682      (* radius (cos (+ angle degrees-in-radians)))
 683      (* radius (sin (+ angle degrees-in-radians))))))
 684
 685 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 686 ;; trig
 687
 688 (define-public PI (* 4 (atan 1)))
 689
 690 (define-public TWO-PI (* 2 PI))
 691
 692 (define-public PI-OVER-TWO (/ PI 2))
 693
 694 (define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
 695
 696 (define-public (cyclic-base-value value cycle)
 697   "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
 698   (if (< value 0)
 699       (cyclic-base-value (+ value cycle) cycle)
 700       (if (>= value cycle)
 701           (cyclic-base-value (- value cycle) cycle)
 702           value)))
 703
 704 (define-public (angle-0-2pi angle)
 705   "Take @var{angle} (in radians) and maps it between 0 and 2pi."
 706   (cyclic-base-value angle TWO-PI))
 707
 708 (define-public (angle-0-360 angle)
 709   "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
 710   (cyclic-base-value angle 360.0))
 711
 712 (define-public PI-OVER-180  (/ PI 180))
 713
 714 (define-public (degrees->radians angle-degrees)
 715   "Convert the given angle from degrees to radians."
 716   (* angle-degrees PI-OVER-180))
 717
 718 (define-public (ellipse-radius x-radius y-radius angle)
 719   (/
 720     (* x-radius y-radius)
 721     (sqrt
 722       (+ (* (expt y-radius 2)
 723             (* (cos angle) (cos angle)))
 724         (* (expt x-radius 2)
 725            (* (sin angle) (sin angle)))))))
 726
 727 (define-public (polar->rectangular radius angle-in-degrees)
 728   "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
 729 as rectangular coordinates @ode{(x-length . y-length)}."
 730
 731   (let ((complex (make-polar
 732                     radius
 733                     (degrees->radians angle-in-degrees))))
 734      (cons
 735        (real-part complex)
 736        (imag-part complex))))
 737
 738 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 739 ;; string
 740
 741 (define-public (string-endswith s suffix)
 742   (equal? suffix (substring s
 743                             (max 0 (- (string-length s) (string-length suffix)))
 744                             (string-length s))))
 745
 746 (define-public (string-startswith s prefix)
 747   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 748
 749 (define-public (string-encode-integer i)
 750   (cond
 751    ((= i  0) "o")
 752    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 753    (else (string-append
 754           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 755           (string-encode-integer (quotient i 26))))))
 756
 757 (define (number->octal-string x)
 758   (let* ((n (inexact->exact x))
 759          (n64 (quotient n 64))
 760          (n8 (quotient (- n (* n64 64)) 8)))
 761     (string-append
 762      (number->string n64)
 763      (number->string n8)
 764      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 765
 766 (define-public (ly:inexact->string x radix)
 767   (let ((n (inexact->exact x)))
 768     (number->string n radix)))
 769
 770 (define-public (ly:number-pair->string c)
 771   (string-append (ly:number->string (car c)) " "
 772                  (ly:number->string (cdr c))))
 773
 774 (define-public (dir-basename file . rest)
 775   "Strip suffixes in @var{rest}, but leave directory component for
 776 @var{file}."
 777   (define (inverse-basename x y) (basename y x))
 778   (simple-format #f "~a/~a" (dirname file)
 779                  (fold inverse-basename file rest)))
 780
 781 (define-public (write-me message x)
 782   "Return @var{x}.  Display @var{message} and write @var{x}.
 783 Handy for debugging, possibly turned off."
 784   (display message) (write x) (newline) x)
 785 ;;  x)
 786
 787 (define-public (stderr string . rest)
 788   (apply format (cons (current-error-port) (cons string rest)))
 789   (force-output (current-error-port)))
 790
 791 (define-public (debugf string . rest)
 792   (if #f
 793       (apply stderr (cons string rest))))
 794
 795 (define (index-cell cell dir)
 796   (if (equal? dir 1)
 797       (cdr cell)
 798       (car cell)))
 799
 800 (define (cons-map f x)
 801   "map F to contents of X"
 802   (cons (f (car x)) (f (cdr x))))
 803
 804 (define-public (list-insert-separator lst between)
 805   "Create new list, inserting @var{between} between elements of @var{lst}."
 806   (define (conc x y )
 807     (if (eq? y #f)
 808         (list x)
 809         (cons x  (cons between y))))
 810   (fold-right conc #f lst))
 811
 812 (define-public (string-regexp-substitute a b str)
 813   (regexp-substitute/global #f a str 'pre b 'post))
 814
 815 (define (regexp-split str regex)
 816   (define matches '())
 817   (define end-of-prev-match 0)
 818   (define (notice match)
 819
 820     (set! matches (cons (substring (match:string match)
 821                                    end-of-prev-match
 822                                    (match:start match))
 823                         matches))
 824     (set! end-of-prev-match (match:end match)))
 825
 826   (regexp-substitute/global #f regex str notice 'post)
 827
 828   (if (< end-of-prev-match (string-length str))
 829       (set!
 830        matches
 831        (cons (substring str end-of-prev-match (string-length str)) matches)))
 832
 833    (reverse matches))
 834
 835 ;;;;;;;;;;;;;;;;
 836 ;; other
 837
 838 (define (sign x)
 839   (if (= x 0)
 840       0
 841       (if (< x 0) -1 1)))
 842
 843 (define-public (binary-search start end getter target-val)
 844   (_i "Find the index between @var{start} and @var{end} (an integer)
 845 which produces the closest match to @var{target-val} if
 846 applied to function @var{getter}.")
 847   (if (<= end start)
 848       start
 849       (let* ((compare (quotient (+ start end) 2))
 850              (get-val (getter compare)))
 851         (cond
 852          ((< target-val get-val)
 853           (set! end (1- compare)))
 854          ((< get-val target-val)
 855           (set! start (1+ compare))))
 856         (binary-search start end getter target-val))))
 857
 858 (define-public (car< a b)
 859   (< (car a) (car b)))
 860
 861 (define-public (car<= a b)
 862   (<= (car a) (car b)))
 863
 864 (define-public (symbol<? lst r)
 865   (string<? (symbol->string lst) (symbol->string r)))
 866
 867 (define-public (symbol-key<? lst r)
 868   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 869
 870 (define-public (eval-carefully symbol module . default)
 871   "Check whether all symbols in expr @var{symbol} are reachable
 872 in module @var{module}.  In that case evaluate, otherwise
 873 print a warning and set an optional @var{default}."
 874   (let* ((unavailable? (lambda (sym)
 875                          (not (module-defined? module sym))))
 876          (sym-unavailable (if (pair? symbol)
 877                               (filter
 878                                 unavailable?
 879                                 (filter symbol? (flatten-list symbol)))
 880                               (if (unavailable? symbol)
 881                                    #t
 882                                    '()))))
 883     (if (null? sym-unavailable)
 884         (eval symbol module)
 885         (let* ((def (and (pair? default) (car default))))
 886           (ly:programming-error
 887             "cannot evaluate ~S in module ~S, setting to ~S"
 888             (object->string symbol)
 889             (object->string module)
 890             (object->string def))
 891           def))))
 892
 893 ;;
 894 ;; don't confuse users with #<procedure .. > syntax.
 895 ;;
 896 (define-public (scm->string val)
 897   (if (and (procedure? val)
 898            (symbol? (procedure-name val)))
 899       (symbol->string (procedure-name val))
 900       (string-append
 901        (if (self-evaluating? val)
 902            (if (string? val)
 903                "\""
 904                "")
 905            "'")
 906        (call-with-output-string (lambda (port) (display val port)))
 907        (if (string? val)
 908            "\""
 909            ""))))
 910
 911 (define-public (!= lst r)
 912   (not (= lst r)))
 913
 914 (define-public lily-unit->bigpoint-factor
 915   (cond
 916    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 917    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 918    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 919
 920 (define-public lily-unit->mm-factor
 921   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 922
 923 ;;; FONT may be font smob, or pango font string...
 924 (define-public (font-name-style font)
 925   (if (string? font)
 926       (string-downcase font)
 927       (let* ((font-name (ly:font-name font))
 928              (full-name (if font-name font-name (ly:font-file-name font))))
 929           (string-downcase full-name))))
 930
 931 (define-public (modified-font-metric-font-scaling font)
 932   (let* ((designsize (ly:font-design-size font))
 933          (magnification (* (ly:font-magnification font)))
 934          (scaling (* magnification designsize)))
 935     (debugf "scaling:~S\n" scaling)
 936     (debugf "magnification:~S\n" magnification)
 937     (debugf "design:~S\n" designsize)
 938     scaling))
 939
 940 (define-public (version-not-seen-message input-file-name)
 941   (ly:warning-located
 942     (ly:format "~a:0" input-file-name)
 943     (_ "no \\version statement found, please add~afor future compatibility")
 944     (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
 945
 946 (define-public (old-relative-not-used-message input-file-name)
 947   (ly:warning-located
 948     (ly:format "~a:0" input-file-name)
 949     (_ "old relative compatibility not used")))