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