scm/lily-library.scm

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