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