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