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