X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=34c9cb3820096c04603fd358393651bb165491e1;hb=4a03918c90866800b208ad12ffc019f577c8ab83;hp=335c345c3c0e345f6fd7b2b7b493be9f421759d5;hpb=cb01be4028886109ecc4772234452965ce7dfb66;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 335c345c3c..34c9cb3820 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -1,10 +1,20 @@ +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; lily-library.scm -- utilities +;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen +;;;; Han-Wen Nienhuys ;;;; -;;;; source file of the GNU LilyPond music typesetter +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. ;;;; -;;;; (c) 1998--2009 Jan Nieuwenhuizen -;;;; Han-Wen Nienhuys +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . ; for take, drop, take-while, list-index, and find-tail: (use-modules (srfi srfi-1)) @@ -56,6 +66,15 @@ (or (equal? a b) (ly:momentmoment fraction) + (if (null? fraction) + ZERO-MOMENT + (ly:make-moment (car fraction) (cdr fraction)))) + +(define-public (moment->fraction moment) + (cons (ly:moment-main-numerator moment) + (ly:moment-main-denominator moment))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; arithmetic (define-public (average x . lst) @@ -65,7 +84,7 @@ ;; parser <-> output hooks. (define-public (collect-bookpart-for-book parser book-part) - "Toplevel book-part handler" + "Toplevel book-part handler." (define (add-bookpart book-part) (ly:parser-define! parser 'toplevel-bookparts @@ -112,21 +131,21 @@ (score-handler (scorify-music music parser))))) (define-public (collect-music-for-book parser music) - "Top-level music handler" + "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" + "Book music handler." (collect-music-aux (lambda (score) (ly:book-add-score! book score)) parser music)) (define-public (scorify-music music parser) - "Preprocess MUSIC." + "Preprocess @var{music}." (for-each (lambda (func) (set! music (func music parser))) @@ -135,33 +154,59 @@ (ly:make-score music)) -(define (get-outfile-name parser base) - (let* ((output-suffix (ly:parser-lookup parser 'output-suffix)) +(define (get-current-filename parser) + "return any suffix value for output filename allowing for settings by +calls to bookOutputName function" + (let ((book-filename (ly:parser-lookup parser 'book-filename))) + (if (not book-filename) + (ly:parser-output-name parser) + book-filename))) + +(define (get-current-suffix parser) + "return any suffix value for output filename allowing for settings by calls to +bookoutput function" + (let ((book-output-suffix (ly:parser-lookup parser 'book-output-suffix))) + (if (not (string? book-output-suffix)) + (ly:parser-lookup parser 'output-suffix) + book-output-suffix))) + +(define-public current-outfile-name #f) ; for use by regression tests + +(define (get-outfile-name parser) + "return current filename for generating backend output files" + ;; user can now override the base file name, so we have to use + ;; the file-name concatenated with any potential output-suffix value + ;; as the key to out internal a-list + (let* ((base-name (get-current-filename parser)) + (output-suffix (get-current-suffix parser)) + (alist-key (format #f "~a~a" base-name output-suffix)) (counter-alist (ly:parser-lookup parser 'counter-alist)) - (output-count (assoc-get output-suffix counter-alist 0)) - (result base)) + (output-count (assoc-get alist-key counter-alist 0)) + (result base-name)) ;; Allow all ASCII alphanumerics, including accents (if (string? output-suffix) - (set! result (format "~a-~a" - base (string-regexp-substitute - "[^-[:alnum:]]" "_" output-suffix)))) + (set! result + (format #f "~a-~a" + result + (string-regexp-substitute + "[^-[:alnum:]]" + "_" + output-suffix)))) ;; assoc-get call will always have returned a number (if (> output-count 0) - (set! result (format #f "~a-~a" result output-count))) + (set! result (format #f "~a-~a" result output-count))) (ly:parser-define! - parser 'counter-alist - (assoc-set! counter-alist output-suffix (1+ output-count))) + parser 'counter-alist + (assoc-set! counter-alist alist-key (1+ output-count))) + (set! current-outfile-name result) result)) (define (print-book-with parser book process-procedure) (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)) - (outfile-name (get-outfile-name parser base))) - + (outfile-name (get-outfile-name parser))) (process-procedure book paper layout outfile-name))) (define-public (print-book-with-defaults parser book) @@ -197,6 +242,8 @@ (define-public assoc-get ly:assoc-get) +(define-public chain-assoc-get ly:chain-assoc-get) + (define-public (uniqued-alist alist acc) (if (null? alist) acc (if (assoc (caar alist) acc) @@ -207,21 +254,6 @@ (stringstring (car x)) (symbol->string (car y)))) -(define-public (chain-assoc-get x alist-list . default) - "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not -found." - - (define (helper x alist-list default) - (if (null? alist-list) - default - (let* ((handle (assoc x (car alist-list)))) - (if (pair? handle) - (cdr handle) - (helper x (cdr alist-list) default))))) - - (helper x alist-list - (if (pair? default) (car default) #f))) - (define (map-alist-vals func list) "map FUNC over the vals of LIST, leaving the keys." (if (null? list) @@ -230,21 +262,22 @@ found." (map-alist-vals func (cdr list))))) (define (map-alist-keys func list) - "map FUNC over the keys of an alist LIST, leaving the vals. " + "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))))) (define-public (first-member members lst) - "Return first successful MEMBER of member from MEMBERS in LST." + "Return first successful member (of member) from @var{members} in +@var{lst}." (if (null? members) #f (let ((m (member (car members) lst))) (if m m (first-member (cdr members) lst))))) (define-public (first-assoc keys lst) - "Return first successful ASSOC of key from KEYS in LST." + "Return first successful assoc of key from @var{keys} in @var{lst}." (if (null? keys) #f (let ((k (assoc (car keys) lst))) @@ -257,6 +290,40 @@ found." (cons (cdar alist) (flatten-alist (cdr alist)))))) +(define (assoc-remove key alist) + "Remove key (and its corresponding value) from an alist. + Different than assoc-remove! because it is non-destructive." + (define (assoc-crawler key l r) + (if (null? r) + l + (if (equal? (caar r) key) + (append l (cdr r)) + (assoc-crawler key (append l `(,(car r))) (cdr r))))) + (assoc-crawler key '() alist)) + +(define-public (map-selected-alist-keys function keys alist) + "Return @var{alist} with @var{function} applied to all of the values +in list @var{keys}. + +For example: +@example +@code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))} +@code{((a . -1) (b . 2) (c . 3) (d . 4)} +@end example" + (define (map-selected-alist-keys-helper function key alist) + (map + (lambda (pair) + (if (equal? key (car pair)) + (cons key (function (cdr pair))) + pair)) + alist)) + (if (null? keys) + alist + (map-selected-alist-keys + function + (cdr keys) + (map-selected-alist-keys-helper function (car keys) alist)))) + ;;;;;;;;;;;;;;;; ;; vector @@ -286,7 +353,7 @@ found." (define (functional-or . rest) (if (pair? rest) (or (car rest) - (apply functional-and (cdr rest))) + (apply functional-or (cdr rest))) #f)) (define (functional-and . rest) @@ -321,7 +388,8 @@ found." (helper lst 0)) (define-public (count-list lst) - "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... ) " + "Given @var{lst} as @code{(E1 E2 .. )}, return +@code{((E1 . 1) (E2 . 2) ... )}." (define (helper l acc count) (if (pair? l) @@ -332,7 +400,7 @@ found." (reverse (helper lst '() 1))) (define-public (list-join lst intermediate) - "put INTERMEDIATE between all elts of LST." + "Put @var{intermediate} between all elts of @var{lst}." (fold-right (lambda (elem prev) @@ -346,21 +414,20 @@ found." (lambda (x) x) (map proc lst))) - -(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-public (flatten-list x) + "Unnest list." + (cond ((null? x) '()) + ((not (pair? x)) (list x)) + (else (append (flatten-list (car x)) + (flatten-list (cdr x)))))) (define (list-minus a b) "Return list of elements in A that are not in B." (lset-difference eq? a b)) (define-public (uniq-list lst) - "Uniq LST, assuming that it is sorted. Uses equal? for comparisons." + "Uniq @var{lst}, assuming that it is sorted. Uses @code{equal?} +for comparisons." (reverse! (fold (lambda (x acc) @@ -373,19 +440,22 @@ found." (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. + (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))) + (let ((i (list-index (lambda (x y) (not (pred x y))) + lst + (cdr 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))" + "Split @var{lst} at each element that satisfies @var{pred}, and return +the parts (with the separators removed) as a list of lists. For example, +executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns +@samp{((a) (b c) (d))}." (let loop ((result '()) (lst lst)) (if (and lst (not (null? lst))) (loop @@ -412,17 +482,6 @@ found." (cons (cons (car coords) (cadr coords)) (ly:list->offsets accum (cddr coords))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; numbers - -(if (not (defined? 'nan?)) ;; guile 1.6 compat - (define-public (nan? x) (not (or (< 0.0 x) - (> 0.0 x) - (= 0.0 x))))) - -(if (not (defined? 'inf?)) - (define-public (inf? x) (= (/ 1.0 x) 0.0))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; intervals @@ -432,7 +491,7 @@ found." (cons (- expr) expr)) (define-public (interval-length x) - "Length of the number-pair X, when an interval" + "Length of the number-pair @var{x}, if an interval." (max 0 (- (cdr x) (car x)))) (define-public (ordered-cons a b) @@ -443,14 +502,15 @@ found." ((if (= dir RIGHT) cdr car) interval)) (define-public (interval-index interval dir) - "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)" + "Interpolate @var{interval} between between left (@var{dir}=-1) and +right (@var{dir}=+1)." (* (+ (interval-start interval) (interval-end interval) (* dir (- (interval-end interval) (interval-start interval)))) 0.5)) (define-public (interval-center x) - "Center the number-pair X, when an interval" + "Center the number-pair @var{x}, if an interval." (if (interval-empty? x) 0.0 (/ (+ (car x) (cdr x)) 2))) @@ -459,27 +519,25 @@ found." (define-public interval-end cdr) -(define-public (interval-translate iv amount) - (cons (+ amount (car iv)) - (+ amount (cdr iv)))) - (define (other-axis a) (remainder (+ a 1) 2)) (define-public (interval-widen iv amount) - (cons (- (car iv) amount) - (+ (cdr iv) amount))) + (cons (- (car iv) amount) + (+ (cdr iv) amount))) (define-public (interval-empty? iv) (> (car iv) (cdr iv))) (define-public (interval-union i1 i2) - (cons (min (car i1) (car i2)) - (max (cdr i1) (cdr i2)))) + (cons + (min (car i1) (car i2)) + (max (cdr i1) (cdr i2)))) (define-public (interval-intersection i1 i2) - (cons (max (car i1) (car i2)) - (min (cdr i1) (cdr i2)))) + (cons + (max (car i1) (car i2)) + (min (cdr i1) (cdr i2)))) (define-public (interval-sane? i) (not (or (nan? (car i)) @@ -492,6 +550,105 @@ found." (cons (min (interval-start interval) p) (max (interval-end interval) p))) +(define-public (reverse-interval iv) + (cons (cdr iv) (car iv))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; coordinates + +(define coord-x car) +(define coord-y cdr) + +(define (coord-operation operator operand coordinate) + (if (pair? operand) + (cons (operator (coord-x operand) (coord-x coordinate)) + (operator (coord-y operand) (coord-y coordinate))) + (cons (operator operand (coord-x coordinate)) + (operator operand (coord-y coordinate))))) + +(define (coord-apply function coordinate) + (if (pair? function) + (cons + ((coord-x function) (coord-x coordinate)) + ((coord-y function) (coord-y coordinate))) + (cons + (function (coord-x coordinate)) + (function (coord-y coordinate))))) + +(define-public (coord-translate coordinate amount) + (coord-operation + amount coordinate)) + +(define-public (coord-scale coordinate amount) + (coord-operation * amount coordinate)) + +(define-public (coord-rotate coordinate degrees-in-radians) + (let* + ((coordinate + (cons + (exact->inexact (coord-x coordinate)) + (exact->inexact (coord-y coordinate)))) + (radius + (sqrt + (+ (* (coord-x coordinate) (coord-x coordinate)) + (* (coord-y coordinate) (coord-y coordinate))))) + (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate))))) + (cons + (* radius (cos (+ angle degrees-in-radians))) + (* radius (sin (+ angle degrees-in-radians)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; trig + +(define-public PI (* 4 (atan 1))) + +(define-public TWO-PI (* 2 PI)) + +(define-public PI-OVER-TWO (/ PI 2)) + +(define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO)) + +(define-public (cyclic-base-value value cycle) + "Take @var{value} and modulo-maps it between 0 and base @var{cycle}." + (if (< value 0) + (cyclic-base-value (+ value cycle) cycle) + (if (>= value cycle) + (cyclic-base-value (- value cycle) cycle) + value))) + +(define-public (angle-0-2pi angle) + "Take @var{angle} (in radians) and maps it between 0 and 2pi." + (cyclic-base-value angle TWO-PI)) + +(define-public (angle-0-360 angle) + "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees." + (cyclic-base-value angle 360.0)) + +(define-public PI-OVER-180 (/ PI 180)) + +(define-public (degrees->radians angle-degrees) + "Convert the given angle from degrees to radians." + (* angle-degrees PI-OVER-180)) + +(define-public (ellipse-radius x-radius y-radius angle) + (/ + (* x-radius y-radius) + (sqrt + (+ (* (expt y-radius 2) + (* (cos angle) (cos angle))) + (* (expt x-radius 2) + (* (sin angle) (sin angle))))))) + +(define-public (polar->rectangular radius angle-in-degrees) + "Return polar coordinates (@var{radius}, @var{angle-in-degrees}) +as rectangular coordinates @ode{(x-length . y-length)}." + + (let ((complex (make-polar + radius + (degrees->radians angle-in-degrees)))) + (cons + (real-part complex) + (imag-part complex)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; string @@ -529,14 +686,15 @@ found." (ly:number->string (cdr c)))) (define-public (dir-basename file . rest) - "Strip suffixes in REST, but leave directory component for FILE." + "Strip suffixes in @var{rest}, but leave directory component for +@var{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, -possibly turned off." + "Return @var{x}. Display @var{message} and write @var{x}. +Handy for debugging, possibly turned off." (display message) (write x) (newline) x) ;; x) @@ -558,7 +716,7 @@ possibly turned off." (cons (f (car x)) (f (cdr x)))) (define-public (list-insert-separator lst between) - "Create new list, inserting BETWEEN between elements of LIST" + "Create new list, inserting @var{between} between elements of @var{lst}." (define (conc x y ) (if (eq? y #f) (list x) @@ -588,6 +746,23 @@ possibly turned off." (reverse matches)) +(define-public (random-string pool n) + "Produces a random lowercase string of length n" + (define (helper alphabet out num) + (let ((rand (random (string-length pool)))) + (if (< num 1) + out + (helper alphabet + (string-concatenate `(,out + ,(substring alphabet + rand + (+ 1 rand)))) + (- num 1))))) + (helper pool "" n)) + +(define-public (random-lowercase-string n) + (random-string "abcdefghijklmnopqrstuvwxyz" n)) + ;;;;;;;;;;;;;;;; ;; other @@ -598,7 +773,7 @@ possibly turned off." (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 +which produces the closest match to @var{target-val} if applied to function @var{getter}.") (if (<= end start) start @@ -614,12 +789,38 @@ applied to function @var{getter}.") (define-public (car< a b) (< (car a) (car b))) +(define-public (car<= a b) + (<= (car a) (car b))) + (define-public (symbolstring lst) (symbol->string r))) (define-public (symbol-keystring (car lst)) (symbol->string (car r)))) +(define-public (eval-carefully symbol module . default) + "Check whether all symbols in expr @var{symbol} are reachable +in module @var{module}. In that case evaluate, otherwise +print a warning and set an optional @var{default}." + (let* ((unavailable? (lambda (sym) + (not (module-defined? module sym)))) + (sym-unavailable (if (pair? symbol) + (filter + unavailable? + (filter symbol? (flatten-list symbol))) + (if (unavailable? symbol) + #t + '())))) + (if (null? sym-unavailable) + (eval symbol module) + (let* ((def (and (pair? default) (car default)))) + (ly:programming-error + "cannot evaluate ~S in module ~S, setting to ~S" + (object->string symbol) + (object->string module) + (object->string def)) + def)))) + ;; ;; don't confuse users with # syntax. ;; @@ -652,19 +853,11 @@ applied to function @var{getter}.") ;;; FONT may be font smob, or pango font string... (define-public (font-name-style font) - ;; 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))) + (if (string? font) + (string-downcase font) (let* ((font-name (ly:font-name font)) (full-name (if font-name font-name (ly:font-file-name font)))) - (if (string-prefix? "Aybabtu" full-name) - "aybabtu" - (string-downcase full-name))))) + (string-downcase full-name)))) (define-public (modified-font-metric-font-scaling font) (let* ((designsize (ly:font-design-size font))