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 ;; durations
  83
  84 (define-public (duration-log-factor lognum)
  85 "Given a logarithmic duration number, return the length of the duration,
  86 as a number of whole notes."
  87   (or (and (exact? lognum) (integer? lognum))
  88     (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f))
  89   (if (<= lognum 0)
  90     (ash 1 (- lognum))
  91     (/ (ash 1 lognum))))
  92
  93 (define-public (duration-dot-factor dotcount)
  94 "Given a count of the dots used to extend a musical duration, return
  95 the numeric factor by which they increase the duration."
  96   (or (and (exact? dotcount) (integer? dotcount) (>= dotcount 0))
  97     (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f))
  98   (- 2 (/ (ash 1 dotcount))))
  99
 100 (define-public (duration-length dur)
 101 "Return the overall length of a duration, as a number of whole notes.
 102 (Not to be confused with ly:duration-length, which returns a less-useful
 103 moment object.)"
 104   (ly:moment-main (ly:duration-length dur)))
 105
 106 (define-public (duration-visual dur)
 107 "Given a duration object, return the visual part of the duration (base
 108 note length and dot count), in the form of a duration object with
 109 non-visual scale factor 1."
 110   (ly:make-duration (ly:duration-log dur) (ly:duration-dot-count dur) 1))
 111
 112 (define-public (duration-visual-length dur)
 113 "Given a duration object, return the length of the visual part of the
 114 duration (base note length and dot count), as a number of whole notes."
 115   (duration-length (duration-visual dur)))
 116
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118 ;; arithmetic
 119 (define-public (average x . lst)
 120   (/ (+ x (apply + lst)) (1+ (length lst))))
 121
 122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 123 ;; parser <-> output hooks.
 124
 125 (define-public (collect-bookpart-for-book parser book-part)
 126   "Toplevel book-part handler."
 127   (define (add-bookpart book-part)
 128     (ly:parser-define!
 129        parser 'toplevel-bookparts
 130        (cons book-part (ly:parser-lookup parser 'toplevel-bookparts))))
 131   ;; If toplevel scores have been found before this \bookpart,
 132   ;; add them first to a dedicated bookpart
 133   (if (pair? (ly:parser-lookup parser 'toplevel-scores))
 134       (begin
 135         (add-bookpart (ly:make-book-part
 136                        (ly:parser-lookup parser 'toplevel-scores)))
 137         (ly:parser-define! parser 'toplevel-scores (list))))
 138   (add-bookpart book-part))
 139
 140 (define-public (collect-scores-for-book parser score)
 141   (ly:parser-define!
 142    parser 'toplevel-scores
 143    (cons score (ly:parser-lookup parser 'toplevel-scores))))
 144
 145 (define-public (collect-music-aux score-handler parser music)
 146   (define (music-property symbol)
 147     (let ((value (ly:music-property music symbol)))
 148       (if (not (null? value))
 149           value
 150           #f)))
 151   (cond ((music-property 'page-marker)
 152          ;; a page marker: set page break/turn permissions or label
 153          (begin
 154            (let ((label (music-property 'page-label)))
 155              (if (symbol? label)
 156                  (score-handler (ly:make-page-label-marker label))))
 157            (for-each (lambda (symbol)
 158                        (let ((permission (music-property symbol)))
 159                          (if (symbol? permission)
 160                              (score-handler
 161                               (ly:make-page-permission-marker symbol
 162                                                               (if (eqv? 'forbid permission)
 163                                                                   '()
 164                                                                   permission))))))
 165                      (list 'line-break-permission 'page-break-permission
 166                            'page-turn-permission))))
 167         ((not (music-property 'void))
 168          ;; a regular music expression: make a score with this music
 169          ;; void music is discarded
 170          (score-handler (scorify-music music parser)))))
 171
 172 (define-public (collect-music-for-book parser music)
 173   "Top-level music handler."
 174   (collect-music-aux (lambda (score)
 175                        (collect-scores-for-book parser score))
 176                      parser
 177                      music))
 178
 179 (define-public (collect-book-music-for-book parser book music)
 180   "Book music handler."
 181   (collect-music-aux (lambda (score)
 182                        (ly:book-add-score! book score))
 183                      parser
 184                      music))
 185
 186 (define-public (scorify-music music parser)
 187   "Preprocess @var{music}."
 188
 189   (for-each (lambda (func)
 190               (set! music (func music parser)))
 191             toplevel-music-functions)
 192
 193   (ly:make-score music))
 194
 195
 196 (define (get-current-filename parser book)
 197   "return any suffix value for output filename allowing for settings by
 198 calls to bookOutputName function"
 199   (let ((book-filename (paper-variable parser book 'output-filename)))
 200     (if (not book-filename)
 201         (ly:parser-output-name parser)
 202         book-filename)))
 203
 204 (define (get-current-suffix parser book)
 205   "return any suffix value for output filename allowing for settings by calls to
 206 bookoutput function"
 207   (let ((book-output-suffix (paper-variable parser book 'output-suffix)))
 208     (if (not (string? book-output-suffix))
 209         (ly:parser-lookup parser 'output-suffix)
 210         book-output-suffix)))
 211
 212 (define-public current-outfile-name #f)  ; for use by regression tests
 213
 214 (define (get-outfile-name parser book)
 215   "return current filename for generating backend output files"
 216   ;; user can now override the base file name, so we have to use
 217   ;; the file-name concatenated with any potential output-suffix value
 218   ;; as the key to out internal a-list
 219   (let* ((base-name (get-current-filename parser book))
 220          (output-suffix (get-current-suffix parser book))
 221          (alist-key (format #f "~a~a" base-name output-suffix))
 222          (counter-alist (ly:parser-lookup parser 'counter-alist))
 223          (output-count (assoc-get alist-key counter-alist 0))
 224          (result base-name))
 225     ;; Allow all ASCII alphanumerics, including accents
 226     (if (string? output-suffix)
 227         (set! result
 228               (format #f "~a-~a"
 229                       result
 230                       (string-regexp-substitute
 231                        "[^-[:alnum:]]"
 232                        "_"
 233                        output-suffix))))
 234
 235     ;; assoc-get call will always have returned a number
 236     (if (> output-count 0)
 237         (set! result (format #f "~a-~a" result output-count)))
 238
 239     (ly:parser-define!
 240      parser 'counter-alist
 241      (assoc-set! counter-alist alist-key (1+ output-count)))
 242     (set! current-outfile-name result)
 243     result))
 244
 245 (define (print-book-with parser book process-procedure)
 246   (let* ((paper (ly:parser-lookup parser '$defaultpaper))
 247          (layout (ly:parser-lookup parser '$defaultlayout))
 248          (outfile-name (get-outfile-name parser book)))
 249     (process-procedure book paper layout outfile-name)))
 250
 251 (define-public (print-book-with-defaults parser book)
 252   (print-book-with parser book ly:book-process))
 253
 254 (define-public (print-book-with-defaults-as-systems parser book)
 255   (print-book-with parser book ly:book-process-to-systems))
 256
 257 ;; Add a score to the current bookpart, book or toplevel
 258 (define-public (add-score parser score)
 259     (cond
 260       ((ly:parser-lookup parser '$current-bookpart)
 261           ((ly:parser-lookup parser 'bookpart-score-handler)
 262                 (ly:parser-lookup parser '$current-bookpart) score))
 263       ((ly:parser-lookup parser '$current-book)
 264           ((ly:parser-lookup parser 'book-score-handler)
 265                 (ly:parser-lookup parser '$current-book) score))
 266       (else
 267           ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
 268
 269 (define-public paper-variable
 270   (let
 271       ((get-papers
 272         (lambda (parser book)
 273           (append (if (and book (ly:output-def? (ly:book-paper book)))
 274                       (list (ly:book-paper book))
 275                       '())
 276                   (ly:parser-lookup parser '$papers)
 277                   (list (ly:parser-lookup parser '$defaultpaper))))))
 278     (make-procedure-with-setter
 279      (lambda (parser book symbol)
 280        (any (lambda (p) (ly:output-def-lookup p symbol #f))
 281             (get-papers parser book)))
 282      (lambda (parser book symbol value)
 283        (ly:output-def-set-variable!
 284         (car (get-papers parser book))
 285         symbol value)))))
 286
 287 (define-public (add-text parser text)
 288   (add-score parser (list text)))
 289
 290 (define-public (add-music parser music)
 291   (collect-music-aux (lambda (score)
 292                        (add-score parser score))
 293                      parser
 294                      music))
 295
 296 (define-public (context-mod-from-music parser music)
 297   (let ((warn #t) (mods (ly:make-context-mod)))
 298     (let loop ((m music))
 299       (if (music-is-of-type? m 'layout-instruction-event)
 300           (let ((symbol (ly:music-property m 'symbol)))
 301             (ly:add-context-mod
 302              mods
 303              (case (ly:music-property m 'name)
 304                ((PropertySet)
 305                 (list 'assign
 306                       symbol
 307                       (ly:music-property m 'value)))
 308                ((PropertyUnset)
 309                 (list 'unset symbol))
 310                ((OverrideProperty)
 311                 (cons* 'push
 312                        symbol
 313                        (ly:music-property m 'grob-value)
 314                        (cond
 315                         ((ly:music-property m 'grob-property #f) => list)
 316                         (else
 317                          (ly:music-property m 'grob-property-path)))))
 318                ((RevertProperty)
 319                 (cons* 'pop
 320                        symbol
 321                        (cond
 322                         ((ly:music-property m 'grob-property #f) => list)
 323                         (else
 324                          (ly:music-property m 'grob-property-path))))))))
 325           (case (ly:music-property m 'name)
 326             ((ApplyContext)
 327              (ly:add-context-mod mods
 328                                  (list 'apply
 329                                        (ly:music-property m 'procedure))))
 330             ((ContextSpeccedMusic)
 331              (loop (ly:music-property m 'element)))
 332             (else
 333              (let ((callback (ly:music-property m 'elements-callback)))
 334                (if (procedure? callback)
 335                    (for-each loop (callback m))
 336                    (if (and warn (ly:duration? (ly:music-property m 'duration)))
 337                        (begin
 338                          (ly:music-warning
 339                           music
 340                           (_ "Music unsuitable for context-mod"))
 341                          (set! warn #f)))))))))
 342     mods))
 343
 344 (define-public (context-defs-from-music parser output-def music)
 345   (let ((warn #t))
 346     (let loop ((m music) (mods #f))
 347       ;; The parser turns all sets, overrides etc into something
 348       ;; wrapped in ContextSpeccedMusic.  If we ever get a set,
 349       ;; override etc that is not wrapped in ContextSpeccedMusic, the
 350       ;; user has created it in Scheme himself without providing the
 351       ;; required wrapping.  In that case, using #f in the place of a
 352       ;; context modification results in a reasonably recognizable
 353       ;; error.
 354       (if (music-is-of-type? m 'layout-instruction-event)
 355           (ly:add-context-mod
 356            mods
 357            (case (ly:music-property m 'name)
 358              ((PropertySet)
 359               (list 'assign
 360                     (ly:music-property m 'symbol)
 361                     (ly:music-property m 'value)))
 362              ((PropertyUnset)
 363               (list 'unset
 364                     (ly:music-property m 'symbol)))
 365              ((OverrideProperty)
 366               (cons* 'push
 367                      (ly:music-property m 'symbol)
 368                      (ly:music-property m 'grob-value)
 369                      (cond
 370                       ((ly:music-property m 'grob-property #f) => list)
 371                       (else
 372                        (ly:music-property m 'grob-property-path)))))
 373              ((RevertProperty)
 374               (cons* 'pop
 375                      (ly:music-property m 'symbol)
 376                      (cond
 377                       ((ly:music-property m 'grob-property #f) => list)
 378                       (else
 379                        (ly:music-property m 'grob-property-path)))))))
 380           (case (ly:music-property m 'name)
 381             ((ApplyContext)
 382              (ly:add-context-mod mods
 383                                  (list 'apply
 384                                        (ly:music-property m 'procedure))))
 385             ((ContextSpeccedMusic)
 386              ;; Use let* here to let defs catch up with modifications
 387              ;; to the context defs made in the recursion
 388              (let* ((mods (loop (ly:music-property m 'element)
 389                                 (ly:make-context-mod)))
 390                     (defs (ly:output-find-context-def
 391                            output-def (ly:music-property m 'context-type))))
 392                (if (null? defs)
 393                    (ly:music-warning
 394                     music
 395                     (ly:format (_ "Cannot find context-def \\~a")
 396                                (ly:music-property m 'context-type)))
 397                    (for-each
 398                     (lambda (entry)
 399                       (ly:output-def-set-variable!
 400                        output-def (car entry)
 401                        (ly:context-def-modify (cdr entry) mods)))
 402                     defs))))
 403             (else
 404              (let ((callback (ly:music-property m 'elements-callback)))
 405                (if (procedure? callback)
 406                    (fold loop mods (callback m))
 407                    (if (and warn (ly:duration? (ly:music-property m 'duration)))
 408                        (begin
 409                          (ly:music-warning
 410                           music
 411                           (_ "Music unsuitable for output-def"))
 412                          (set! warn #f))))))))
 413       mods)))
 414
 415
 416 ;;;;;;;;;;;;;;;;
 417 ;; alist
 418
 419 (define-public assoc-get ly:assoc-get)
 420
 421 (define-public chain-assoc-get ly:chain-assoc-get)
 422
 423 (define-public (uniqued-alist alist acc)
 424   (if (null? alist) acc
 425       (if (assoc (caar alist) acc)
 426           (uniqued-alist (cdr alist) acc)
 427           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 428
 429 (define-public (alist<? x y)
 430   (string<? (symbol->string (car x))
 431             (symbol->string (car y))))
 432
 433 (define (map-alist-vals func list)
 434   "map FUNC over the vals of  LIST, leaving the keys."
 435   (if (null?  list)
 436       '()
 437       (cons (cons  (caar list) (func (cdar list)))
 438             (map-alist-vals func (cdr list)))))
 439
 440 (define (map-alist-keys func list)
 441   "map FUNC over the keys of an alist LIST, leaving the vals."
 442   (if (null?  list)
 443       '()
 444       (cons (cons (func (caar list)) (cdar list))
 445             (map-alist-keys func (cdr list)))))
 446
 447 (define-public (first-member members lst)
 448   "Return first successful member (of member) from @var{members} in
 449 @var{lst}."
 450   (any (lambda (m) (member m lst)) members))
 451
 452 (define-public (first-assoc keys lst)
 453   "Return first successful assoc of key from @var{keys} in @var{lst}."
 454   (any (lambda (k) (assoc k lst)) keys))
 455
 456 (define-public (flatten-alist alist)
 457   (if (null? alist)
 458       '()
 459       (cons (caar alist)
 460             (cons (cdar alist)
 461                   (flatten-alist (cdr alist))))))
 462
 463 (define (assoc-remove key alist)
 464   "Remove key (and its corresponding value) from an alist.
 465    Different than assoc-remove! because it is non-destructive."
 466   (define (assoc-crawler key l r)
 467     (if (null? r)
 468         l
 469         (if (equal? (caar r) key)
 470             (append l (cdr r))
 471             (assoc-crawler key (append l `(,(car r))) (cdr r)))))
 472   (assoc-crawler key '() alist))
 473
 474 (define-public (map-selected-alist-keys function keys alist)
 475   "Return @var{alist} with @var{function} applied to all of the values
 476 in list @var{keys}.
 477
 478 For example:
 479 @example
 480 @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
 481 @code{((a . -1) (b . 2) (c . 3) (d . 4)}
 482 @end example"
 483    (define (map-selected-alist-keys-helper function key alist)
 484      (map
 485      (lambda (pair)
 486        (if (equal? key (car pair))
 487            (cons key (function (cdr pair)))
 488            pair))
 489      alist))
 490    (if (null? keys)
 491        alist
 492        (map-selected-alist-keys
 493          function
 494          (cdr keys)
 495          (map-selected-alist-keys-helper function (car keys) alist))))
 496
 497 ;;;;;;;;;;;;;;;;
 498 ;; vector
 499
 500 (define-public (vector-for-each proc vec)
 501   (do
 502       ((i 0 (1+ i)))
 503       ((>= i (vector-length vec)) vec)
 504     (vector-set! vec i (proc (vector-ref vec i)))))
 505
 506 ;;;;;;;;;;;;;;;;
 507 ;; hash
 508
 509 (define-public (hash-table->alist t)
 510   (hash-fold acons '() t))
 511
 512 ;; todo: code dup with C++.
 513 (define-safe-public (alist->hash-table lst)
 514   "Convert alist to table"
 515   (let ((m (make-hash-table (length lst))))
 516     (for-each (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 517     m))
 518
 519 ;;;;;;;;;;;;;;;;
 520 ;; list
 521
 522 (define (functional-or . rest)
 523   (any identity rest))
 524
 525 (define (functional-and . rest)
 526   (every identity rest))
 527
 528 (define (split-list lst n)
 529   "Split LST in N equal sized parts"
 530
 531   (define (helper todo acc-vector k)
 532     (if (null? todo)
 533         acc-vector
 534         (begin
 535           (if (< k 0)
 536               (set! k (+ n k)))
 537
 538           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 539           (helper (cdr todo) acc-vector (1- k)))))
 540
 541   (helper lst (make-vector n '()) (1- n)))
 542
 543 (define (list-element-index lst x)
 544   (list-index (lambda (m) (equal? m x)) lst))
 545
 546 (define-public (count-list lst)
 547   "Given @var{lst} as @code{(E1 E2 .. )}, return
 548 @code{((E1 . 1) (E2 . 2) ... )}."
 549   (map cons lst (iota (length lst) 1)))
 550
 551 (define-public (list-join lst intermediate)
 552   "Put @var{intermediate} between all elts of @var{lst}."
 553
 554   (fold-right
 555    (lambda (elem prev)
 556             (if (pair? prev)
 557                 (cons  elem (cons intermediate prev))
 558                 (list elem)))
 559           '() lst))
 560
 561 (define-public (filtered-map proc lst)
 562   (filter
 563    (lambda (x) x)
 564    (map proc lst)))
 565
 566 (define-public (flatten-list x)
 567   "Unnest list."
 568   (cond ((null? x) '())
 569         ((not (pair? x)) (list x))
 570         (else (append (flatten-list (car x))
 571                       (flatten-list (cdr x))))))
 572
 573 (define (list-minus a b)
 574   "Return list of elements in A that are not in B."
 575   (lset-difference eq? a b))
 576
 577 (define-public (uniq-list lst)
 578   "Uniq @var{lst}, assuming that it is sorted.  Uses @code{equal?}
 579 for comparisons."
 580
 581   (reverse!
 582    (fold (lambda (x acc)
 583            (if (null? acc)
 584                (list x)
 585                (if (equal? x (car acc))
 586                    acc
 587                    (cons x acc))))
 588          '() lst) '()))
 589
 590 (define (split-at-predicate pred lst)
 591   "Split LST into two lists at the first element that returns #f for
 592   (PRED previous_element element).  Return the two parts as a pair.
 593   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 594   (if (null? lst)
 595       (list lst)
 596       (let ((i (list-index (lambda (x y) (not (pred x y)))
 597                            lst
 598                            (cdr lst))))
 599         (if i
 600             (cons (take lst (1+ i)) (drop lst (1+ i)))
 601             (list lst)))))
 602
 603 (define-public (split-list-by-separator lst pred)
 604   "Split @var{lst} at each element that satisfies @var{pred}, and return
 605 the parts (with the separators removed) as a list of lists.  For example,
 606 executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns
 607 @samp{((a) (b c) (d))}."
 608   (let loop ((result '()) (lst lst))
 609     (if (and lst (not (null? lst)))
 610         (loop
 611           (append result
 612                   (list (take-while (lambda (x) (not (pred x))) lst)))
 613           (let ((tail (find-tail pred lst)))
 614             (if tail (cdr tail) #f)))
 615        result)))
 616
 617 (define-public (offset-add a b)
 618   (cons (+ (car a) (car b))
 619         (+ (cdr a) (cdr b))))
 620
 621 (define-public (offset-flip-y o)
 622   (cons (car o) (- (cdr o))))
 623
 624 (define-public (offset-scale o scale)
 625   (cons (* (car o) scale)
 626         (* (cdr o) scale)))
 627
 628 (define-public (ly:list->offsets accum coords)
 629   (if (null? coords)
 630       accum
 631       (cons (cons (car coords) (cadr coords))
 632             (ly:list->offsets accum (cddr coords)))))
 633
 634 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 635 ;; intervals
 636
 637 (define-public empty-interval '(+inf.0 . -inf.0))
 638
 639 (define-public (symmetric-interval expr)
 640   (cons (- expr) expr))
 641
 642 (define-public (interval-length x)
 643   "Length of the number-pair @var{x}, if an interval."
 644   (max 0 (- (cdr x) (car x))))
 645
 646 (define-public (ordered-cons a b)
 647   (cons (min a b)
 648         (max a b)))
 649
 650 (define-public (interval-bound interval dir)
 651   ((if (= dir RIGHT) cdr car) interval))
 652
 653 (define-public (interval-index interval dir)
 654   "Interpolate @var{interval} between between left (@var{dir}=-1) and
 655 right (@var{dir}=+1)."
 656
 657   (* (+  (interval-start interval) (interval-end interval)
 658          (* dir (- (interval-end interval) (interval-start interval))))
 659      0.5))
 660
 661 (define-public (interval-center x)
 662   "Center the number-pair @var{x}, if an interval."
 663   (if (interval-empty? x)
 664       0.0
 665       (/ (+ (car x) (cdr x)) 2)))
 666
 667 (define-public interval-start car)
 668
 669 (define-public interval-end cdr)
 670
 671 (define (other-axis a)
 672   (remainder (+ a 1) 2))
 673
 674 (define-public (interval-scale iv factor)
 675   (cons (* (car iv) factor)
 676     (* (cdr iv) factor)))
 677
 678 (define-public (interval-widen iv amount)
 679   (cons (- (car iv) amount)
 680     (+ (cdr iv) amount)))
 681
 682 (define-public (interval-empty? iv)
 683    (> (car iv) (cdr iv)))
 684
 685 (define-public (interval-union i1 i2)
 686   (cons
 687     (min (car i1) (car i2))
 688     (max (cdr i1) (cdr i2))))
 689
 690 (define-public (interval-intersection i1 i2)
 691    (cons
 692      (max (car i1) (car i2))
 693      (min (cdr i1) (cdr i2))))
 694
 695 (define-public (interval-sane? i)
 696   (not (or  (nan? (car i))
 697             (inf? (car i))
 698             (nan? (cdr i))
 699             (inf? (cdr i))
 700             (> (car i) (cdr i)))))
 701
 702 (define-public (add-point interval p)
 703   (cons (min (interval-start interval) p)
 704         (max (interval-end interval) p)))
 705
 706 (define-public (reverse-interval iv)
 707   (cons (cdr iv) (car iv)))
 708
 709 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 710 ;; boolean
 711
 712 (define (lily-and a b)
 713   (and a b))
 714
 715 (define (lily-or a b)
 716   (or a b))
 717
 718 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 719 ;; coordinates
 720
 721 (define coord-x car)
 722 (define coord-y cdr)
 723
 724 (define (coord-operation operator operand coordinate)
 725   (if (pair? operand)
 726     (cons (operator (coord-x operand) (coord-x coordinate))
 727           (operator (coord-y operand) (coord-y coordinate)))
 728     (cons (operator operand (coord-x coordinate))
 729           (operator operand (coord-y coordinate)))))
 730
 731 (define (coord-apply function coordinate)
 732   (if (pair? function)
 733     (cons
 734       ((coord-x function) (coord-x coordinate))
 735       ((coord-y function) (coord-y coordinate)))
 736     (cons
 737       (function (coord-x coordinate))
 738       (function (coord-y coordinate)))))
 739
 740 (define-public (coord-translate coordinate amount)
 741   (coord-operation + amount coordinate))
 742
 743 (define-public (coord-scale coordinate amount)
 744   (coord-operation * amount coordinate))
 745
 746 (define-public (coord-rotate coordinate degrees-in-radians)
 747   (let*
 748     ((coordinate
 749       (cons
 750         (exact->inexact (coord-x coordinate))
 751         (exact->inexact (coord-y coordinate))))
 752      (radius
 753       (sqrt
 754         (+ (* (coord-x coordinate) (coord-x coordinate))
 755            (* (coord-y coordinate) (coord-y coordinate)))))
 756     (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
 757    (cons
 758      (* radius (cos (+ angle degrees-in-radians)))
 759      (* radius (sin (+ angle degrees-in-radians))))))
 760
 761 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 762 ;; trig
 763
 764 (define-public PI (* 4 (atan 1)))
 765
 766 (define-public TWO-PI (* 2 PI))
 767
 768 (define-public PI-OVER-TWO (/ PI 2))
 769
 770 (define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
 771
 772 (define-public (cyclic-base-value value cycle)
 773   "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
 774   (if (< value 0)
 775       (cyclic-base-value (+ value cycle) cycle)
 776       (if (>= value cycle)
 777           (cyclic-base-value (- value cycle) cycle)
 778           value)))
 779
 780 (define-public (angle-0-2pi angle)
 781   "Take @var{angle} (in radians) and maps it between 0 and 2pi."
 782   (cyclic-base-value angle TWO-PI))
 783
 784 (define-public (angle-0-360 angle)
 785   "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
 786   (cyclic-base-value angle 360.0))
 787
 788 (define-public PI-OVER-180  (/ PI 180))
 789
 790 (define-public (degrees->radians angle-degrees)
 791   "Convert the given angle from degrees to radians."
 792   (* angle-degrees PI-OVER-180))
 793
 794 (define-public (ellipse-radius x-radius y-radius angle)
 795   (/
 796     (* x-radius y-radius)
 797     (sqrt
 798       (+ (* (expt y-radius 2)
 799             (* (cos angle) (cos angle)))
 800         (* (expt x-radius 2)
 801            (* (sin angle) (sin angle)))))))
 802
 803 (define-public (polar->rectangular radius angle-in-degrees)
 804   "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
 805 as rectangular coordinates @ode{(x-length . y-length)}."
 806
 807   (let ((complex (make-polar
 808                     radius
 809                     (degrees->radians angle-in-degrees))))
 810      (cons
 811        (real-part complex)
 812        (imag-part complex))))
 813
 814 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 815 ;; string
 816
 817 (define-public (string-endswith s suffix)
 818   (equal? suffix (substring s
 819                             (max 0 (- (string-length s) (string-length suffix)))
 820                             (string-length s))))
 821
 822 (define-public (string-startswith s prefix)
 823   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 824
 825 (define-public (string-encode-integer i)
 826   (cond
 827    ((= i  0) "o")
 828    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 829    (else (string-append
 830           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 831           (string-encode-integer (quotient i 26))))))
 832
 833 (define (number->octal-string x)
 834   (let* ((n (inexact->exact x))
 835          (n64 (quotient n 64))
 836          (n8 (quotient (- n (* n64 64)) 8)))
 837     (string-append
 838      (number->string n64)
 839      (number->string n8)
 840      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 841
 842 (define-public (ly:inexact->string x radix)
 843   (let ((n (inexact->exact x)))
 844     (number->string n radix)))
 845
 846 (define-public (ly:number-pair->string c)
 847   (string-append (ly:number->string (car c)) " "
 848                  (ly:number->string (cdr c))))
 849
 850 (define-public (dir-basename file . rest)
 851   "Strip suffixes in @var{rest}, but leave directory component for
 852 @var{file}."
 853   (define (inverse-basename x y) (basename y x))
 854   (simple-format #f "~a/~a" (dirname file)
 855                  (fold inverse-basename file rest)))
 856
 857 (define-public (write-me message x)
 858   "Return @var{x}.  Display @var{message} and write @var{x}.
 859 Handy for debugging, possibly turned off."
 860   (display message) (write x) (newline) x)
 861 ;;  x)
 862
 863 (define-public (stderr string . rest)
 864   (apply format (cons (current-error-port) (cons string rest)))
 865   (force-output (current-error-port)))
 866
 867 (define-public (debugf string . rest)
 868   (if #f
 869       (apply stderr (cons string rest))))
 870
 871 (define (index-cell cell dir)
 872   (if (equal? dir 1)
 873       (cdr cell)
 874       (car cell)))
 875
 876 (define (cons-map f x)
 877   "map F to contents of X"
 878   (cons (f (car x)) (f (cdr x))))
 879
 880 (define-public (list-insert-separator lst between)
 881   "Create new list, inserting @var{between} between elements of @var{lst}."
 882   (define (conc x y )
 883     (if (eq? y #f)
 884         (list x)
 885         (cons x  (cons between y))))
 886   (fold-right conc #f lst))
 887
 888 (define-public (string-regexp-substitute a b str)
 889   (regexp-substitute/global #f a str 'pre b 'post))
 890
 891 (define (regexp-split str regex)
 892   (define matches '())
 893   (define end-of-prev-match 0)
 894   (define (notice match)
 895
 896     (set! matches (cons (substring (match:string match)
 897                                    end-of-prev-match
 898                                    (match:start match))
 899                         matches))
 900     (set! end-of-prev-match (match:end match)))
 901
 902   (regexp-substitute/global #f regex str notice 'post)
 903
 904   (if (< end-of-prev-match (string-length str))
 905       (set!
 906        matches
 907        (cons (substring str end-of-prev-match (string-length str)) matches)))
 908
 909    (reverse matches))
 910
 911 ;;;;;;;;;;;;;;;;
 912 ;; other
 913
 914 (define (sign x)
 915   (if (= x 0)
 916       0
 917       (if (< x 0) -1 1)))
 918
 919 (define-public (binary-search start end getter target-val)
 920   (_i "Find the index between @var{start} and @var{end} (an integer)
 921 which produces the closest match to @var{target-val} if
 922 applied to function @var{getter}.")
 923   (if (<= end start)
 924       start
 925       (let* ((compare (quotient (+ start end) 2))
 926              (get-val (getter compare)))
 927         (cond
 928          ((< target-val get-val)
 929           (set! end (1- compare)))
 930          ((< get-val target-val)
 931           (set! start (1+ compare))))
 932         (binary-search start end getter target-val))))
 933
 934 (define-public (car< a b)
 935   (< (car a) (car b)))
 936
 937 (define-public (car<= a b)
 938   (<= (car a) (car b)))
 939
 940 (define-public (symbol<? lst r)
 941   (string<? (symbol->string lst) (symbol->string r)))
 942
 943 (define-public (symbol-key<? lst r)
 944   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 945
 946 (define-public (eval-carefully symbol module . default)
 947   "Check whether all symbols in expr @var{symbol} are reachable
 948 in module @var{module}.  In that case evaluate, otherwise
 949 print a warning and set an optional @var{default}."
 950   (let* ((unavailable? (lambda (sym)
 951                          (not (module-defined? module sym))))
 952          (sym-unavailable (if (pair? symbol)
 953                               (filter
 954                                 unavailable?
 955                                 (filter symbol? (flatten-list symbol)))
 956                               (if (unavailable? symbol)
 957                                    #t
 958                                    '()))))
 959     (if (null? sym-unavailable)
 960         (eval symbol module)
 961         (let* ((def (and (pair? default) (car default))))
 962           (ly:programming-error
 963             "cannot evaluate ~S in module ~S, setting to ~S"
 964             (object->string symbol)
 965             (object->string module)
 966             (object->string def))
 967           def))))
 968
 969 ;;
 970 ;; don't confuse users with #<procedure .. > syntax.
 971 ;;
 972 (define-public (scm->string val)
 973   (if (and (procedure? val)
 974            (symbol? (procedure-name val)))
 975       (symbol->string (procedure-name val))
 976       (string-append
 977        (if (self-evaluating? val)
 978            (if (string? val)
 979                "\""
 980                "")
 981            "'")
 982        (call-with-output-string (lambda (port) (display val port)))
 983        (if (string? val)
 984            "\""
 985            ""))))
 986
 987 (define-public (!= lst r)
 988   (not (= lst r)))
 989
 990 (define-public lily-unit->bigpoint-factor
 991   (cond
 992    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 993    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 994    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 995
 996 (define-public lily-unit->mm-factor
 997   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 998
 999 ;;; FONT may be font smob, or pango font string...
1000 (define-public (font-name-style font)
1001   (if (string? font)
1002       (string-downcase font)
1003       (let* ((font-name (ly:font-name font))
1004              (full-name (if font-name font-name (ly:font-file-name font))))
1005           (string-downcase full-name))))
1006
1007 (define-public (modified-font-metric-font-scaling font)
1008   (let* ((designsize (ly:font-design-size font))
1009          (magnification (* (ly:font-magnification font)))
1010          (scaling (* magnification designsize)))
1011     (debugf "scaling:~S\n" scaling)
1012     (debugf "magnification:~S\n" magnification)
1013     (debugf "design:~S\n" designsize)
1014     scaling))
1015
1016 (define-public (version-not-seen-message input-file-name)
1017   (ly:warning-located
1018     (ly:format "~a:1" input-file-name)
1019     (_ "no \\version statement found, please add~afor future compatibility")
1020     (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
1021
1022 (define-public (old-relative-not-used-message input-file-name)
1023   (ly:warning-located
1024     (ly:format "~a:1" input-file-name)
1025     (_ "old relative compatibility not used")))