X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=adb2bdfdc8ccde720798cb57a8d572885a221afc;hb=7461c479c7a2e448b2d1da9759246b0cc1c9257a;hp=dc69ad5df74de3e5ebbd620ff679fb1e058caf4f;hpb=16cb456cabf477f6d398ff731aa0f10b60913394;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index dc69ad5df7..adb2bdfdc8 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -3,9 +3,12 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2006 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. @@ -56,18 +59,67 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; parser <-> 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-public (collect-music-aux score-handler parser music) + (define (music-property symbol) + (let ((value (ly:music-property music symbol))) + (if (not (null? value)) + value + #f))) + (cond ((music-property 'page-marker) + ;; a page marker: set page break/turn permissions or label + (begin + (let ((label (music-property 'page-label))) + (if (symbol? label) + (score-handler (ly:make-page-label-marker label)))) + (for-each (lambda (symbol) + (let ((permission (music-property symbol))) + (if (symbol? permission) + (score-handler + (ly:make-page-permission-marker symbol + (if (eqv? 'forbid permission) + '() + permission)))))) + (list 'line-break-permission 'page-break-permission + 'page-turn-permission)))) + ((not (music-property 'void)) + ;; a regular music expression: make a score with this music + ;; void music is discarded + (score-handler (scorify-music music parser))))) + (define-public (collect-music-for-book parser music) - ;; discard music if its 'void property is true. - (let ((void-music (ly:music-property music 'void))) - (if (or (null? void-music) (not void-music)) - (collect-scores-for-book parser (scorify-music music parser))))) + "Top-level music handler" + (collect-music-aux (lambda (score) + (collect-scores-for-book parser score)) + parser + music)) + +(define-public (collect-book-music-for-book parser book music) + "Book music handler" + (collect-music-aux (lambda (score) + (ly:book-add-score! book score)) + parser + music)) (define-public (scorify-music music parser) "Preprocess MUSIC." @@ -82,9 +134,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)) @@ -92,7 +148,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) )) @@ -118,14 +173,6 @@ (stringstring (car x)) (symbol->string (car y)))) -(define-public (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-public (chain-assoc-get x alist-list . default) "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not found." @@ -279,64 +326,40 @@ 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! (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)) @@ -380,6 +403,9 @@ found." (define-public interval-end cdr) +(define-public (interval-bound interval dir) + ((if (= dir RIGHT) cdr car) interval)) + (define-public (interval-index interval dir) "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)" @@ -423,9 +449,16 @@ found." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; - - +;; string + +(define-public (string-endswith s suffix) + (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") @@ -434,9 +467,6 @@ found." (make-string 1 (integer->char (+ 65 (modulo i 26)))) (string-encode-integer (quotient i 26)))))) -(define-public (ly:numbers->string lst) - (string-join (map ly:number->string lst) " ")) - (define (number->octal-string x) (let* ((n (inexact->exact x)) (n64 (quotient n 64)) @@ -454,6 +484,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, @@ -510,13 +545,30 @@ possibly turned off." (reverse matches)) ;;;;;;;;;;;;;;;; -; other +;; other + (define (sign x) (if (= x 0) 0 (if (< x 0) -1 1))) -(define-public (car< a b) (< (car a) (car b))) +(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))) (define-public (symbolstring lst) (symbol->string r))) @@ -528,11 +580,19 @@ possibly turned off." ;; 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))) @@ -548,17 +608,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)) @@ -571,16 +633,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")))