X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=e7f1d295d81ea98708163f173acf76e0f6067979;hb=2fab58f39ab5d5188c69af3500ffd4072031ea92;hp=068bbb2873688b478fd0cd31ca75a0200ab5bc1b;hpb=8c00ef0a0eb95417f6db5056c0c03b7cfa2e7571;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 068bbb2873..e7f1d295d8 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -2,10 +2,13 @@ ;;;; lily-library.scm -- utilities ;;;; ;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 1998--2007 Jan Nieuwenhuizen +;;;; +;;;; (c) 1998--2009 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys +; for take, drop, take-while, list-index, and find-tail: +(use-modules (srfi srfi-1)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; constants. @@ -44,11 +47,15 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; moments -(define-public ZERO-MOMENT (ly:make-moment 0 1)) +(define-public ZERO-MOMENT (ly:make-moment 0 1)) (define-public (moment-min a b) (if (ly:moment output hooks. - +(define-public (collect-bookpart-for-book parser book-part) + "Toplevel book-part handler" + (define (add-bookpart book-part) + (ly:parser-define! + parser 'toplevel-bookparts + (cons book-part (ly:parser-lookup parser 'toplevel-bookparts)))) + ;; If toplevel scores have been found before this \bookpart, + ;; add them first to a dedicated bookpart + (if (pair? (ly:parser-lookup parser 'toplevel-scores)) + (begin + (add-bookpart (ly:make-book-part + (ly:parser-lookup parser 'toplevel-scores))) + (ly:parser-define! parser 'toplevel-scores (list)))) + (add-bookpart book-part)) + (define-public (collect-scores-for-book parser score) (ly:parser-define! parser 'toplevel-scores (cons score (ly:parser-lookup parser 'toplevel-scores)))) -(define (collect-music-aux score-handler parser music) +(define-public (collect-music-aux score-handler parser music) (define (music-property symbol) (let ((value (ly:music-property music symbol))) (if (not (null? value)) @@ -106,7 +127,7 @@ (define-public (scorify-music music parser) "Preprocess MUSIC." - + (for-each (lambda (func) (set! music (func music parser))) toplevel-music-functions) @@ -117,9 +138,13 @@ (let* ((paper (ly:parser-lookup parser '$defaultpaper)) (layout (ly:parser-lookup parser '$defaultlayout)) - (count (ly:parser-lookup parser 'output-count)) - (base (ly:parser-output-name parser))) + (base (ly:parser-output-name parser)) + (output-suffix (ly:parser-lookup parser 'output-suffix)) ) + + (if (string? output-suffix) + (set! base (format "~a-~a" base (string-regexp-substitute + "[^a-zA-Z0-9-]" "_" output-suffix)))) ;; must be careful: output-count is under user control. (if (not (integer? count)) @@ -127,7 +152,6 @@ (if (> count 0) (set! base (format #f "~a-~a" base count))) - (ly:parser-define! parser 'output-count (1+ count)) (process-procedure book paper layout base) )) @@ -219,7 +243,7 @@ found." (hash-fold (lambda (k v acc) (acons k v acc)) '() t)) -;; todo: code dup with C++. +;; todo: code dup with C++. (define-safe-public (alist->hash-table lst) "Convert alist to table" (let ((m (make-hash-table (length lst)))) @@ -243,14 +267,14 @@ found." (define (split-list lst n) "Split LST in N equal sized parts" - + (define (helper todo acc-vector k) (if (null? todo) acc-vector (begin (if (< k 0) (set! k (+ n k))) - + (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k))) (helper (cdr todo) acc-vector (1- k))))) @@ -276,7 +300,7 @@ found." (reverse (helper lst '() 1))) - + (define-public (list-join lst intermediate) "put INTERMEDIATE between all elts of LST." @@ -294,7 +318,7 @@ found." (define (flatten-list lst) - "Unnest LST" + "Unnest LST" (if (null? lst) '() (if (pair? (car lst)) @@ -306,68 +330,44 @@ found." (lset-difference eq? a b)) (define-public (uniq-list lst) - "Uniq LST, assuming that it is sorted" + "Uniq LST, assuming that it is sorted. Uses equal? for comparisons." - (reverse! + (reverse! (fold (lambda (x acc) (if (null? acc) (list x) - (if (eq? x (car acc)) + (if (equal? x (car acc)) acc (cons x acc)))) '() lst) '())) -(define (split-at-predicate predicate lst) - "Split LST = (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 '() '()))" - - ;; " Emacs is broken - - (define (inner-split predicate lst acc) - (cond - ((null? lst) acc) - ((null? (cdr lst)) - (set-car! acc (cons (car lst) (car acc))) - acc) - ((predicate (car lst) (cadr lst)) - (set-car! acc (cons (car lst) (car acc))) - (inner-split predicate (cdr lst) acc)) - (else - (set-car! acc (cons (car lst) (car acc))) - (set-cdr! acc (cdr lst)) - acc))) - - (let* ((c (cons '() '()))) - (inner-split predicate lst c) - (set-car! c (reverse! (car c))) - c)) - -(define-public (split-list-by-separator lst sep?) - "(display (split-list-by-separator '(a b c / d e f / g) (lambda (x) (equal? x '/)))) - => - ((a b c) (d e f) (g)) - " - ;; " Emacs is broken - (define (split-one sep? lst acc) - "Split off the first parts before separator and return both parts." - (if (null? lst) - (cons acc '()) - (if (sep? (car lst)) - (cons acc (cdr lst)) - (split-one sep? (cdr lst) (cons (car lst) acc))))) - - (if (null? lst) - '() - (let* ((c (split-one sep? lst '()))) - (cons (reverse! (car c) '()) (split-list-by-separator (cdr c) sep?))))) +(define (split-at-predicate pred lst) + "Split LST into two lists at the first element that returns #f for + (PRED previous_element element). Return the two parts as a pair. + Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))" + (if (null? lst) + (list lst) + (let ((i (list-index pred (cdr lst) lst))) + (if i + (cons (take lst (1+ i)) (drop lst (1+ i))) + (list lst))))) + +(define-public (split-list-by-separator lst pred) + "Split LST at each element that satisfies PRED, and return the parts + (with the separators removed) as a list of lists. Example: + (split-list-by-separator '(a 0 b c 1 d) number?) ==> ((a) (b c) (d))" + (let loop ((result '()) (lst lst)) + (if (and lst (not (null? lst))) + (loop + (append result + (list (take-while (lambda (x) (not (pred x))) lst))) + (let ((tail (find-tail pred lst))) + (if tail (cdr tail) #f))) + result))) (define-public (offset-add a b) (cons (+ (car a) (car b)) - (+ (cdr a) (cdr b)))) + (+ (cdr a) (cdr b)))) (define-public (offset-flip-y o) (cons (car o) (- (cdr o)))) @@ -396,6 +396,8 @@ found." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; intervals +(define-public empty-interval '(+inf.0 . -inf.0)) + (define-public (interval-length x) "Length of the number-pair X, when an interval" (max 0 (- (cdr x) (car x)))) @@ -412,7 +414,7 @@ found." (define-public (interval-index interval dir) "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)" - + (* (+ (interval-start interval) (interval-end interval) (* dir (- (interval-end interval) (interval-start interval)))) 0.5)) @@ -451,6 +453,10 @@ found." (inf? (cdr i)) (> (car i) (cdr i))))) +(define-public (add-point interval p) + (cons (min (interval-start interval) p) + (max (interval-end interval) p))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; string @@ -459,10 +465,10 @@ found." (equal? suffix (substring s (max 0 (- (string-length s) (string-length suffix))) (string-length s)))) - + (define-public (string-startswith s prefix) (equal? prefix (substring s 0 (min (string-length s) (string-length prefix))))) - + (define-public (string-encode-integer i) (cond ((= i 0) "o") @@ -488,6 +494,11 @@ found." (string-append (ly:number->string (car c)) " " (ly:number->string (cdr c)))) +(define-public (dir-basename file . rest) + "Strip suffixes in REST, but leave directory component for FILE." + (define (inverse-basename x y) (basename y x)) + (simple-format #f "~a/~a" (dirname file) + (fold inverse-basename file rest))) (define-public (write-me message x) "Return X. Display MESSAGE and write X. Handy for debugging, @@ -521,7 +532,7 @@ possibly turned off." (fold-right conc #f lst)) (define-public (string-regexp-substitute a b str) - (regexp-substitute/global #f a str 'pre b 'post)) + (regexp-substitute/global #f a str 'pre b 'post)) (define (regexp-split str regex) (define matches '()) @@ -544,12 +555,27 @@ possibly turned off." (reverse matches)) ;;;;;;;;;;;;;;;; -; other +;; other + (define (sign x) (if (= x 0) 0 (if (< x 0) -1 1))) +(define-public (binary-search start end getter target-val) + (_i "Find the index between @var{start} and @var{end} (an integer) +which will produce the closest match to @var{target-val} when +applied to function @var{getter}.") + (if (<= end start) + start + (let* ((compare (quotient (+ start end) 2)) + (get-val (getter compare))) + (cond + ((< target-val get-val) + (set! end (1- compare))) + ((< get-val target-val) + (set! start (1+ compare)))) + (binary-search start end getter target-val)))) (define-public (car< a b) (< (car a) (car b))) @@ -561,14 +587,22 @@ possibly turned off." (stringstring (car lst)) (symbol->string (car r)))) ;; -;; don't confuse users with # syntax. -;; +;; don't confuse users with # syntax. +;; (define-public (scm->string val) - (if (and (procedure? val) (symbol? (procedure-name val))) + (if (and (procedure? val) + (symbol? (procedure-name val))) (symbol->string (procedure-name val)) (string-append - (if (self-evaluating? val) "" "'") - (call-with-output-string (lambda (port) (display val port)))))) + (if (self-evaluating? val) + (if (string? val) + "\"" + "") + "'") + (call-with-output-string (lambda (port) (display val port))) + (if (string? val) + "\"" + "")))) (define-public (!= lst r) (not (= lst r))) @@ -584,17 +618,19 @@ possibly turned off." ;;; FONT may be font smob, or pango font string... (define-public (font-name-style font) - ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended. + ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler + (if (and (string? font) + (string-prefix? "feta-alphabet" font)) + (string-append "emmentaler" + "-" + (substring font + (string-length "feta-alphabet") + (string-length font))) (let* ((font-name (ly:font-name font)) - (full-name (if font-name font-name (ly:font-file-name font))) - (name-style (string-split full-name #\-))) - ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler - (if (string-prefix? "feta-alphabet" full-name) - (list "emmentaler" - (substring full-name (string-length "feta-alphabet"))) - (if (not (null? (cdr name-style))) - name-style - (append name-style '("Regular")))))) + (full-name (if font-name font-name (ly:font-file-name font)))) + (if (string-prefix? "Aybabtu" full-name) + "aybabtu" + (string-downcase full-name))))) (define-public (modified-font-metric-font-scaling font) (let* ((designsize (ly:font-design-size font)) @@ -607,16 +643,16 @@ possibly turned off." (define-public (version-not-seen-message input-file-name) (ly:message - "~a:0: ~a: ~a" + "~a:0: ~a ~a" input-file-name - (_ "warning: ") + (_ "warning:") (format #f (_ "no \\version statement found, please add~afor future compatibility") (format #f "\n\n\\version ~s\n\n" (lilypond-version))))) (define-public (old-relative-not-used-message input-file-name) (ly:message - "~a:0: ~a: ~a" + "~a:0: ~a ~a" input-file-name - (_ "warning: ") + (_ "warning:") (_ "old relative compatibility not used")))