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