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