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