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 ;; boolean
 701
 702 (define (lily-and a b)
 703   (and a b))
 704
 705 (define (lily-or a b)
 706   (or a b))
 707
 708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 709 ;; coordinates
 710
 711 (define coord-x car)
 712 (define coord-y cdr)
 713
 714 (define (coord-operation operator operand coordinate)
 715   (if (pair? operand)
 716     (cons (operator (coord-x operand) (coord-x coordinate))
 717           (operator (coord-y operand) (coord-y coordinate)))
 718     (cons (operator operand (coord-x coordinate))
 719           (operator operand (coord-y coordinate)))))
 720
 721 (define (coord-apply function coordinate)
 722   (if (pair? function)
 723     (cons
 724       ((coord-x function) (coord-x coordinate))
 725       ((coord-y function) (coord-y coordinate)))
 726     (cons
 727       (function (coord-x coordinate))
 728       (function (coord-y coordinate)))))
 729
 730 (define-public (coord-translate coordinate amount)
 731   (coord-operation + amount coordinate))
 732
 733 (define-public (coord-scale coordinate amount)
 734   (coord-operation * amount coordinate))
 735
 736 (define-public (coord-rotate coordinate degrees-in-radians)
 737   (let*
 738     ((coordinate
 739       (cons
 740         (exact->inexact (coord-x coordinate))
 741         (exact->inexact (coord-y coordinate))))
 742      (radius
 743       (sqrt
 744         (+ (* (coord-x coordinate) (coord-x coordinate))
 745            (* (coord-y coordinate) (coord-y coordinate)))))
 746     (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
 747    (cons
 748      (* radius (cos (+ angle degrees-in-radians)))
 749      (* radius (sin (+ angle degrees-in-radians))))))
 750
 751 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 752 ;; trig
 753
 754 (define-public PI (* 4 (atan 1)))
 755
 756 (define-public TWO-PI (* 2 PI))
 757
 758 (define-public PI-OVER-TWO (/ PI 2))
 759
 760 (define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
 761
 762 (define-public (cyclic-base-value value cycle)
 763   "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
 764   (if (< value 0)
 765       (cyclic-base-value (+ value cycle) cycle)
 766       (if (>= value cycle)
 767           (cyclic-base-value (- value cycle) cycle)
 768           value)))
 769
 770 (define-public (angle-0-2pi angle)
 771   "Take @var{angle} (in radians) and maps it between 0 and 2pi."
 772   (cyclic-base-value angle TWO-PI))
 773
 774 (define-public (angle-0-360 angle)
 775   "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
 776   (cyclic-base-value angle 360.0))
 777
 778 (define-public PI-OVER-180  (/ PI 180))
 779
 780 (define-public (degrees->radians angle-degrees)
 781   "Convert the given angle from degrees to radians."
 782   (* angle-degrees PI-OVER-180))
 783
 784 (define-public (ellipse-radius x-radius y-radius angle)
 785   (/
 786     (* x-radius y-radius)
 787     (sqrt
 788       (+ (* (expt y-radius 2)
 789             (* (cos angle) (cos angle)))
 790         (* (expt x-radius 2)
 791            (* (sin angle) (sin angle)))))))
 792
 793 (define-public (polar->rectangular radius angle-in-degrees)
 794   "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
 795 as rectangular coordinates @ode{(x-length . y-length)}."
 796
 797   (let ((complex (make-polar
 798                     radius
 799                     (degrees->radians angle-in-degrees))))
 800      (cons
 801        (real-part complex)
 802        (imag-part complex))))
 803
 804 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 805 ;; string
 806
 807 (define-public (string-endswith s suffix)
 808   (equal? suffix (substring s
 809                             (max 0 (- (string-length s) (string-length suffix)))
 810                             (string-length s))))
 811
 812 (define-public (string-startswith s prefix)
 813   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 814
 815 (define-public (string-encode-integer i)
 816   (cond
 817    ((= i  0) "o")
 818    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 819    (else (string-append
 820           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 821           (string-encode-integer (quotient i 26))))))
 822
 823 (define (number->octal-string x)
 824   (let* ((n (inexact->exact x))
 825          (n64 (quotient n 64))
 826          (n8 (quotient (- n (* n64 64)) 8)))
 827     (string-append
 828      (number->string n64)
 829      (number->string n8)
 830      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 831
 832 (define-public (ly:inexact->string x radix)
 833   (let ((n (inexact->exact x)))
 834     (number->string n radix)))
 835
 836 (define-public (ly:number-pair->string c)
 837   (string-append (ly:number->string (car c)) " "
 838                  (ly:number->string (cdr c))))
 839
 840 (define-public (dir-basename file . rest)
 841   "Strip suffixes in @var{rest}, but leave directory component for
 842 @var{file}."
 843   (define (inverse-basename x y) (basename y x))
 844   (simple-format #f "~a/~a" (dirname file)
 845                  (fold inverse-basename file rest)))
 846
 847 (define-public (write-me message x)
 848   "Return @var{x}.  Display @var{message} and write @var{x}.
 849 Handy for debugging, possibly turned off."
 850   (display message) (write x) (newline) x)
 851 ;;  x)
 852
 853 (define-public (stderr string . rest)
 854   (apply format (cons (current-error-port) (cons string rest)))
 855   (force-output (current-error-port)))
 856
 857 (define-public (debugf string . rest)
 858   (if #f
 859       (apply stderr (cons string rest))))
 860
 861 (define (index-cell cell dir)
 862   (if (equal? dir 1)
 863       (cdr cell)
 864       (car cell)))
 865
 866 (define (cons-map f x)
 867   "map F to contents of X"
 868   (cons (f (car x)) (f (cdr x))))
 869
 870 (define-public (list-insert-separator lst between)
 871   "Create new list, inserting @var{between} between elements of @var{lst}."
 872   (define (conc x y )
 873     (if (eq? y #f)
 874         (list x)
 875         (cons x  (cons between y))))
 876   (fold-right conc #f lst))
 877
 878 (define-public (string-regexp-substitute a b str)
 879   (regexp-substitute/global #f a str 'pre b 'post))
 880
 881 (define (regexp-split str regex)
 882   (define matches '())
 883   (define end-of-prev-match 0)
 884   (define (notice match)
 885
 886     (set! matches (cons (substring (match:string match)
 887                                    end-of-prev-match
 888                                    (match:start match))
 889                         matches))
 890     (set! end-of-prev-match (match:end match)))
 891
 892   (regexp-substitute/global #f regex str notice 'post)
 893
 894   (if (< end-of-prev-match (string-length str))
 895       (set!
 896        matches
 897        (cons (substring str end-of-prev-match (string-length str)) matches)))
 898
 899    (reverse matches))
 900
 901 ;;;;;;;;;;;;;;;;
 902 ;; other
 903
 904 (define (sign x)
 905   (if (= x 0)
 906       0
 907       (if (< x 0) -1 1)))
 908
 909 (define-public (binary-search start end getter target-val)
 910   (_i "Find the index between @var{start} and @var{end} (an integer)
 911 which produces the closest match to @var{target-val} if
 912 applied to function @var{getter}.")
 913   (if (<= end start)
 914       start
 915       (let* ((compare (quotient (+ start end) 2))
 916              (get-val (getter compare)))
 917         (cond
 918          ((< target-val get-val)
 919           (set! end (1- compare)))
 920          ((< get-val target-val)
 921           (set! start (1+ compare))))
 922         (binary-search start end getter target-val))))
 923
 924 (define-public (car< a b)
 925   (< (car a) (car b)))
 926
 927 (define-public (car<= a b)
 928   (<= (car a) (car b)))
 929
 930 (define-public (symbol<? lst r)
 931   (string<? (symbol->string lst) (symbol->string r)))
 932
 933 (define-public (symbol-key<? lst r)
 934   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 935
 936 (define-public (eval-carefully symbol module . default)
 937   "Check whether all symbols in expr @var{symbol} are reachable
 938 in module @var{module}.  In that case evaluate, otherwise
 939 print a warning and set an optional @var{default}."
 940   (let* ((unavailable? (lambda (sym)
 941                          (not (module-defined? module sym))))
 942          (sym-unavailable (if (pair? symbol)
 943                               (filter
 944                                 unavailable?
 945                                 (filter symbol? (flatten-list symbol)))
 946                               (if (unavailable? symbol)
 947                                    #t
 948                                    '()))))
 949     (if (null? sym-unavailable)
 950         (eval symbol module)
 951         (let* ((def (and (pair? default) (car default))))
 952           (ly:programming-error
 953             "cannot evaluate ~S in module ~S, setting to ~S"
 954             (object->string symbol)
 955             (object->string module)
 956             (object->string def))
 957           def))))
 958
 959 ;;
 960 ;; don't confuse users with #<procedure .. > syntax.
 961 ;;
 962 (define-public (scm->string val)
 963   (if (and (procedure? val)
 964            (symbol? (procedure-name val)))
 965       (symbol->string (procedure-name val))
 966       (string-append
 967        (if (self-evaluating? val)
 968            (if (string? val)
 969                "\""
 970                "")
 971            "'")
 972        (call-with-output-string (lambda (port) (display val port)))
 973        (if (string? val)
 974            "\""
 975            ""))))
 976
 977 (define-public (!= lst r)
 978   (not (= lst r)))
 979
 980 (define-public lily-unit->bigpoint-factor
 981   (cond
 982    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 983    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 984    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 985
 986 (define-public lily-unit->mm-factor
 987   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 988
 989 ;;; FONT may be font smob, or pango font string...
 990 (define-public (font-name-style font)
 991   (if (string? font)
 992       (string-downcase font)
 993       (let* ((font-name (ly:font-name font))
 994              (full-name (if font-name font-name (ly:font-file-name font))))
 995           (string-downcase full-name))))
 996
 997 (define-public (modified-font-metric-font-scaling font)
 998   (let* ((designsize (ly:font-design-size font))
 999          (magnification (* (ly:font-magnification font)))
1000          (scaling (* magnification designsize)))
1001     (debugf "scaling:~S\n" scaling)
1002     (debugf "magnification:~S\n" magnification)
1003     (debugf "design:~S\n" designsize)
1004     scaling))
1005
1006 (define-public (version-not-seen-message input-file-name)
1007   (ly:warning-located
1008     (ly:format "~a:1" input-file-name)
1009     (_ "no \\version statement found, please add~afor future compatibility")
1010     (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
1011
1012 (define-public (old-relative-not-used-message input-file-name)
1013   (ly:warning-located
1014     (ly:format "~a:1" input-file-name)
1015     (_ "old relative compatibility not used")))