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