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