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