scm/lily-library.scm

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