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   (if (null? list) '()
 123       (let* ((rest (filter-list pred? (cdr list))))
 124         (if (pred? (car list))
 125             (cons (car list)  rest)
 126             rest))))
 127
 128 (define-public (filter-out-list pred? list)
 129   "return that part of LIST for which PRED is false."
 130   (if (null? list) '()
 131       (let* ((rest (filter-out-list pred? (cdr list))))
 132         (if (not (pred? (car list)))
 133             (cons (car list)  rest)
 134             rest))))
 135
 136
 137 (define (first-n n lst)
 138   "Return first N elements of LST"
 139   (if (and (pair? lst)
 140            (> n 0))
 141       (cons (car lst) (first-n (- n 1) (cdr lst)))
 142       '()))
 143
 144 (define-public (uniq-list list)
 145   (if (null? list) '()
 146       (if (null? (cdr list))
 147           list
 148           (if (equal? (car list) (cadr list))
 149               (uniq-list (cdr list))
 150               (cons (car list) (uniq-list (cdr list)))))))
 151
 152 (define (butfirst-n n lst)
 153   "Return all but first N entries of LST"
 154   (if (pair? lst)
 155       (if (> n 0)
 156           (butfirst-n (- n 1) (cdr lst))
 157           lst)
 158       '()))
 159
 160 (define (split-at predicate l)
 161  "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
 162 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 163 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 164 L1 is copied, L2 not.
 165
 166 (split-at (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
 167 ;; "
 168
 169 ;; KUT EMACS MODE.
 170
 171   (define (inner-split predicate l acc)
 172   (cond
 173    ((null? l) acc)
 174    ((null? (cdr l))
 175     (set-car! acc (cons (car l) (car acc)))
 176     acc)
 177    ((predicate (car l) (cadr l))
 178     (set-car! acc (cons (car l) (car acc)))
 179     (inner-split predicate (cdr l) acc))
 180    (else
 181     (set-car! acc (cons (car l) (car acc)))
 182     (set-cdr! acc (cdr l))
 183     acc)
 184
 185   ))
 186  (let*
 187     ((c (cons '() '()))
 188      )
 189   (inner-split predicate l  c)
 190   (set-car! c (reverse! (car c)))
 191   c)
 192 )
 193
 194
 195 (define (other-axis a)
 196   (remainder (+ a 1) 2))
 197
 198
 199 (define-public (widen-interval iv amount)
 200    (cons (- (car iv) amount)
 201          (+ (cdr iv) amount))
 202 )
 203
 204 (define-public (write-me message x)
 205   "Return X.  Display MESSAGE and write X.  Handy for debugging, possibly turned off."
 206   (display message) (write x) (newline) x)
 207 ;;  x)
 208
 209 (define (index-cell cell dir)
 210   (if (equal? dir 1)
 211       (cdr cell)
 212       (car cell)))
 213
 214 (define (cons-map f x)
 215   "map F to contents of X"
 216   (cons (f (car x)) (f (cdr x))))
 217
 218 ;; used where?
 219 (define-public (reduce operator list)
 220   "reduce OP [A, B, C, D, ... ] =
 221    A op (B op (C ... ))
 222 "
 223       (if (null? (cdr list)) (car list)
 224           (operator (car list) (reduce operator (cdr list)))))
 225
 226 (define (take-from-list-until todo gathered crit?)
 227   "return (G, T), where (reverse G) + T = GATHERED + TODO, and the last of G
 228 is the  first to satisfy CRIT
 229
 230  (take-from-list-until '(1 2 3  4 5) '() (lambda (x) (eq? x 3)))
 231 =>
 232  ((3 2 1) 4 5)
 233
 234 "
 235   (if (null? todo)
 236       (cons gathered todo)
 237       (if (crit? (car todo))
 238           (cons (cons (car todo) gathered) (cdr todo))
 239           (take-from-list-until (cdr todo) (cons (car todo) gathered) crit?)
 240       )
 241   ))
 242
 243 (define-public (list-insert-separator list between)
 244   "Create new list, inserting BETWEEN between elements of LIST"
 245   (if (null? list)
 246       '()
 247       (if (null? (cdr list))
 248           list
 249           (cons (car list)
 250                 (cons between (list-insert-separator (cdr list) between)))
 251
 252   )))
 253
 254 ;;;;;;;;;;;;;;;;
 255 ; strings.
 256
 257 (define-public (string-join str-list sep)
 258   "append the list of strings in STR-LIST, joining them with SEP"
 259   (apply string-append (list-insert-separator str-list sep))
 260   )
 261
 262 (define-public (pad-string-to str wid)
 263   (string-append str (make-string (max (- wid (string-length str)) 0) #\ ))
 264   )
 265
 266 ;;;;;;;;;;;;;;;;
 267 ; other
 268 (define (sign x)
 269   (if (= x 0)
 270       0
 271       (if (< x 0) -1 1)))
 272
 273 (define-public (!= l r)
 274   (not (= l r)))
 275
 276 (define-public (ly:load x)
 277   (let* (
 278          (fn (%search-load-path x))
 279
 280          )
 281     (if (ly:verbose)
 282         (format (current-error-port) "[~A]" fn))
 283     (primitive-load fn)))
 284
 285
 286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 287 ;;  output
 288 (use-modules (scm tex)
 289              (scm ps)
 290              (scm pysk)
 291              (scm ascii-script)
 292              (scm sketch)
 293              (scm sodipodi)
 294              (scm pdftex)
 295              )
 296
 297 (define output-alist
 298   `(
 299     ("tex" . ("TeX output. The default output form." ,tex-output-expression))
 300     ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression))
 301     ("scm" . ("Scheme dump: debug scheme molecule expressions" ,write))
 302     ("as" . ("Asci-script. Postprocess with as2txt to get ascii art"  ,as-output-expression))
 303     ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
 304     ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
 305     ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
 306     ))
 307
 308
 309 (define (document-format-dumpers)
 310   (map
 311    (lambda (x)
 312      (display (string-append  (pad-string-to 5 (car x)) (cadr x) "\n"))
 313      output-alist)
 314    ))
 315
 316 (define-public (find-dumper format )
 317   (let*
 318       ((d (assoc format output-alist)))
 319
 320     (if (pair? d)
 321         (caddr d)
 322         (scm-error "Could not find dumper for format ~s" format))
 323     ))
 324
 325 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 326 ;; other files.
 327
 328 (map ly:load
 329                                         ; load-from-path
 330      '("music-types.scm"
 331        "output-lib.scm"
 332        "c++.scm"
 333        "chords-ignatzek.scm"
 334        "chord-entry.scm"
 335        "double-plus-new-chord-name.scm"
 336        "molecule.scm"
 337        "bass-figure.scm"
 338        "grob-property-description.scm"
 339        "context-description.scm"
 340        "interface-description.scm"
 341        "beam.scm"
 342        "clef.scm"
 343        "slur.scm"
 344        "font.scm"
 345        "music-functions.scm"
 346        "music-property-description.scm"
 347        "auto-beam.scm"
 348        "new-markup.scm"
 349        "basic-properties.scm"
 350        "chord-name.scm"
 351        "grob-description.scm"
 352        "translator-property-description.scm"
 353        "script.scm"
 354        "drums.scm"
 355        "midi.scm"
 356        ))
 357
 358
 359
 360
 361
 362 (set! type-p-name-alist
 363   `(
 364    (,ly:dir? . "direction")
 365    (,scheme? . "any type")
 366    (,number-pair? . "pair of numbers")
 367    (,ly:input-location? . "input location")
 368    (,ly:grob? . "grob (GRaphical OBject)")
 369    (,grob-list? . "list of grobs")
 370    (,ly:duration? . "duration")
 371    (,pair? . "pair")
 372    (,integer? . "integer")
 373    (,list? . "list")
 374    (,symbol? . "symbol")
 375    (,string? . "string")
 376    (,boolean? . "boolean")
 377    (,ly:pitch? . "pitch")
 378    (,ly:moment? . "moment")
 379    (,ly:input-location? . "input location")
 380    (,music-list? . "list of music")
 381    (,ly:music? . "music")
 382    (,number? . "number")
 383    (,char? . "char")
 384    (,input-port? . "input port")
 385    (,output-port? . "output port")
 386    (,vector? . "vector")
 387    (,procedure? . "procedure")
 388    (,boolean-or-symbol? . "boolean or symbol")
 389    (,number-or-string? . "number or string")
 390    (,markup? . "markup")
 391    (,markup-list? . "list of markups")
 392    (,number-or-grob? . "number or grob")
 393    ))