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