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