;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;; for define-safe-public when byte-compiling using Guile V2
(use-modules (scm safe-utility-defs))
+(use-modules (ice-9 pretty-print))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; constants.
(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
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:moment<? (ly:context-property context 'measureLength)
+ (ly:duration-length dur))
+ 1
+ #f))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; arithmetic
(define-public (average x . lst)
(symbol->string (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)))
(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}.
@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
(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."
;; 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)
(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
(object->string def))
def))))
-;;
-;; don't confuse users with #<procedure .. > 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 #<procedure ...> 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)))
projects / lilypond.git / blobdiff