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