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