scm/lily.scm

   1 ;;;; lily.scm -- implement Scheme output routines for TeX and PostScript
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8 ;;; Library functions
   9
  10
  11 (use-modules (ice-9 regex)
  12              (ice-9 safe)
  13              (oop goops)
  14              (srfi srfi-1)  ; lists
  15              (srfi srfi-13)) ; strings
  16
  17 (define-public safe-module (make-safe-module))
  18
  19 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
  20
  21 ;;; General settings
  22 ;;; debugging evaluator is slower.  This should
  23 ;;; have a more sensible default.
  24
  25
  26 (if (ly:get-option 'verbose)
  27     (begin
  28       (debug-enable 'debug)
  29       (debug-enable 'backtrace)
  30       (read-enable 'positions) ))
  31
  32
  33 (define-public (line-column-location line col file)
  34   "Print an input location, including column number ."
  35   (string-append (number->string line) ":"
  36                  (number->string col) " " file)
  37   )
  38
  39 (define-public (line-location line col file)
  40   "Print an input location, without column number ."
  41   (string-append (number->string line) " " file)
  42   )
  43
  44 (define-public point-and-click #f)
  45
  46 (define-public (lilypond-version)
  47   (string-join
  48    (map (lambda (x) (if (symbol? x)
  49                         (symbol->string x)
  50                         (number->string x)))
  51                 (ly:version))
  52    "."))
  53
  54
  55
  56 ;; cpp hack to get useful error message
  57 (define ifdef "First run this through cpp.")
  58 (define ifndef "First run this through cpp.")
  59
  60
  61
  62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63
  64 (define-public X 0)
  65 (define-public Y 1)
  66 (define-public START -1)
  67 (define-public STOP 1)
  68 (define-public LEFT -1)
  69 (define-public RIGHT 1)
  70 (define-public UP 1)
  71 (define-public DOWN -1)
  72 (define-public CENTER 0)
  73
  74 (define-public DOUBLE-FLAT -4)
  75 (define-public THREE-Q-FLAT -3)
  76 (define-public FLAT -2)
  77 (define-public SEMI-FLAT -1)
  78 (define-public NATURAL 0)
  79 (define-public SEMI-SHARP 1)
  80 (define-public SHARP 2)
  81 (define-public THREE-Q-SHARP 3)
  82 (define-public DOUBLE-SHARP 4)
  83 (define-public SEMI-TONE 2)
  84
  85 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  86
  87 (define-public (moment-min a b)
  88   (if (ly:moment<? a b) a b))
  89
  90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91 ;; lily specific variables.
  92 (define-public default-script-alist '())
  93
  94 (define-public safe-mode? #f)
  95
  96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97 ;;; Unassorted utility functions.
  98
  99
 100 ;;;;;;;;;;;;;;;;
 101 ; alist
 102 (define (uniqued-alist  alist acc)
 103   (if (null? alist) acc
 104       (if (assoc (caar alist) acc)
 105           (uniqued-alist (cdr alist) acc)
 106           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 107
 108
 109 (define-public (assoc-get key alist)
 110   "Return value if KEY in ALIST, else #f."
 111   (let ((entry (assoc key alist)))
 112     (if entry (cdr entry) #f)))
 113
 114 (define-public (assoc-get-default key alist default)
 115   "Return value if KEY in ALIST, else DEFAULT."
 116   (let ((entry (assoc key alist)))
 117     (if entry (cdr entry) default)))
 118
 119
 120 (define-public (uniqued-alist  alist acc)
 121   (if (null? alist) acc
 122       (if (assoc (caar alist) acc)
 123           (uniqued-alist (cdr alist) acc)
 124           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 125
 126 (define-public (alist<? x y)
 127   (string<? (symbol->string (car x))
 128             (symbol->string (car y))))
 129
 130
 131
 132 (define (chain-assoc x alist-list)
 133   (if (null? alist-list)
 134       #f
 135       (let* ((handle (assoc x (car alist-list))))
 136         (if (pair? handle)
 137             handle
 138             (chain-assoc x (cdr alist-list))))))
 139
 140 (define (chain-assoc-get x alist-list default)
 141   (if (null? alist-list)
 142       default
 143       (let* ((handle (assoc x (car alist-list))))
 144         (if (pair? handle)
 145             (cdr handle)
 146             (chain-assoc-get x (cdr alist-list) default)))))
 147
 148
 149 (define (map-alist-vals func list)
 150   "map FUNC over the vals of  LIST, leaving the keys."
 151   (if (null?  list)
 152       '()
 153       (cons (cons  (caar list) (func (cdar list)))
 154             (map-alist-vals func (cdr list)))
 155       ))
 156
 157 (define (map-alist-keys func list)
 158   "map FUNC over the keys of an alist LIST, leaving the vals. "
 159   (if (null?  list)
 160       '()
 161       (cons (cons (func (caar list)) (cdar list))
 162             (map-alist-keys func (cdr list)))
 163       ))
 164
 165 ;;;;;;;;;;;;;;;;
 166 ;; hash
 167
 168
 169
 170 (if (not (defined? 'hash-table?))       ; guile 1.6 compat
 171     (begin
 172       (define hash-table? vector?)
 173
 174       (define-public (hash-table->alist t)
 175         "Convert table t to list"
 176         (apply append
 177                (vector->list t)
 178                )))
 179
 180     ;; native hashtabs.
 181     (begin
 182       (define-public (hash-table->alist t)
 183
 184         (hash-fold (lambda (k v acc) (acons  k v  acc))
 185                    '() t)
 186         )
 187       ))
 188
 189 ;; todo: code dup with C++.
 190 (define-public (alist->hash-table l)
 191   "Convert alist to table"
 192   (let
 193       ((m (make-hash-table (length l))))
 194
 195     (map (lambda (k-v)
 196            (hashq-set! m (car k-v) (cdr k-v)))
 197          l)
 198
 199     m))
 200
 201
 202
 203 ;;;;;;;;;;;;;;;;
 204 ; list
 205
 206 (define (flatten-list lst)
 207   "Unnest LST"
 208   (if (null? lst)
 209       '()
 210       (if (pair? (car lst))
 211           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 212           (cons (car lst) (flatten-list (cdr lst))))
 213   ))
 214
 215 (define (list-minus a b)
 216   "Return list of elements in A that are not in B."
 217   (lset-difference eq? a b))
 218
 219
 220 ;; TODO: use the srfi-1 partition function.
 221 (define-public (uniq-list l)
 222
 223   "Uniq LIST, assuming that it is sorted"
 224   (define (helper acc l)
 225     (if (null? l)
 226         acc
 227         (if (null? (cdr l))
 228             (cons (car l) acc)
 229             (if (equal? (car l) (cadr l))
 230                 (helper acc (cdr l))
 231                 (helper (cons (car l) acc)  (cdr l)))
 232             )))
 233   (reverse! (helper '() l) '()))
 234
 235
 236 (define (split-at-predicate predicate l)
 237  "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
 238 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 239 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 240 L1 is copied, L2 not.
 241
 242 (split-at-predicate (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
 243 ;; "
 244
 245 ;; KUT EMACS MODE.
 246
 247   (define (inner-split predicate l acc)
 248   (cond
 249    ((null? l) acc)
 250    ((null? (cdr l))
 251     (set-car! acc (cons (car l) (car acc)))
 252     acc)
 253    ((predicate (car l) (cadr l))
 254     (set-car! acc (cons (car l) (car acc)))
 255     (inner-split predicate (cdr l) acc))
 256    (else
 257     (set-car! acc (cons (car l) (car acc)))
 258     (set-cdr! acc (cdr l))
 259     acc)
 260
 261   ))
 262  (let*
 263     ((c (cons '() '()))
 264      )
 265   (inner-split predicate l  c)
 266   (set-car! c (reverse! (car c)))
 267   c)
 268 )
 269
 270
 271 (define-public (split-list l sep?)
 272 "
 273 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
 274 =>
 275 ((a b c) (d e f) (g))
 276
 277 "
 278 ;; " KUT EMACS.
 279
 280 (define (split-one sep?  l acc)
 281   "Split off the first parts before separator and return both parts."
 282   (if (null? l)
 283       (cons acc '())
 284       (if (sep? (car l))
 285           (cons acc (cdr l))
 286           (split-one sep? (cdr l) (cons (car l) acc))
 287           )
 288       ))
 289
 290 (if (null? l)
 291     '()
 292     (let* ((c (split-one sep? l '())))
 293       (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
 294       )))
 295
 296
 297 (define-public (interval-length x)
 298   "Length of the number-pair X, when an interval"
 299   (max 0 (- (cdr x) (car x)))
 300   )
 301
 302
 303 (define (other-axis a)
 304   (remainder (+ a 1) 2))
 305
 306
 307 (define-public (interval-widen iv amount)
 308    (cons (- (car iv) amount)
 309          (+ (cdr iv) amount)))
 310
 311 (define-public (interval-union i1 i2)
 312    (cons (min (car i1) (car i2))
 313          (max (cdr i1) (cdr i2))))
 314
 315
 316 (define-public (write-me message x)
 317   "Return X.  Display MESSAGE and write X.  Handy for debugging, possibly turned off."
 318   (display message) (write x) (newline) x)
 319 ;;  x)
 320
 321 (define (index-cell cell dir)
 322   (if (equal? dir 1)
 323       (cdr cell)
 324       (car cell)))
 325
 326 (define (cons-map f x)
 327   "map F to contents of X"
 328   (cons (f (car x)) (f (cdr x))))
 329
 330
 331 (define-public (list-insert-separator lst between)
 332   "Create new list, inserting BETWEEN between elements of LIST"
 333   (define (conc x y )
 334     (if (eq? y #f)
 335         (list x)
 336         (cons x  (cons between y))
 337         ))
 338   (fold-right conc #f lst))
 339
 340 ;;;;;;;;;;;;;;;;
 341 ; other
 342 (define (sign x)
 343   (if (= x 0)
 344       0
 345       (if (< x 0) -1 1)))
 346
 347 (define-public (symbol<? l r)
 348   (string<? (symbol->string l) (symbol->string r)))
 349
 350 (define-public (!= l r)
 351   (not (= l r)))
 352
 353 (define-public (ly:load x)
 354   (let* (
 355          (fn (%search-load-path x))
 356
 357          )
 358     (if (ly:get-option 'verbose)
 359         (format (current-error-port) "[~A]" fn))
 360     (primitive-load fn)))
 361
 362
 363 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 364 ;;  output
 365 (use-modules (scm output-tex)
 366              (scm output-ps)
 367              (scm output-sketch)
 368              (scm output-sodipodi)
 369              (scm output-pdftex)
 370              )
 371
 372 (define output-alist
 373   `(
 374     ("tex" . ("TeX output. The default output form." ,tex-output-expression))
 375     ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression))
 376     ("scm" . ("Scheme dump: debug scheme stencil expressions" ,write))
 377     ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
 378     ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
 379     ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
 380     ))
 381
 382
 383 (define (document-format-dumpers)
 384   (map
 385    (lambda (x)
 386      (display (string-append  (pad-string-to 5 (car x)) (cadr x) "\n"))
 387      output-alist)
 388    ))
 389
 390 (define-public (find-dumper format )
 391   (let* ((d (assoc format output-alist)))
 392
 393     (if (pair? d)
 394         (caddr d)
 395         (scm-error "Could not find dumper for format ~s" format))))
 396
 397 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 398 ;; other files.
 399
 400 (map ly:load
 401      ;; load-from-path
 402      '("define-music-types.scm"
 403        "output-lib.scm"
 404        "c++.scm"
 405        "chord-ignatzek-names.scm"
 406        "chord-entry.scm"
 407        "chord-generic-names.scm"
 408        "stencil.scm"
 409        "new-markup.scm"
 410        "bass-figure.scm"
 411        "music-functions.scm"
 412        "part-combiner.scm"
 413        "define-music-properties.scm"
 414        "auto-beam.scm"
 415        "chord-name.scm"
 416
 417        "define-context-properties.scm"
 418        "translation-functions.scm"
 419        "script.scm"
 420        "midi.scm"
 421
 422        "beam.scm"
 423        "clef.scm"
 424        "slur.scm"
 425        "font.scm"
 426
 427        "define-markup-commands.scm"
 428        "define-grob-properties.scm"
 429        "define-grobs.scm"
 430        "define-grob-interfaces.scm"
 431
 432        "page-layout.scm"
 433        "paper.scm"
 434        ))
 435
 436
 437 (set! type-p-name-alist
 438   `(
 439    (,boolean-or-symbol? . "boolean or symbol")
 440    (,boolean? . "boolean")
 441    (,char? . "char")
 442    (,grob-list? . "list of grobs")
 443    (,hash-table? . "hash table")
 444    (,input-port? . "input port")
 445    (,integer? . "integer")
 446    (,list? . "list")
 447    (,ly:context? . "context")
 448    (,ly:dimension? . "dimension, in staff space")
 449    (,ly:dir? . "direction")
 450    (,ly:duration? . "duration")
 451    (,ly:grob? . "layout object")
 452    (,ly:input-location? . "input location")
 453    (,ly:moment? . "moment")
 454    (,ly:music? . "music")
 455    (,ly:pitch? . "pitch")
 456    (,ly:translator? . "translator")
 457    (,ly:font-metric? . "font metric")
 458    (,markup-list? . "list of markups")
 459    (,markup? . "markup")
 460    (,ly:music-list? . "list of music")
 461    (,number-or-grob? . "number or grob")
 462    (,number-or-string? . "number or string")
 463    (,number-pair? . "pair of numbers")
 464    (,number? . "number")
 465    (,output-port? . "output port")
 466    (,pair? . "pair")
 467    (,procedure? . "procedure")
 468    (,scheme? . "any type")
 469    (,string? . "string")
 470    (,symbol? . "symbol")
 471    (,vector? . "vector")
 472    ))
 473
 474
 475 ;; debug mem leaks
 476
 477 (define gc-protect-stat-count 0)
 478 (define-public (dump-gc-protects)
 479   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 480   (let*
 481       ((protects (sort
 482            (hash-table->alist (ly:protects))
 483            (lambda (a b)
 484              (< (object-address (car a))
 485                 (object-address (car b))))))
 486        (outfile    (open-file (string-append
 487                "gcstat-" (number->string gc-protect-stat-count)
 488                ".scm"
 489                ) "w"))
 490        )
 491
 492     (display
 493      (filter
 494       (lambda (x) (not (symbol? x)))
 495       (map (lambda (y)
 496              (let
 497                  ((x (car y))
 498                   (c (cdr y)))
 499
 500                (string-append
 501                 (string-join
 502                  (map object->string (list (object-address x) c x))
 503                  " ")
 504                 "\n")))
 505            protects))
 506      outfile)
 507
 508     ))
 509