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