scm/lily-library.scm

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