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