X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=adb2bdfdc8ccde720798cb57a8d572885a221afc;hb=3e399689e122161ec09f5d0aa7f24795dc303a46;hp=58c8720d84421e8693b8b8e42c49b82a46d1d5dd;hpb=def21b306e2b8fa2d5630fab0878e9922e197f0c;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 58c8720d84..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--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. @@ -334,53 +337,29 @@ found." (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)) @@ -566,12 +545,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))) @@ -586,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))) @@ -606,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)) @@ -629,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")))