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