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