scm/lily-library.scm

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