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)
 161   "return any suffix value for output filename allowing for settings by
 162 calls to bookOutputName function"
 163   (let ((book-filename (ly:parser-lookup parser 'book-filename)))
 164     (if (not book-filename)
 165         (ly:parser-output-name parser)
 166         book-filename)))
 167
 168 (define (get-current-suffix parser)
 169   "return any suffix value for output filename allowing for settings by calls to
 170 bookoutput function"
 171   (let ((book-output-suffix (ly:parser-lookup 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)
 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))
 184          (output-suffix (get-current-suffix parser))
 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)))
 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 (add-text parser text)
 234   (add-score parser (list text)))
 235
 236 (define-public (add-music parser music)
 237   (collect-music-aux (lambda (score)
 238                        (add-score parser score))
 239                      parser
 240                      music))
 241
 242
 243 ;;;;;;;;;;;;;;;;
 244 ;; alist
 245
 246 (define-public assoc-get ly:assoc-get)
 247
 248 (define-public chain-assoc-get ly:chain-assoc-get)
 249
 250 (define-public (uniqued-alist alist acc)
 251   (if (null? alist) acc
 252       (if (assoc (caar alist) acc)
 253           (uniqued-alist (cdr alist) acc)
 254           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 255
 256 (define-public (alist<? x y)
 257   (string<? (symbol->string (car x))
 258             (symbol->string (car y))))
 259
 260 (define (map-alist-vals func list)
 261   "map FUNC over the vals of  LIST, leaving the keys."
 262   (if (null?  list)
 263       '()
 264       (cons (cons  (caar list) (func (cdar list)))
 265             (map-alist-vals func (cdr list)))))
 266
 267 (define (map-alist-keys func list)
 268   "map FUNC over the keys of an alist LIST, leaving the vals."
 269   (if (null?  list)
 270       '()
 271       (cons (cons (func (caar list)) (cdar list))
 272             (map-alist-keys func (cdr list)))))
 273
 274 (define-public (first-member members lst)
 275   "Return first successful member (of member) from @var{members} in
 276 @var{lst}."
 277   (if (null? members)
 278       #f
 279       (let ((m (member (car members) lst)))
 280         (if m m (first-member (cdr members) lst)))))
 281
 282 (define-public (first-assoc keys lst)
 283   "Return first successful assoc of key from @var{keys} in @var{lst}."
 284   (if (null? keys)
 285       #f
 286       (let ((k (assoc (car keys) lst)))
 287         (if k k (first-assoc (cdr keys) lst)))))
 288
 289 (define-public (flatten-alist alist)
 290   (if (null? alist)
 291       '()
 292       (cons (caar alist)
 293             (cons (cdar alist)
 294                   (flatten-alist (cdr alist))))))
 295
 296 (define (assoc-remove key alist)
 297   "Remove key (and its corresponding value) from an alist.
 298    Different than assoc-remove! because it is non-destructive."
 299   (define (assoc-crawler key l r)
 300     (if (null? r)
 301         l
 302         (if (equal? (caar r) key)
 303             (append l (cdr r))
 304             (assoc-crawler key (append l `(,(car r))) (cdr r)))))
 305   (assoc-crawler key '() alist))
 306
 307 (define-public (map-selected-alist-keys function keys alist)
 308   "Return @var{alist} with @var{function} applied to all of the values
 309 in list @var{keys}.
 310
 311 For example:
 312 @example
 313 @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
 314 @code{((a . -1) (b . 2) (c . 3) (d . 4)}
 315 @end example"
 316    (define (map-selected-alist-keys-helper function key alist)
 317      (map
 318      (lambda (pair)
 319        (if (equal? key (car pair))
 320            (cons key (function (cdr pair)))
 321            pair))
 322      alist))
 323    (if (null? keys)
 324        alist
 325        (map-selected-alist-keys
 326          function
 327          (cdr keys)
 328          (map-selected-alist-keys-helper function (car keys) alist))))
 329
 330 ;;;;;;;;;;;;;;;;
 331 ;; vector
 332
 333 (define-public (vector-for-each proc vec)
 334   (do
 335       ((i 0 (1+ i)))
 336       ((>= i (vector-length vec)) vec)
 337     (vector-set! vec i (proc (vector-ref vec i)))))
 338
 339 ;;;;;;;;;;;;;;;;
 340 ;; hash
 341
 342 (define-public (hash-table->alist t)
 343   (hash-fold (lambda (k v acc) (acons  k v  acc))
 344              '() t))
 345
 346 ;; todo: code dup with C++.
 347 (define-safe-public (alist->hash-table lst)
 348   "Convert alist to table"
 349   (let ((m (make-hash-table (length lst))))
 350     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 351     m))
 352
 353 ;;;;;;;;;;;;;;;;
 354 ;; list
 355
 356 (define (functional-or . rest)
 357   (if (pair? rest)
 358       (or (car rest)
 359            (apply functional-or (cdr rest)))
 360       #f))
 361
 362 (define (functional-and . rest)
 363   (if (pair? rest)
 364       (and (car rest)
 365            (apply functional-and (cdr rest)))
 366       #t))
 367
 368 (define (split-list lst n)
 369   "Split LST in N equal sized parts"
 370
 371   (define (helper todo acc-vector k)
 372     (if (null? todo)
 373         acc-vector
 374         (begin
 375           (if (< k 0)
 376               (set! k (+ n k)))
 377
 378           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 379           (helper (cdr todo) acc-vector (1- k)))))
 380
 381   (helper lst (make-vector n '()) (1- n)))
 382
 383 (define (list-element-index lst x)
 384   (define (helper todo k)
 385     (cond
 386      ((null? todo) #f)
 387      ((equal? (car todo) x) k)
 388      (else
 389       (helper (cdr todo) (1+ k)))))
 390
 391   (helper lst 0))
 392
 393 (define-public (count-list lst)
 394   "Given @var{lst} as @code{(E1 E2 .. )}, return
 395 @code{((E1 . 1) (E2 . 2) ... )}."
 396
 397   (define (helper l acc count)
 398     (if (pair? l)
 399         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 400         acc))
 401
 402
 403   (reverse (helper lst '() 1)))
 404
 405 (define-public (list-join lst intermediate)
 406   "Put @var{intermediate} between all elts of @var{lst}."
 407
 408   (fold-right
 409    (lambda (elem prev)
 410             (if (pair? prev)
 411                 (cons  elem (cons intermediate prev))
 412                 (list elem)))
 413           '() lst))
 414
 415 (define-public (filtered-map proc lst)
 416   (filter
 417    (lambda (x) x)
 418    (map proc lst)))
 419
 420 (define-public (flatten-list x)
 421   "Unnest list."
 422   (cond ((null? x) '())
 423         ((not (pair? x)) (list x))
 424         (else (append (flatten-list (car x))
 425                       (flatten-list (cdr x))))))
 426
 427 (define (list-minus a b)
 428   "Return list of elements in A that are not in B."
 429   (lset-difference eq? a b))
 430
 431 (define-public (uniq-list lst)
 432   "Uniq @var{lst}, assuming that it is sorted.  Uses @code{equal?}
 433 for comparisons."
 434
 435   (reverse!
 436    (fold (lambda (x acc)
 437            (if (null? acc)
 438                (list x)
 439                (if (equal? x (car acc))
 440                    acc
 441                    (cons x acc))))
 442          '() lst) '()))
 443
 444 (define (split-at-predicate pred lst)
 445   "Split LST into two lists at the first element that returns #f for
 446   (PRED previous_element element).  Return the two parts as a pair.
 447   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 448   (if (null? lst)
 449       (list lst)
 450       (let ((i (list-index (lambda (x y) (not (pred x y)))
 451                            lst
 452                            (cdr lst))))
 453         (if i
 454             (cons (take lst (1+ i)) (drop lst (1+ i)))
 455             (list lst)))))
 456
 457 (define-public (split-list-by-separator lst pred)
 458   "Split @var{lst} at each element that satisfies @var{pred}, and return
 459 the parts (with the separators removed) as a list of lists.  For example,
 460 executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns
 461 @samp{((a) (b c) (d))}."
 462   (let loop ((result '()) (lst lst))
 463     (if (and lst (not (null? lst)))
 464         (loop
 465           (append result
 466                   (list (take-while (lambda (x) (not (pred x))) lst)))
 467           (let ((tail (find-tail pred lst)))
 468             (if tail (cdr tail) #f)))
 469        result)))
 470
 471 (define-public (offset-add a b)
 472   (cons (+ (car a) (car b))
 473         (+ (cdr a) (cdr b))))
 474
 475 (define-public (offset-flip-y o)
 476   (cons (car o) (- (cdr o))))
 477
 478 (define-public (offset-scale o scale)
 479   (cons (* (car o) scale)
 480         (* (cdr o) scale)))
 481
 482 (define-public (ly:list->offsets accum coords)
 483   (if (null? coords)
 484       accum
 485       (cons (cons (car coords) (cadr coords))
 486             (ly:list->offsets accum (cddr coords)))))
 487
 488 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 489 ;; intervals
 490
 491 (define-public empty-interval '(+inf.0 . -inf.0))
 492
 493 (define-public (symmetric-interval expr)
 494   (cons (- expr) expr))
 495
 496 (define-public (interval-length x)
 497   "Length of the number-pair @var{x}, if an interval."
 498   (max 0 (- (cdr x) (car x))))
 499
 500 (define-public (ordered-cons a b)
 501   (cons (min a b)
 502         (max a b)))
 503
 504 (define-public (interval-bound interval dir)
 505   ((if (= dir RIGHT) cdr car) interval))
 506
 507 (define-public (interval-index interval dir)
 508   "Interpolate @var{interval} between between left (@var{dir}=-1) and
 509 right (@var{dir}=+1)."
 510
 511   (* (+  (interval-start interval) (interval-end interval)
 512          (* dir (- (interval-end interval) (interval-start interval))))
 513      0.5))
 514
 515 (define-public (interval-center x)
 516   "Center the number-pair @var{x}, if an interval."
 517   (if (interval-empty? x)
 518       0.0
 519       (/ (+ (car x) (cdr x)) 2)))
 520
 521 (define-public interval-start car)
 522
 523 (define-public interval-end cdr)
 524
 525 (define (other-axis a)
 526   (remainder (+ a 1) 2))
 527
 528 (define-public (interval-widen iv amount)
 529   (cons (- (car iv) amount)
 530     (+ (cdr iv) amount)))
 531
 532 (define-public (interval-empty? iv)
 533    (> (car iv) (cdr iv)))
 534
 535 (define-public (interval-union i1 i2)
 536   (cons
 537     (min (car i1) (car i2))
 538     (max (cdr i1) (cdr i2))))
 539
 540 (define-public (interval-intersection i1 i2)
 541    (cons
 542      (max (car i1) (car i2))
 543      (min (cdr i1) (cdr i2))))
 544
 545 (define-public (interval-sane? i)
 546   (not (or  (nan? (car i))
 547             (inf? (car i))
 548             (nan? (cdr i))
 549             (inf? (cdr i))
 550             (> (car i) (cdr i)))))
 551
 552 (define-public (add-point interval p)
 553   (cons (min (interval-start interval) p)
 554         (max (interval-end interval) p)))
 555
 556 (define-public (reverse-interval iv)
 557   (cons (cdr iv) (car iv)))
 558
 559 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 560 ;; coordinates
 561
 562 (define coord-x car)
 563 (define coord-y cdr)
 564
 565 (define (coord-operation operator operand coordinate)
 566   (if (pair? operand)
 567     (cons (operator (coord-x operand) (coord-x coordinate))
 568           (operator (coord-y operand) (coord-y coordinate)))
 569     (cons (operator operand (coord-x coordinate))
 570           (operator operand (coord-y coordinate)))))
 571
 572 (define (coord-apply function coordinate)
 573   (if (pair? function)
 574     (cons
 575       ((coord-x function) (coord-x coordinate))
 576       ((coord-y function) (coord-y coordinate)))
 577     (cons
 578       (function (coord-x coordinate))
 579       (function (coord-y coordinate)))))
 580
 581 (define-public (coord-translate coordinate amount)
 582   (coord-operation + amount coordinate))
 583
 584 (define-public (coord-scale coordinate amount)
 585   (coord-operation * amount coordinate))
 586
 587 (define-public (coord-rotate coordinate degrees-in-radians)
 588   (let*
 589     ((coordinate
 590       (cons
 591         (exact->inexact (coord-x coordinate))
 592         (exact->inexact (coord-y coordinate))))
 593      (radius
 594       (sqrt
 595         (+ (* (coord-x coordinate) (coord-x coordinate))
 596            (* (coord-y coordinate) (coord-y coordinate)))))
 597     (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
 598    (cons
 599      (* radius (cos (+ angle degrees-in-radians)))
 600      (* radius (sin (+ angle degrees-in-radians))))))
 601
 602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 603 ;; trig
 604
 605 (define-public PI (* 4 (atan 1)))
 606
 607 (define-public TWO-PI (* 2 PI))
 608
 609 (define-public PI-OVER-TWO (/ PI 2))
 610
 611 (define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
 612
 613 (define-public (cyclic-base-value value cycle)
 614   "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
 615   (if (< value 0)
 616       (cyclic-base-value (+ value cycle) cycle)
 617       (if (>= value cycle)
 618           (cyclic-base-value (- value cycle) cycle)
 619           value)))
 620
 621 (define-public (angle-0-2pi angle)
 622   "Take @var{angle} (in radians) and maps it between 0 and 2pi."
 623   (cyclic-base-value angle TWO-PI))
 624
 625 (define-public (angle-0-360 angle)
 626   "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
 627   (cyclic-base-value angle 360.0))
 628
 629 (define-public PI-OVER-180  (/ PI 180))
 630
 631 (define-public (degrees->radians angle-degrees)
 632   "Convert the given angle from degrees to radians."
 633   (* angle-degrees PI-OVER-180))
 634
 635 (define-public (ellipse-radius x-radius y-radius angle)
 636   (/
 637     (* x-radius y-radius)
 638     (sqrt
 639       (+ (* (expt y-radius 2)
 640             (* (cos angle) (cos angle)))
 641         (* (expt x-radius 2)
 642            (* (sin angle) (sin angle)))))))
 643
 644 (define-public (polar->rectangular radius angle-in-degrees)
 645   "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
 646 as rectangular coordinates @ode{(x-length . y-length)}."
 647
 648   (let ((complex (make-polar
 649                     radius
 650                     (degrees->radians angle-in-degrees))))
 651      (cons
 652        (real-part complex)
 653        (imag-part complex))))
 654
 655 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 656 ;; string
 657
 658 (define-public (string-endswith s suffix)
 659   (equal? suffix (substring s
 660                             (max 0 (- (string-length s) (string-length suffix)))
 661                             (string-length s))))
 662
 663 (define-public (string-startswith s prefix)
 664   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 665
 666 (define-public (string-encode-integer i)
 667   (cond
 668    ((= i  0) "o")
 669    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 670    (else (string-append
 671           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 672           (string-encode-integer (quotient i 26))))))
 673
 674 (define (number->octal-string x)
 675   (let* ((n (inexact->exact x))
 676          (n64 (quotient n 64))
 677          (n8 (quotient (- n (* n64 64)) 8)))
 678     (string-append
 679      (number->string n64)
 680      (number->string n8)
 681      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 682
 683 (define-public (ly:inexact->string x radix)
 684   (let ((n (inexact->exact x)))
 685     (number->string n radix)))
 686
 687 (define-public (ly:number-pair->string c)
 688   (string-append (ly:number->string (car c)) " "
 689                  (ly:number->string (cdr c))))
 690
 691 (define-public (dir-basename file . rest)
 692   "Strip suffixes in @var{rest}, but leave directory component for
 693 @var{file}."
 694   (define (inverse-basename x y) (basename y x))
 695   (simple-format #f "~a/~a" (dirname file)
 696                  (fold inverse-basename file rest)))
 697
 698 (define-public (write-me message x)
 699   "Return @var{x}.  Display @var{message} and write @var{x}.
 700 Handy for debugging, possibly turned off."
 701   (display message) (write x) (newline) x)
 702 ;;  x)
 703
 704 (define-public (stderr string . rest)
 705   (apply format (cons (current-error-port) (cons string rest)))
 706   (force-output (current-error-port)))
 707
 708 (define-public (debugf string . rest)
 709   (if #f
 710       (apply stderr (cons string rest))))
 711
 712 (define (index-cell cell dir)
 713   (if (equal? dir 1)
 714       (cdr cell)
 715       (car cell)))
 716
 717 (define (cons-map f x)
 718   "map F to contents of X"
 719   (cons (f (car x)) (f (cdr x))))
 720
 721 (define-public (list-insert-separator lst between)
 722   "Create new list, inserting @var{between} between elements of @var{lst}."
 723   (define (conc x y )
 724     (if (eq? y #f)
 725         (list x)
 726         (cons x  (cons between y))))
 727   (fold-right conc #f lst))
 728
 729 (define-public (string-regexp-substitute a b str)
 730   (regexp-substitute/global #f a str 'pre b 'post))
 731
 732 (define (regexp-split str regex)
 733   (define matches '())
 734   (define end-of-prev-match 0)
 735   (define (notice match)
 736
 737     (set! matches (cons (substring (match:string match)
 738                                    end-of-prev-match
 739                                    (match:start match))
 740                         matches))
 741     (set! end-of-prev-match (match:end match)))
 742
 743   (regexp-substitute/global #f regex str notice 'post)
 744
 745   (if (< end-of-prev-match (string-length str))
 746       (set!
 747        matches
 748        (cons (substring str end-of-prev-match (string-length str)) matches)))
 749
 750    (reverse matches))
 751
 752 ;;;;;;;;;;;;;;;;
 753 ;; other
 754
 755 (define (sign x)
 756   (if (= x 0)
 757       0
 758       (if (< x 0) -1 1)))
 759
 760 (define-public (binary-search start end getter target-val)
 761   (_i "Find the index between @var{start} and @var{end} (an integer)
 762 which produces the closest match to @var{target-val} if
 763 applied to function @var{getter}.")
 764   (if (<= end start)
 765       start
 766       (let* ((compare (quotient (+ start end) 2))
 767              (get-val (getter compare)))
 768         (cond
 769          ((< target-val get-val)
 770           (set! end (1- compare)))
 771          ((< get-val target-val)
 772           (set! start (1+ compare))))
 773         (binary-search start end getter target-val))))
 774
 775 (define-public (car< a b)
 776   (< (car a) (car b)))
 777
 778 (define-public (car<= a b)
 779   (<= (car a) (car b)))
 780
 781 (define-public (symbol<? lst r)
 782   (string<? (symbol->string lst) (symbol->string r)))
 783
 784 (define-public (symbol-key<? lst r)
 785   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 786
 787 (define-public (eval-carefully symbol module . default)
 788   "Check whether all symbols in expr @var{symbol} are reachable
 789 in module @var{module}.  In that case evaluate, otherwise
 790 print a warning and set an optional @var{default}."
 791   (let* ((unavailable? (lambda (sym)
 792                          (not (module-defined? module sym))))
 793          (sym-unavailable (if (pair? symbol)
 794                               (filter
 795                                 unavailable?
 796                                 (filter symbol? (flatten-list symbol)))
 797                               (if (unavailable? symbol)
 798                                    #t
 799                                    '()))))
 800     (if (null? sym-unavailable)
 801         (eval symbol module)
 802         (let* ((def (and (pair? default) (car default))))
 803           (ly:programming-error
 804             "cannot evaluate ~S in module ~S, setting to ~S"
 805             (object->string symbol)
 806             (object->string module)
 807             (object->string def))
 808           def))))
 809
 810 ;;
 811 ;; don't confuse users with #<procedure .. > syntax.
 812 ;;
 813 (define-public (scm->string val)
 814   (if (and (procedure? val)
 815            (symbol? (procedure-name val)))
 816       (symbol->string (procedure-name val))
 817       (string-append
 818        (if (self-evaluating? val)
 819            (if (string? val)
 820                "\""
 821                "")
 822            "'")
 823        (call-with-output-string (lambda (port) (display val port)))
 824        (if (string? val)
 825            "\""
 826            ""))))
 827
 828 (define-public (!= lst r)
 829   (not (= lst r)))
 830
 831 (define-public lily-unit->bigpoint-factor
 832   (cond
 833    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 834    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 835    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 836
 837 (define-public lily-unit->mm-factor
 838   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 839
 840 ;;; FONT may be font smob, or pango font string...
 841 (define-public (font-name-style font)
 842   (if (string? font)
 843       (string-downcase font)
 844       (let* ((font-name (ly:font-name font))
 845              (full-name (if font-name font-name (ly:font-file-name font))))
 846           (string-downcase full-name))))
 847
 848 (define-public (modified-font-metric-font-scaling font)
 849   (let* ((designsize (ly:font-design-size font))
 850          (magnification (* (ly:font-magnification font)))
 851          (scaling (* magnification designsize)))
 852     (debugf "scaling:~S\n" scaling)
 853     (debugf "magnification:~S\n" magnification)
 854     (debugf "design:~S\n" designsize)
 855     scaling))
 856
 857 (define-public (version-not-seen-message input-file-name)
 858   (ly:warning-located
 859     (ly:format "~a:0" input-file-name)
 860     (_ "no \\version statement found, please add~afor future compatibility")
 861     (format #f "\n\n\\version ~s\n\n" (lilypond-version))))
 862
 863 (define-public (old-relative-not-used-message input-file-name)
 864   (ly:warning-located
 865     (ly:format "~a:0" input-file-name)
 866     (_ "old relative compatibility not used")))