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