scm/lily-library.scm

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