X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=d87bca208ac8e370679f35d622c5bef5d8d906ca;hb=8b39eb741ede02e7e930fbf6ac107c76133d02fd;hp=ede65ff5e2a54b88d303e0a2429e3980384c7022;hpb=fb0b572f923f29e02bc9909a4cf5cc674e5315d5;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index ede65ff5e2..d87bca208a 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -19,6 +19,9 @@ ; for take, drop, take-while, list-index, and find-tail: (use-modules (srfi srfi-1)) +; for define-safe-public when byte-compiling using Guile V2 +(use-modules (scm safe-utility-defs)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; constants. @@ -54,6 +57,8 @@ (define-safe-public DOUBLE-SHARP 1) (define-safe-public SEMI-TONE 1/2) +(define-safe-public INFINITY-INT 1000000) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; moments @@ -75,6 +80,42 @@ (cons (ly:moment-main-numerator moment) (ly:moment-main-denominator moment))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; durations + +(define-public (duration-log-factor lognum) +"Given a logarithmic duration number, return the length of the duration, +as a number of whole notes." + (or (and (exact? lognum) (integer? lognum)) + (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f)) + (if (<= lognum 0) + (ash 1 (- lognum)) + (/ (ash 1 lognum)))) + +(define-public (duration-dot-factor dotcount) +"Given a count of the dots used to extend a musical duration, return +the numeric factor by which they increase the duration." + (or (and (exact? dotcount) (integer? dotcount) (>= dotcount 0)) + (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f)) + (- 2 (/ (ash 1 dotcount)))) + +(define-public (duration-length dur) +"Return the overall length of a duration, as a number of whole notes. +(Not to be confused with ly:duration-length, which returns a less-useful +moment object.)" + (ly:moment-main (ly:duration-length dur))) + +(define-public (duration-visual dur) +"Given a duration object, return the visual part of the duration (base +note length and dot count), in the form of a duration object with +non-visual scale factor 1." + (ly:make-duration (ly:duration-log dur) (ly:duration-dot-count dur) 1)) + +(define-public (duration-visual-length dur) +"Given a duration object, return the length of the visual part of the +duration (base note length and dot count), as a number of whole notes." + (duration-length (duration-visual dur))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; arithmetic (define-public (average x . lst) @@ -105,27 +146,23 @@ (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))) + (ly:music-property music symbol #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)) + (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 (eq? 'forbid permission) + '() + permission)))))) + '(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))))) @@ -146,39 +183,34 @@ (define-public (scorify-music music parser) "Preprocess @var{music}." + (ly:make-score + (fold (lambda (f m) (f m parser)) + music + toplevel-music-functions))) - (for-each (lambda (func) - (set! music (func music parser))) - toplevel-music-functions) - - (ly:make-score music)) - - -(define (get-current-filename parser) +(define (get-current-filename parser book) "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))) + (or (paper-variable parser book 'output-filename) + (ly:parser-output-name parser))) -(define (get-current-suffix parser) +(define (get-current-suffix parser book) "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))) + (let ((book-output-suffix (paper-variable 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) +(define (get-outfile-name parser book) "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)) + (let* ((base-name (get-current-filename parser book)) + (output-suffix (get-current-suffix parser book)) (alist-key (format #f "~a~a" base-name output-suffix)) (counter-alist (ly:parser-lookup parser 'counter-alist)) (output-count (assoc-get alist-key counter-alist 0)) @@ -206,7 +238,7 @@ bookoutput function" (define (print-book-with parser book process-procedure) (let* ((paper (ly:parser-lookup parser '$defaultpaper)) (layout (ly:parser-lookup parser '$defaultlayout)) - (outfile-name (get-outfile-name parser))) + (outfile-name (get-outfile-name parser book))) (process-procedure book paper layout outfile-name))) (define-public (print-book-with-defaults parser book) @@ -227,6 +259,24 @@ bookoutput function" (else ((ly:parser-lookup parser 'toplevel-score-handler) parser score)))) +(define-public paper-variable + (let + ((get-papers + (lambda (parser book) + (append (if (and book (ly:output-def? (ly:book-paper book))) + (list (ly:book-paper book)) + '()) + (ly:parser-lookup parser '$papers) + (list (ly:parser-lookup parser '$defaultpaper)))))) + (make-procedure-with-setter + (lambda (parser book symbol) + (any (lambda (p) (ly:output-def-lookup p symbol #f)) + (get-papers parser book))) + (lambda (parser book symbol value) + (ly:output-def-set-variable! + (car (get-papers parser book)) + symbol value))))) + (define-public (add-text parser text) (add-score parser (list text))) @@ -236,6 +286,125 @@ bookoutput function" parser music)) +(define-public (context-mod-from-music parser music) + (let ((warn #t) (mods (ly:make-context-mod))) + (let loop ((m music)) + (if (music-is-of-type? m 'layout-instruction-event) + (let ((symbol (ly:music-property m 'symbol))) + (ly:add-context-mod + mods + (case (ly:music-property m 'name) + ((PropertySet) + (list 'assign + symbol + (ly:music-property m 'value))) + ((PropertyUnset) + (list 'unset symbol)) + ((OverrideProperty) + (cons* 'push + symbol + (ly:music-property m 'grob-value) + (cond + ((ly:music-property m 'grob-property #f) => list) + (else + (ly:music-property m 'grob-property-path))))) + ((RevertProperty) + (cons* 'pop + symbol + (cond + ((ly:music-property m 'grob-property #f) => list) + (else + (ly:music-property m 'grob-property-path)))))))) + (case (ly:music-property m 'name) + ((ApplyContext) + (ly:add-context-mod mods + (list 'apply + (ly:music-property m 'procedure)))) + ((ContextSpeccedMusic) + (loop (ly:music-property m 'element))) + (else + (let ((callback (ly:music-property m 'elements-callback))) + (if (procedure? callback) + (for-each loop (callback m)) + (if (and warn (ly:duration? (ly:music-property m 'duration))) + (begin + (ly:music-warning + music + (_ "Music unsuitable for context-mod")) + (set! warn #f))))))))) + mods)) + +(define-public (context-defs-from-music parser output-def music) + (let ((warn #t)) + (let loop ((m music) (mods #f)) + ;; The parser turns all sets, overrides etc into something + ;; wrapped in ContextSpeccedMusic. If we ever get a set, + ;; override etc that is not wrapped in ContextSpeccedMusic, the + ;; user has created it in Scheme himself without providing the + ;; required wrapping. In that case, using #f in the place of a + ;; context modification results in a reasonably recognizable + ;; error. + (if (music-is-of-type? m 'layout-instruction-event) + (ly:add-context-mod + mods + (case (ly:music-property m 'name) + ((PropertySet) + (list 'assign + (ly:music-property m 'symbol) + (ly:music-property m 'value))) + ((PropertyUnset) + (list 'unset + (ly:music-property m 'symbol))) + ((OverrideProperty) + (cons* 'push + (ly:music-property m 'symbol) + (ly:music-property m 'grob-value) + (cond + ((ly:music-property m 'grob-property #f) => list) + (else + (ly:music-property m 'grob-property-path))))) + ((RevertProperty) + (cons* 'pop + (ly:music-property m 'symbol) + (cond + ((ly:music-property m 'grob-property #f) => list) + (else + (ly:music-property m 'grob-property-path))))))) + (case (ly:music-property m 'name) + ((ApplyContext) + (ly:add-context-mod mods + (list 'apply + (ly:music-property m 'procedure)))) + ((ContextSpeccedMusic) + ;; Use let* here to let defs catch up with modifications + ;; to the context defs made in the recursion + (let* ((mods (loop (ly:music-property m 'element) + (ly:make-context-mod))) + (defs (ly:output-find-context-def + output-def (ly:music-property m 'context-type)))) + (if (null? defs) + (ly:music-warning + music + (ly:format (_ "Cannot find context-def \\~a") + (ly:music-property m 'context-type))) + (for-each + (lambda (entry) + (ly:output-def-set-variable! + output-def (car entry) + (ly:context-def-modify (cdr entry) mods))) + defs)))) + (else + (let ((callback (ly:music-property m 'elements-callback))) + (if (procedure? callback) + (fold loop mods (callback m)) + (if (and warn (ly:duration? (ly:music-property m 'duration))) + (begin + (ly:music-warning + music + (_ "Music unsuitable for output-def")) + (set! warn #f)))))))) + mods))) + ;;;;;;;;;;;;;;;; ;; alist @@ -271,17 +440,11 @@ bookoutput function" (define-public (first-member members 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))))) + (any (lambda (m) (member m lst)) members)) (define-public (first-assoc keys lst) "Return first successful assoc of key from @var{keys} in @var{lst}." - (if (null? keys) - #f - (let ((k (assoc (car keys) lst))) - (if k k (first-assoc (cdr keys) lst))))) + (any (lambda (k) (assoc k lst)) keys)) (define-public (flatten-alist alist) (if (null? alist) @@ -337,30 +500,23 @@ For example: ;; hash (define-public (hash-table->alist t) - (hash-fold (lambda (k v acc) (acons k v acc)) - '() t)) + (hash-fold acons '() t)) ;; todo: code dup with C++. (define-safe-public (alist->hash-table lst) "Convert alist to table" (let ((m (make-hash-table (length lst)))) - (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst) + (for-each (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst) m)) ;;;;;;;;;;;;;;;; ;; list (define (functional-or . rest) - (if (pair? rest) - (or (car rest) - (apply functional-or (cdr rest))) - #f)) + (any identity rest)) (define (functional-and . rest) - (if (pair? rest) - (and (car rest) - (apply functional-and (cdr rest))) - #t)) + (every identity rest)) (define (split-list lst n) "Split LST in N equal sized parts" @@ -378,26 +534,12 @@ For example: (helper lst (make-vector n '()) (1- n))) (define (list-element-index lst x) - (define (helper todo k) - (cond - ((null? todo) #f) - ((equal? (car todo) x) k) - (else - (helper (cdr todo) (1+ k))))) - - (helper lst 0)) + (list-index (lambda (m) (equal? m x)) lst)) (define-public (count-list lst) "Given @var{lst} as @code{(E1 E2 .. )}, return @code{((E1 . 1) (E2 . 2) ... )}." - - (define (helper l acc count) - (if (pair? l) - (helper (cdr l) (cons (cons (car l) count) acc) (1+ count)) - acc)) - - - (reverse (helper lst '() 1))) + (map cons lst (iota (length lst) 1))) (define-public (list-join lst intermediate) "Put @var{intermediate} between all elts of @var{lst}." @@ -442,28 +584,27 @@ for comparisons." "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 (lambda (x y) (not (pred x y))) - lst - (cdr lst)))) - (if i - (cons (take lst (1+ i)) (drop lst (1+ i))) - (list lst))))) + (let ((i (and (pair? lst) + (list-index (lambda (x y) (not (pred x y))) + lst + (cdr lst))))) + (if i + (call-with-values + (lambda () (split-at lst (1+ i))) + cons) + (list lst)))) (define-public (split-list-by-separator lst pred) "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 - (append result - (list (take-while (lambda (x) (not (pred x))) lst))) - (let ((tail (find-tail pred lst))) - (if tail (cdr tail) #f))) - result))) + (call-with-values (lambda () (break pred lst)) + (lambda (head tail) + (cons head + (if (null? tail) + tail + (split-list-by-separator (cdr tail) pred)))))) (define-public (offset-add a b) (cons (+ (car a) (car b)) @@ -522,6 +663,10 @@ right (@var{dir}=+1)." (define (other-axis a) (remainder (+ a 1) 2)) +(define-public (interval-scale iv factor) + (cons (* (car iv) factor) + (* (cdr iv) factor))) + (define-public (interval-widen iv amount) (cons (- (car iv) amount) (+ (cdr iv) amount))) @@ -852,17 +997,7 @@ print a warning and set an optional @var{default}." scaling)) (define-public (version-not-seen-message input-file-name) - (ly:message - "~a:0: ~a ~a" - input-file-name - (_ "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" - input-file-name - (_ "warning:") - (_ "old relative compatibility not used"))) + (ly:warning-located + (ly:format "~a:1" input-file-name) + (_ "no \\version statement found, please add~afor future compatibility") + (format #f "\n\n\\version ~s\n\n" (lilypond-version))))