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