scm/lily-library.scm

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