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