X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=b49dfbe0bd1e9fe7e834ddf50150636fedae0576;hb=47db9a3883d726ca53e2133a3b2298f78dd6a32e;hp=82db3699d42f38cbf978fa6c5d9e7c981398b2c2;hpb=cf137655b7aee9988ef536d6fa5e38d279ee73cf;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 82db3699d4..b49dfbe0bd 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--2012 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -22,6 +22,8 @@ ;; for define-safe-public when byte-compiling using Guile V2 (use-modules (scm safe-utility-defs)) +(use-modules (ice-9 pretty-print)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; constants. @@ -80,6 +82,11 @@ (cons (ly:moment-main-numerator moment) (ly:moment-main-denominator moment))) +(define-public (seconds->moment s context) + "Return a moment equivalent to s seconds at the current tempo." + (ly:moment-mul (ly:context-property context 'tempoWholesPerMinute) + (ly:make-moment (/ s 60)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; durations @@ -116,6 +123,16 @@ non-visual scale factor 1." duration (base note length and dot count), as a number of whole notes." (duration-length (duration-visual dur))) +(define-public (unity-if-multimeasure context dur) + "Given a context and a duration, return @code{1} if the duration is +longer than the @code{measureLength} in that context, and @code{#f} otherwise. +This supports historic use of @code{Completion_heads_engraver} to split +@code{c1*3} into three whole notes." + (if (ly:momentstring (car y)))) (define (map-alist-vals func list) - "map FUNC over the vals of LIST, leaving the keys." + "map FUNC over the vals of LIST, leaving the keys." (if (null? list) '() (cons (cons (caar list) (func (cdar list))) @@ -453,17 +470,6 @@ bookoutput function" (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}. @@ -473,19 +479,14 @@ For 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) + (define (map-selected-alist-keys-helper 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)))) + (fold map-selected-alist-keys-helper alist keys)) ;;;;;;;;;;;;;;;; ;; vector @@ -551,17 +552,14 @@ For example: (list elem))) '() lst)) -(define-public (filtered-map proc lst) - (filter - (lambda (x) x) - (map proc lst))) +(define-public filtered-map filter-map) (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)))))) + (let loop ((x x) (tail '())) + (cond ((list? x) (fold-right loop tail x)) + ((not (pair? x)) (cons x tail)) + (else (loop (car x) (loop (cdr x) tail)))))) (define (list-minus a b) "Return list of elements in A that are not in B." @@ -844,12 +842,12 @@ Handy for debugging, possibly turned off." ;; x) (define-public (stderr string . rest) - (apply format (cons (current-error-port) (cons string rest))) + (apply format (current-error-port) string rest) (force-output (current-error-port))) (define-public (debugf string . rest) (if #f - (apply stderr (cons string rest)))) + (apply stderr string rest))) (define (index-cell cell dir) (if (equal? dir 1) @@ -891,6 +889,26 @@ Handy for debugging, possibly turned off." (reverse matches)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; numbering styles + +(define-public (number-format number-type num . custom-format) + "Print NUM accordingly to the requested NUMBER-TYPE. +Choices include @code{roman-lower} (by default), +@code{roman-upper}, @code{arabic} and @code{custom}. +In the latter case, CUSTOM-FORMAT must be supplied +and will be applied to NUM." + (cond + ((equal? number-type 'roman-lower) + (fancy-format #f "~(~@r~)" num)) + ((equal? number-type 'roman-upper) + (fancy-format #f "~@r" num)) + ((equal? number-type 'arabic) + (fancy-format #f "~d" num)) + ((equal? number-type 'custom) + (fancy-format #f (car custom-format) num)) + (else (fancy-format #f "~(~@r~)" num)))) + ;;;;;;;;;;;;;;;; ;; other @@ -946,23 +964,46 @@ print a warning and set an optional @var{default}." (object->string def)) def)))) -;; -;; don't confuse users with # syntax. -;; +(define (self-evaluating? x) + (or (number? x) (string? x) (procedure? x) (boolean? x))) + +(define (ly-type? x) + (any (lambda (p) ((car p) x)) lilypond-exported-predicates)) + +(define-public (pretty-printable? val) + (and (not (self-evaluating? val)) + (not (symbol? val)) + (not (hash-table? val)) + (not (ly-type? val)))) + (define-public (scm->string val) - (if (and (procedure? val) - (symbol? (procedure-name val))) - (symbol->string (procedure-name val)) - (string-append - (if (self-evaluating? val) - (if (string? val) - "\"" - "") - "'") - (call-with-output-string (lambda (port) (display val port))) - (if (string? val) - "\"" - "")))) + (let* ((quote-style (if (string? val) + 'double + (if (or (null? val) ; (ly-type? '()) => #t + (and (not (self-evaluating? val)) + (not (vector? val)) + (not (hash-table? val)) + (not (ly-type? val)))) + 'single + 'none))) + ; don't confuse users with # syntax + (str (if (and (procedure? val) + (symbol? (procedure-name val))) + (symbol->string (procedure-name val)) + (call-with-output-string + (if (pretty-printable? val) + ; property values in PDF hit margin after 64 columns + (lambda (port) + (pretty-print val port #:width (case quote-style + ((single) 63) + (else 64)))) + (lambda (port) (display val port))))))) + (case quote-style + ((single) (string-append + "'" + (string-regexp-substitute "\n " "\n " str))) + ((double) (string-append "\"" str "\"")) + (else str)))) (define-public (!= lst r) (not (= lst r)))