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