X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily.scm;h=9ceb5333ed322b51231d33c066404b21a5db8127;hb=a280a2653ee2b2eedaeed90865116ee5cdbc8590;hp=86243a87cfb22f4a454510278a8e4151f474ed5c;hpb=899a5926b98860f3d5db399616d9211927fbfa3c;p=lilypond.git diff --git a/scm/lily.scm b/scm/lily.scm index 86243a87cf..9ceb5333ed 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -1,22 +1,28 @@ -;;;; lily.scm -- implement Scheme output routines for TeX and PostScript +;;; lily.scm -- implement Scheme output routines for TeX and PostScript ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2002 Jan Nieuwenhuizen +;;;; (c) 1998--2003 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;; Library functions -(use-modules (ice-9 regex)) - +(use-modules (ice-9 regex) + (srfi srfi-1) ;lists + (srfi srfi-13) ;strings + ) ;;; General settings -;; debugging evaluator is slower. +;;; debugging evaluator is slower. This should +;;; have a more sensible default. -(debug-enable 'debug) -;(debug-enable 'backtrace) -(read-enable 'positions) + +(if (ly:get-option 'verbose) + (begin + (debug-enable 'debug) + (debug-enable 'backtrace) + (read-enable 'positions))) (define-public (line-column-location line col file) @@ -32,6 +38,16 @@ (define-public point-and-click #f) +(define-public (lilypond-version) + (string-join + (map (lambda (x) (if (symbol? x) + (symbol->string x) + (number->string x))) + (ly:version)) + ".")) + + + ;; cpp hack to get useful error message (define ifdef "First run this through cpp.") (define ifndef "First run this through cpp.") @@ -50,6 +66,19 @@ (define-public DOWN -1) (define-public CENTER 0) +(define-public DOUBLE-FLAT -4) +(define-public THREE-Q-FLAT -3) +(define-public FLAT -2) +(define-public SEMI-FLAT -1) +(define-public NATURAL 0) +(define-public SEMI-SHARP 1) +(define-public SHARP 2) +(define-public THREE-Q-SHARP 3) +(define-public DOUBLE-SHARP 4) +(define-public SEMI-TONE 2) + +(define-public ZERO-MOMENT (ly:make-moment 0 1)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; lily specific variables. (define-public default-script-alist '()) @@ -59,22 +88,186 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Unassorted utility functions. + +;;;;;;;;;;;;;;;; +; alist (define (uniqued-alist alist acc) (if (null? alist) acc (if (assoc (caar alist) acc) (uniqued-alist (cdr alist) acc) (uniqued-alist (cdr alist) (cons (car alist) acc))))) + +(define (assoc-get key alist) + "Return value if KEY in ALIST, else #f." + (let ((entry (assoc key alist))) + (if entry (cdr entry) #f))) + +(define (assoc-get-default key alist default) + "Return value if KEY in ALIST, else DEFAULT." + (let ((entry (assoc key alist))) + (if entry (cdr entry) default))) + + +(define-public (uniqued-alist alist acc) + (if (null? alist) acc + (if (assoc (caar alist) acc) + (uniqued-alist (cdr alist) acc) + (uniqued-alist (cdr alist) (cons (car alist) acc))))) + +(define-public (aliststring (car x)) + (symbol->string (car y)))) + + + +(define (chain-assoc x alist-list) + (if (null? alist-list) + #f + (let* ((handle (assoc x (car alist-list)))) + (if (pair? handle) + handle + (chain-assoc x (cdr alist-list)))))) + +(define (chain-assoc-get x alist-list default) + (if (null? alist-list) + default + (let* ((handle (assoc x (car alist-list)))) + (if (pair? handle) + (cdr handle) + (chain-assoc-get x (cdr alist-list) default))))) + + +(define (map-alist-vals func list) + "map FUNC over the vals of LIST, leaving the keys." + (if (null? list) + '() + (cons (cons (caar list) (func (cdar list))) + (map-alist-vals func (cdr list))) + )) + +(define (map-alist-keys func list) + "map FUNC over the keys of an alist LIST, leaving the vals. " + (if (null? list) + '() + (cons (cons (func (caar list)) (cdar list)) + (map-alist-keys func (cdr list))) + )) + + + +;;;;;;;;;;;;;;;; +; list + +(define (flatten-list lst) + "Unnest LST" + (if (null? lst) + '() + (if (pair? (car lst)) + (append (flatten-list (car lst)) (flatten-list (cdr lst))) + (cons (car lst) (flatten-list (cdr lst)))) + )) + +(define (list-minus a b) + "Return list of elements in A that are not in B." + (lset-difference eq? a b)) + + +;; TODO: use the srfi-1 partition function. +(define-public (uniq-list list) + "Uniq LIST, assuming that it is sorted" + (if (null? list) '() + (if (null? (cdr list)) + list + (if (equal? (car list) (cadr list)) + (uniq-list (cdr list)) + (cons (car list) (uniq-list (cdr list))))))) + +(define (split-at-predicate predicate l) + "Split L = (a_1 a_2 ... a_k b_1 ... b_k) +into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) +Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1). +L1 is copied, L2 not. + +(split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))" +;; " + +;; KUT EMACS MODE. + + (define (inner-split predicate l acc) + (cond + ((null? l) acc) + ((null? (cdr l)) + (set-car! acc (cons (car l) (car acc))) + acc) + ((predicate (car l) (cadr l)) + (set-car! acc (cons (car l) (car acc))) + (inner-split predicate (cdr l) acc)) + (else + (set-car! acc (cons (car l) (car acc))) + (set-cdr! acc (cdr l)) + acc) + + )) + (let* + ((c (cons '() '())) + ) + (inner-split predicate l c) + (set-car! c (reverse! (car c))) + c) +) + + +(define-public (split-list l sep?) +" +(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) ) +=> +((a b c) (d e f) (g)) + +" +;; " KUT EMACS. + +(define (split-one sep? l acc) + "Split off the first parts before separator and return both parts." + (if (null? l) + (cons acc '()) + (if (sep? (car l)) + (cons acc (cdr l)) + (split-one sep? (cdr l) (cons (car l) acc)) + ) + )) + +(if (null? l) + '() + (let* ((c (split-one sep? l '()))) + (cons (reverse! (car c) '()) (split-list (cdr c) sep?)) + ))) + + +(define-public (interval-length x) + "Length of the number-pair X, when an interval" + (max 0 (- (cdr x) (car x))) + ) + + (define (other-axis a) (remainder (+ a 1) 2)) -(define-public (widen-interval iv amount) +(define-public (interval-widen iv amount) (cons (- (car iv) amount) - (+ (cdr iv) amount)) -) + (+ (cdr iv) amount))) + + +(define-public (interval-union i1 i2) + (cons (min (car i1) (car i2)) + (max (cdr i1) (cdr i2)))) +(define-public (write-me message x) + "Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off." + (display message) (write x) (newline) x) +;; x) (define (index-cell cell dir) (if (equal? dir 1) @@ -85,101 +278,44 @@ "map F to contents of X" (cons (f (car x)) (f (cdr x)))) -;; used where? -(define-public (reduce operator list) - "reduce OP [A, B, C, D, ... ] = - A op (B op (C ... )) -" - (if (null? (cdr list)) (car list) - (operator (car list) (reduce operator (cdr list))))) - -(define (take-from-list-until todo gathered crit?) - "return (G, T), where (reverse G) + T = GATHERED + TODO, and the last of G -is the first to satisfy CRIT - - (take-from-list-until '(1 2 3 4 5) '() (lambda (x) (eq? x 3))) -=> - ((3 2 1) 4 5) -" - (if (null? todo) - (cons gathered todo) - (if (crit? (car todo)) - (cons (cons (car todo) gathered) (cdr todo)) - (take-from-list-until (cdr todo) (cons (car todo) gathered) crit?) - ) - )) +(define-public (list-insert-separator lst between) + "Create new list, inserting BETWEEN between elements of LIST" + (define (conc x y ) + (if (eq? y #f) + (list x) + (cons x (cons between y)) + )) + (fold-right conc #f lst)) +;;;;;;;;;;;;;;;; +; other (define (sign x) (if (= x 0) 0 (if (< x 0) -1 1))) -(define (write-me n x) - (display n) - (write x) - (newline) - x) - -(define (!= l r) +(define-public (!= l r) (not (= l r))) -(define-public (filter-list pred? list) - "return that part of LIST for which PRED is true." - (if (null? list) '() - (let* ((rest (filter-list pred? (cdr list)))) - (if (pred? (car list)) - (cons (car list) rest) - rest)))) - -(define-public (filter-out-list pred? list) - "return that part of LIST for which PRED is true." - (if (null? list) '() - (let* ((rest (filter-list pred? (cdr list)))) - (if (not (pred? (car list))) - (cons (car list) rest) - rest)))) - -(define-public (uniqued-alist alist acc) - (if (null? alist) acc - (if (assoc (caar alist) acc) - (uniqued-alist (cdr alist) acc) - (uniqued-alist (cdr alist) (cons (car alist) acc))))) - -(define-public (uniq-list list) - (if (null? list) '() - (if (null? (cdr list)) - list - (if (equal? (car list) (cadr list)) - (uniq-list (cdr list)) - (cons (car list) (uniq-list (cdr list))))))) - -(define-public (aliststring (car x)) - (symbol->string (car y)))) - -(define-public (pad-string-to str wid) - (string-append str (make-string (max (- wid (string-length str)) 0) #\ )) - ) - (define-public (ly:load x) (let* ( (fn (%search-load-path x)) ) - (if (ly:verbose) + (if (ly:get-option 'verbose) (format (current-error-port) "[~A]" fn)) (primitive-load fn))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; output -(use-modules (scm tex) - (scm ps) - (scm pysk) - (scm ascii-script) - (scm sketch) - (scm pdftex) +(use-modules (scm output-tex) + (scm output-ps) + (scm output-ascii-script) + (scm output-sketch) + (scm output-sodipodi) + (scm output-pdftex) ) (define output-alist @@ -188,7 +324,8 @@ is the first to satisfy CRIT ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression)) ("scm" . ("Scheme dump: debug scheme molecule expressions" ,write)) ("as" . ("Asci-script. Postprocess with as2txt to get ascii art" ,as-output-expression)) - ("sketch" . ("Bare bones Sketch output. Requires sketch 0.7" ,sketch-output-expression)) + ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression)) + ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression)) ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression)) )) @@ -214,27 +351,72 @@ is the first to satisfy CRIT (map ly:load ; load-from-path - '("music-types.scm" + '("define-music-types.scm" "output-lib.scm" "c++.scm" + "chord-ignatzek-names.scm" + "chord-entry.scm" + "chord-generic-names.scm" "molecule.scm" + "new-markup.scm" "bass-figure.scm" - "grob-property-description.scm" - "context-description.scm" - "interface-description.scm" - "beam.scm" - "clef.scm" - "slur.scm" - "font.scm" "music-functions.scm" - "music-property-description.scm" + "define-music-properties.scm" "auto-beam.scm" - "basic-properties.scm" "chord-name.scm" - "grob-description.scm" - "translator-property-description.scm" + + "define-translator-properties.scm" + "translation-functions.scm" "script.scm" "drums.scm" "midi.scm" + + "beam.scm" + "clef.scm" + "slur.scm" + "font.scm" + + "define-grob-properties.scm" + "define-grobs.scm" + "define-grob-interfaces.scm" )) + + + + +(set! type-p-name-alist + `( + (,boolean-or-symbol? . "boolean or symbol") + (,boolean? . "boolean") + (,char? . "char") + (,grob-list? . "list of grobs") + (,input-port? . "input port") + (,integer? . "integer") + (,list? . "list") + (,ly:context? . "context") + (,ly:dimension? . "dimension, in staff space") + (,ly:dir? . "direction") + (,ly:duration? . "duration") + (,ly:grob? . "grob (GRaphical OBject)") + (,ly:input-location? . "input location") + (,ly:input-location? . "input location") + (,ly:moment? . "moment") + (,ly:music? . "music") + (,ly:pitch? . "pitch") + (,ly:translator? . "translator") + (,markup-list? . "list of markups") + (,markup? . "markup") + (,music-list? . "list of music") + (,number-or-grob? . "number or grob") + (,number-or-string? . "number or string") + (,number-pair? . "pair of numbers") + (,number? . "number") + (,output-port? . "output port") + (,pair? . "pair") + (,procedure? . "procedure") + (,scheme? . "any type") + (,string? . "string") + (,symbol? . "symbol") + (,vector? . "vector") + ))