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--2002 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 (other-axis a)
 230   (remainder (+ a 1) 2))
 231
 232
 233 (define-public (widen-interval iv amount)
 234    (cons (- (car iv) amount)
 235          (+ (cdr iv) amount))
 236 )
 237
 238 (define-public (write-me message x)
 239   "Return X.  Display MESSAGE and write X.  Handy for debugging, possibly turned off."
 240   (display message) (write x) (newline) x)
 241 ;;  x)
 242
 243 (define (index-cell cell dir)
 244   (if (equal? dir 1)
 245       (cdr cell)
 246       (car cell)))
 247
 248 (define (cons-map f x)
 249   "map F to contents of X"
 250   (cons (f (car x)) (f (cdr x))))
 251
 252 ;; used where?
 253 (define-public (reduce operator list)
 254   "reduce OP [A, B, C, D, ... ] =
 255    A op (B op (C ... ))
 256 "
 257       (if (null? (cdr list)) (car list)
 258           (operator (car list) (reduce operator (cdr list)))))
 259
 260 (define (take-from-list-until todo gathered crit?)
 261   "return (G, T), where (reverse G) + T = GATHERED + TODO, and the last of G
 262 is the  first to satisfy CRIT
 263
 264  (take-from-list-until '(1 2 3  4 5) '() (lambda (x) (eq? x 3)))
 265 =>
 266  ((3 2 1) 4 5)
 267
 268 "
 269   (if (null? todo)
 270       (cons gathered todo)
 271       (if (crit? (car todo))
 272           (cons (cons (car todo) gathered) (cdr todo))
 273           (take-from-list-until (cdr todo) (cons (car todo) gathered) crit?)
 274       )
 275   ))
 276
 277 (define-public (list-insert-separator list between)
 278   "Create new list, inserting BETWEEN between elements of LIST"
 279   (if (null? list)
 280       '()
 281       (if (null? (cdr list))
 282           list
 283           (cons (car list)
 284                 (cons between (list-insert-separator (cdr list) between)))
 285
 286   )))
 287
 288 ;;;;;;;;;;;;;;;;
 289 ; strings.
 290
 291 (define-public (string-join str-list sep)
 292   "append the list of strings in STR-LIST, joining them with SEP"
 293   (apply string-append (list-insert-separator str-list sep))
 294   )
 295
 296 (define-public (pad-string-to str wid)
 297   (string-append str (make-string (max (- wid (string-length str)) 0) #\ ))
 298   )
 299
 300 ;;;;;;;;;;;;;;;;
 301 ; other
 302 (define (sign x)
 303   (if (= x 0)
 304       0
 305       (if (< x 0) -1 1)))
 306
 307 (define-public (!= l r)
 308   (not (= l r)))
 309
 310 (define-public (ly:load x)
 311   (let* (
 312          (fn (%search-load-path x))
 313
 314          )
 315     (if (ly:verbose)
 316         (format (current-error-port) "[~A]" fn))
 317     (primitive-load fn)))
 318
 319
 320 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 321 ;;  output
 322 (use-modules (scm tex)
 323              (scm ps)
 324              (scm pysk)
 325              (scm ascii-script)
 326              (scm sketch)
 327              (scm sodipodi)
 328              (scm pdftex)
 329              )
 330
 331 (define output-alist
 332   `(
 333     ("tex" . ("TeX output. The default output form." ,tex-output-expression))
 334     ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression))
 335     ("scm" . ("Scheme dump: debug scheme molecule expressions" ,write))
 336     ("as" . ("Asci-script. Postprocess with as2txt to get ascii art"  ,as-output-expression))
 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      '("music-types.scm"
 365        "output-lib.scm"
 366        "c++.scm"
 367        "chords-ignatzek.scm"
 368        "chord-entry.scm"
 369        "double-plus-new-chord-name.scm"
 370        "molecule.scm"
 371        "new-markup.scm"
 372        "bass-figure.scm"
 373        "music-functions.scm"
 374        "music-property-description.scm"
 375        "auto-beam.scm"
 376        "basic-properties.scm"
 377        "chord-name.scm"
 378        "translator-property-description.scm"
 379        "script.scm"
 380        "drums.scm"
 381        "midi.scm"
 382
 383        "beam.scm"
 384        "clef.scm"
 385        "slur.scm"
 386        "font.scm"
 387
 388        "grob-property-description.scm"
 389        "grob-description.scm"
 390        "context-description.scm"
 391        "interface-description.scm"
 392        ))
 393
 394
 395
 396
 397
 398 (set! type-p-name-alist
 399   `(
 400    (,ly:dir? . "direction")
 401    (,scheme? . "any type")
 402    (,number-pair? . "pair of numbers")
 403    (,ly:input-location? . "input location")
 404    (,ly:grob? . "grob (GRaphical OBject)")
 405    (,grob-list? . "list of grobs")
 406    (,ly:duration? . "duration")
 407    (,pair? . "pair")
 408    (,integer? . "integer")
 409    (,list? . "list")
 410    (,symbol? . "symbol")
 411    (,string? . "string")
 412    (,boolean? . "boolean")
 413    (,ly:pitch? . "pitch")
 414    (,ly:moment? . "moment")
 415    (,ly:dimension? . "dimension, in staff space")
 416    (,ly:input-location? . "input location")
 417    (,music-list? . "list of music")
 418    (,ly:music? . "music")
 419    (,number? . "number")
 420    (,char? . "char")
 421    (,input-port? . "input port")
 422    (,output-port? . "output port")
 423    (,vector? . "vector")
 424    (,procedure? . "procedure")
 425    (,boolean-or-symbol? . "boolean or symbol")
 426    (,number-or-string? . "number or string")
 427    (,markup? . "markup")
 428    (,markup-list? . "list of markups")
 429    (,number-or-grob? . "number or grob")
 430    ))