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