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