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))))
 545
 546 (define-public (count-list lst)
 547   "Given @var{lst} as @code{(E1 E2 .. )}, return
 548 @code{((E1 . 1) (E2 . 2) ... )}."
 549
 550   (define (helper l acc count)
 551     (if (pair? l)
 552         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 553         acc))
 554
 555
 556   (reverse (helper lst '() 1)))
 557
 558 (define-public (list-join lst intermediate)
 559   "Put @var{intermediate} between all elts of @var{lst}."
 560
 561   (fold-right
 562    (lambda (elem prev)
 563             (if (pair? prev)
 564                 (cons  elem (cons intermediate prev))
 565                 (list elem)))
 566           '() lst))
 567
 568 (define-public (filtered-map proc lst)
 569   (filter
 570    (lambda (x) x)
 571    (map proc lst)))
 572
 573 (define-public (flatten-list x)
 574   "Unnest list."
 575   (cond ((null? x) '())
 576         ((not (pair? x)) (list x))
 577         (else (append (flatten-list (car x))
 578                       (flatten-list (cdr x))))))
 579
 580 (define (list-minus a b)
 581   "Return list of elements in A that are not in B."
 582   (lset-difference eq? a b))
 583
 584 (define-public (uniq-list lst)
 585   "Uniq @var{lst}, assuming that it is sorted.  Uses @code{equal?}
 586 for comparisons."
 587
 588   (reverse!
 589    (fold (lambda (x acc)
 590            (if (null? acc)
 591                (list x)
 592                (if (equal? x (car acc))
 593                    acc
 594                    (cons x acc))))
 595          '() lst) '()))
 596
 597 (define (split-at-predicate pred lst)
 598   "Split LST into two lists at the first element that returns #f for
 599   (PRED previous_element element).  Return the two parts as a pair.
 600   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 601   (if (null? lst)
 602       (list lst)
 603       (let ((i (list-index (lambda (x y) (not (pred x y)))
 604                            lst
 605                            (cdr lst))))
 606         (if i
 607             (cons (take lst (1+ i)) (drop lst (1+ i)))
 608             (list lst)))))
 609
 610 (define-public (split-list-by-separator lst pred)
 611   "Split @var{lst} at each element that satisfies @var{pred}, and return
 612 the parts (with the separators removed) as a list of lists.  For example,
 613 executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns
 614 @samp{((a) (b c) (d))}."
 615   (let loop ((result '()) (lst lst))
 616     (if (and lst (not (null? lst)))
 617         (loop
 618           (append result
 619                   (list (take-while (lambda (x) (not (pred x))) lst)))
 620           (let ((tail (find-tail pred lst)))
 621             (if tail (cdr tail) #f)))
 622        result)))
 623
 624 (define-public (offset-add a b)
 625   (cons (+ (car a) (car b))
 626         (+ (cdr a) (cdr b))))
 627
 628 (define-public (offset-flip-y o)
 629   (cons (car o) (- (cdr o))))
 630
 631 (define-public (offset-scale o scale)
 632   (cons (* (car o) scale)
 633         (* (cdr o) scale)))
 634
 635 (define-public (ly:list->offsets accum coords)
 636   (if (null? coords)
 637       accum
 638       (cons (cons (car coords) (cadr coords))
 639             (ly:list->offsets accum (cddr coords)))))
 640
 641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 642 ;; intervals
 643
 644 (define-public empty-interval '(+inf.0 . -inf.0))
 645
 646 (define-public (symmetric-interval expr)
 647   (cons (- expr) expr))
 648
 649 (define-public (interval-length x)
 650   "Length of the number-pair @var{x}, if an interval."
 651   (max 0 (- (cdr x) (car x))))
 652
 653 (define-public (ordered-cons a b)
 654   (cons (min a b)
 655         (max a b)))
 656
 657 (define-public (interval-bound interval dir)
 658   ((if (= dir RIGHT) cdr car) interval))
 659
 660 (define-public (interval-index interval dir)
 661   "Interpolate @var{interval} between between left (@var{dir}=-1) and
 662 right (@var{dir}=+1)."
 663
 664   (* (+  (interval-start interval) (interval-end interval)
 665          (* dir (- (interval-end interval) (interval-start interval))))
 666      0.5))
 667
 668 (define-public (interval-center x)
 669   "Center the number-pair @var{x}, if an interval."
 670   (if (interval-empty? x)
 671       0.0
 672       (/ (+ (car x) (cdr x)) 2)))
 673
 674 (define-public interval-start car)
 675
 676 (define-public interval-end cdr)
 677
 678 (define (other-axis a)
 679   (remainder (+ a 1) 2))
 680
 681 (define-public (interval-scale iv factor)
 682   (cons (* (car iv) factor)
 683     (* (cdr iv) factor)))
 684
 685 (define-public (interval-widen iv amount)
 686   (cons (- (car iv) amount)
 687     (+ (cdr iv) amount)))
 688
 689 (define-public (interval-empty? iv)
 690    (> (car iv) (cdr iv)))
 691
 692 (define-public (interval-union i1 i2)
 693   (cons
 694     (min (car i1) (car i2))
 695     (max (cdr i1) (cdr i2))))
 696
 697 (define-public (interval-intersection i1 i2)
 698    (cons
 699      (max (car i1) (car i2))
 700      (min (cdr i1) (cdr i2))))
 701
 702 (define-public (interval-sane? i)
 703   (not (or  (nan? (car i))
 704             (inf? (car i))
 705             (nan? (cdr i))
 706             (inf? (cdr i))
 707             (> (car i) (cdr i)))))
 708
 709 (define-public (add-point interval p)
 710   (cons (min (interval-start interval) p)
 711         (max (interval-end interval) p)))
 712
 713 (define-public (reverse-interval iv)
 714   (cons (cdr iv) (car iv)))
 715
 716 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 717 ;; boolean
 718
 719 (define (lily-and a b)
 720   (and a b))
 721
 722 (define (lily-or a b)
 723   (or a b))
 724
 725 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 726 ;; coordinates
 727
 728 (define coord-x car)
 729 (define coord-y cdr)
 730
 731 (define (coord-operation operator operand coordinate)
 732   (if (pair? operand)
 733     (cons (operator (coord-x operand) (coord-x coordinate))
 734           (operator (coord-y operand) (coord-y coordinate)))
 735     (cons (operator operand (coord-x coordinate))
 736           (operator operand (coord-y coordinate)))))
 737
 738 (define (coord-apply function coordinate)
 739   (if (pair? function)
 740     (cons
 741       ((coord-x function) (coord-x coordinate))
 742       ((coord-y function) (coord-y coordinate)))
 743     (cons
 744       (function (coord-x coordinate))
 745       (function (coord-y coordinate)))))
 746
 747 (define-public (coord-translate coordinate amount)
 748   (coord-operation + amount coordinate))
 749
 750 (define-public (coord-scale coordinate amount)
 751   (coord-operation * amount coordinate))
 752
 753 (define-public (coord-rotate coordinate degrees-in-radians)
 754   (let*
 755     ((coordinate
 756       (cons
 757         (exact->inexact (coord-x coordinate))
 758         (exact->inexact (coord-y coordinate))))
 759      (radius
 760       (sqrt
 761         (+ (* (coord-x coordinate) (coord-x coordinate))
 762            (* (coord-y coordinate) (coord-y coordinate)))))
 763     (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
 764    (cons
 765      (* radius (cos (+ angle degrees-in-radians)))
 766      (* radius (sin (+ angle degrees-in-radians))))))
 767
 768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 769 ;; trig
 770
 771 (define-public PI (* 4 (atan 1)))
 772
 773 (define-public TWO-PI (* 2 PI))
 774
 775 (define-public PI-OVER-TWO (/ PI 2))
 776
 777 (define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
 778
 779 (define-public (cyclic-base-value value cycle)
 780   "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
 781   (if (< value 0)
 782       (cyclic-base-value (+ value cycle) cycle)
 783       (if (>= value cycle)
 784           (cyclic-base-value (- value cycle) cycle)
 785           value)))
 786
 787 (define-public (angle-0-2pi angle)
 788   "Take @var{angle} (in radians) and maps it between 0 and 2pi."
 789   (cyclic-base-value angle TWO-PI))
 790
 791 (define-public (angle-0-360 angle)
 792   "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
 793   (cyclic-base-value angle 360.0))
 794
 795 (define-public PI-OVER-180  (/ PI 180))
 796
 797 (define-public (degrees->radians angle-degrees)
 798   "Convert the given angle from degrees to radians."
 799   (* angle-degrees PI-OVER-180))
 800
 801 (define-public (ellipse-radius x-radius y-radius angle)
 802   (/
 803     (* x-radius y-radius)
 804     (sqrt
 805       (+ (* (expt y-radius 2)
 806             (* (cos angle) (cos angle)))
 807         (* (expt x-radius 2)
 808            (* (sin angle) (sin angle)))))))
 809
 810 (define-public (polar->rectangular radius angle-in-degrees)
 811   "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
 812 as rectangular coordinates @ode{(x-length . y-length)}."
 813
 814   (let ((complex (make-polar
 815                     radius
 816                     (degrees->radians angle-in-degrees))))
 817      (cons
 818        (real-part complex)
 819        (imag-part complex))))
 820
 821 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 822 ;; string
 823
 824 (define-public (string-endswith s suffix)
 825   (equal? suffix (substring s
 826                             (max 0 (- (string-length s) (string-length suffix)))
 827                             (string-length s))))
 828
 829 (define-public (string-startswith s prefix)
 830   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 831
 832 (define-public (string-encode-integer i)
 833   (cond
 834    ((= i  0) "o")
 835    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 836    (else (string-append
 837           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 838           (string-encode-integer (quotient i 26))))))
 839
 840 (define (number->octal-string x)
 841   (let* ((n (inexact->exact x))
 842          (n64 (quotient n 64))
 843          (n8 (quotient (- n (* n64 64)) 8)))
 844     (string-append
 845      (number->string n64)
 846      (number->string n8)
 847      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 848
 849 (define-public (ly:inexact->string x radix)
 850   (let ((n (inexact->exact x)))
 851     (number->string n radix)))
 852
 853 (define-public (ly:number-pair->string c)
 854   (string-append (ly:number->string (car c)) " "
 855                  (ly:number->string (cdr c))))
 856
 857 (define-public (dir-basename file . rest)
 858   "Strip suffixes in @var{rest}, but leave directory component for
 859 @var{file}."
 860   (define (inverse-basename x y) (basename y x))
 861   (simple-format #f "~a/~a" (dirname file)
 862                  (fold inverse-basename file rest)))
 863
 864 (define-public (write-me message x)
 865   "Return @var{x}.  Display @var{message} and write @var{x}.
 866 Handy for debugging, possibly turned off."
 867   (display message) (write x) (newline) x)
 868 ;;  x)
 869
 870 (define-public (stderr string . rest)
 871   (apply format (cons (current-error-port) (cons string rest)))
 872   (force-output (current-error-port)))
 873
 874 (define-public (debugf string . rest)
 875   (if #f
 876       (apply stderr (cons string rest))))
 877
 878 (define (index-cell cell dir)
 879   (if (equal? dir 1)
 880       (cdr cell)
 881       (car cell)))
 882
 883 (define (cons-map f x)
 884   "map F to contents of X"
 885   (cons (f (car x)) (f (cdr x))))
 886
 887 (define-public (list-insert-separator lst between)
 888   "Create new list, inserting @var{between} between elements of @var{lst}."
 889   (define (conc x y )
 890     (if (eq? y #f)
 891         (list x)
 892         (cons x  (cons between y))))
 893   (fold-right conc #f lst))
 894
 895 (define-public (string-regexp-substitute a b str)
 896   (regexp-substitute/global #f a str 'pre b 'post))
 897
 898 (define (regexp-split str regex)
 899   (define matches '())
 900   (define end-of-prev-match 0)
 901   (define (notice match)
 902
 903     (set! matches (cons (substring (match:string match)
 904                                    end-of-prev-match
 905                                    (match:start match))
 906                         matches))
 907     (set! end-of-prev-match (match:end match)))
 908
 909   (regexp-substitute/global #f regex str notice 'post)
 910
 911   (if (< end-of-prev-match (string-length str))
 912       (set!
 913        matches
 914        (cons (substring str end-of-prev-match (string-length str)) matches)))
 915
 916    (reverse matches))
 917
 918 ;;;;;;;;;;;;;;;;
 919 ;; other
 920
 921 (define (sign x)
 922   (if (= x 0)
 923       0
 924       (if (< x 0) -1 1)))
 925
 926 (define-public (binary-search start end getter target-val)
 927   (_i "Find the index between @var{start} and @var{end} (an integer)
 928 which produces the closest match to @var{target-val} if
 929 applied to function @var{getter}.")
 930   (if (<= end start)
 931       start
 932       (let* ((compare (quotient (+ start end) 2))
 933              (get-val (getter compare)))
 934         (cond
 935          ((< target-val get-val)
 936           (set! end (1- compare)))
 937          ((< get-val target-val)
 938           (set! start (1+ compare))))
 939         (binary-search start end getter target-val))))
 940
 941 (define-public (car< a b)
 942   (< (car a) (car b)))
 943
 944 (define-public (car<= a b)
 945   (<= (car a) (car b)))
 946
 947 (define-public (symbol<? lst r)
 948   (string<? (symbol->string lst) (symbol->string r)))
 949
 950 (define-public (symbol-key<? lst r)
 951   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 952
 953 (define-public (eval-carefully symbol module . default)
 954   "Check whether all symbols in expr @var{symbol} are reachable
 955 in module @var{module}.  In that case evaluate, otherwise
 956 print a warning and set an optional @var{default}."
 957   (let* ((unavailable? (lambda (sym)
 958                          (not (module-defined? module sym))))
 959          (sym-unavailable (if (pair? symbol)
 960                               (filter
 961                                 unavailable?
 962                                 (filter symbol? (flatten-list symbol)))
 963                               (if (unavailable? symbol)
 964                                    #t
 965                                    '()))))
 966     (if (null? sym-unavailable)
 967         (eval symbol module)
 968         (let* ((def (and (pair? default) (car default))))
 969           (ly:programming-error
 970             "cannot evaluate ~S in module ~S, setting to ~S"
 971             (object->string symbol)
 972             (object->string module)
 973             (object->string def))
 974           def))))
 975
 976 ;;
 977 ;; don't confuse users with #<procedure .. > syntax.
 978 ;;
 979 (define-public (scm->string val)
 980   (if (and (procedure? val)
 981            (symbol? (procedure-name val)))
 982       (symbol->string (procedure-name val))
 983       (string-append
 984        (if (self-evaluating? val)
 985            (if (string? val)
 986                "\""
 987                "")
 988            "'")
 989        (call-with-output-string (lambda (port) (display val port)))
 990        (if (string? val)
 991            "\""
 992            ""))))
 993
 994 (define-public (!= lst r)
 995   (not (= lst r)))
 996
 997 (define-public lily-unit->bigpoint-factor
 998   (cond
 999    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
1000    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
1001    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
1002
1003 (define-public lily-unit->mm-factor
1004   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
1005
1006 ;;; FONT may be font smob, or pango font string...
1007 (define-public (font-name-style font)
1008   (if (string? font)
1009       (string-downcase font)
1010       (let* ((font-name (ly:font-name font))
1011              (full-name (if font-name font-name (ly:font-file-name font))))
1012           (string-downcase full-name))))
1013
1014 (define-public (modified-font-metric-font-scaling font)
1015   (let* ((designsize (ly:font-design-size font))
1016          (magnification (* (ly:font-magnification font)))
1017          (scaling (* magnification designsize)))
1018     (debugf "scaling:~S\n" scaling)
1019     (debugf "magnification:~S\n" magnification)
1020     (debugf "design:~S\n" designsize)
1021     scaling))
1022
1023 (define-public (version-not-seen-message input-file-name)
1024   (ly:warning-located
1025     (ly:format "~a:1" input-file-name)
1026     (_ "no \\version statement found, please add~afor future compatibility")
1027     (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
1028
1029 (define-public (old-relative-not-used-message input-file-name)
1030   (ly:warning-located
1031     (ly:format "~a:1" input-file-name)
1032     (_ "old relative compatibility not used")))