;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 1998--2014 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
"Does @code{mus} belong to the music class @code{type}?"
(memq type (ly:music-property mus 'types)))
+(define-safe-public (music-type-predicate types)
+ "Returns a predicate function that can be used for checking
+music to have one of the types listed in @var{types}."
+ (if (cheap-list? types)
+ (lambda (m)
+ (any (lambda (t) (music-is-of-type? m t)) types))
+ (lambda (m) (music-is-of-type? m types))))
+
;; TODO move this
(define-public ly:grob-property
(make-procedure-with-setter ly:grob-property
(use-modules (srfi srfi-39)
(scm display-lily))
-(define*-public (display-lily-music expr parser #:optional (port (current-output-port))
+(define*-public (display-lily-music expr #:optional (port (current-output-port))
#:key force-duration)
"Display the music expression using LilyPond syntax"
(memoize-clef-names supported-clefs)
(parameterize ((*indent* 0)
- (*previous-duration* (ly:make-duration 2))
- (*force-duration* force-duration))
- (display (music->lily-string expr parser) port)
+ (*omit-duration* #f))
+ (display (music->lily-string expr) port)
(newline port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(body (ly:music-property tremolo 'element))
(children (if (music-is-of-type? body 'sequential-music)
;; \repeat tremolo n { ... }
- (length (extract-named-music body '(EventChord
- NoteEvent)))
+ (count duration-of-note ; do not count empty <>
+ (extract-named-music body
+ '(EventChord NoteEvent)))
;; \repeat tremolo n c4
1))
(tremolo-type (if (positive? children)
(lambda (m)
(and (music-is-of-type? m 'unfolded-repeated-music)
(make-sequential-music
- (ly:music-deep-copy
- (let ((n (ly:music-property m 'repeat-count))
- (alts (ly:music-property m 'elements))
- (body (ly:music-property m 'element)))
- (cond ((<= n 0) '())
- ((null? alts) (make-list n body))
- (else
- (concatenate
- (zip (make-list n body)
- (append! (make-list (max 0 (- n (length alts)))
- (car alts))
- alts))))))))))
+ (ly:music-deep-copy (make-unfolded-set m)))))
(unfold-repeats music)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; property setting music objs.
-(define-safe-public (check-grob-path path #:optional parser location
+(define-safe-public (check-grob-path path #:optional location
#:key
(start 0)
default
(<= min (length res))))
res
(begin
- (if parser
- (ly:parser-error parser
- (format #f (_ "bad grob property path ~a")
- path)
- location))
+ (ly:parser-error
+ (format #f (_ "bad grob property path ~a")
+ path)
+ location)
#f)))))
+(define-safe-public (check-context-path path #:optional location)
+ "Check a context property path specification @var{path}, a symbol
+list (or a single symbol), for validity and possibly complete it.
+Returns the completed specification, or @code{#f} when rising an
+error (using optionally @code{location})."
+ (let* ((path (if (symbol? path) (list path) path)))
+ ;; A Guile 1.x bug specific to optargs precludes moving the
+ ;; defines out of the let
+ (define (property? s)
+ (object-property s 'translation-type?))
+ (define (unspecial? s)
+ (not (property? s)))
+ (define (check c p) (c p))
+ (or (case (length path)
+ ((1) (and (property? (car path)) (cons 'Bottom path)))
+ ((2) (and (unspecial? (car path)) (property? (cadr path)) path))
+ (else #f))
+ (begin
+ (ly:parser-error
+ (format #f (_ "bad context property ~a")
+ path)
+ location)
+ #f))))
+
+(define-safe-public (check-music-path path #:optional location #:key default)
+ "Check a music property path specification @var{path}, a symbol
+list (or a single symbol), for validity and possibly complete it.
+Returns the completed specification, or @code{#f} when rising an
+error (using optionally @code{location})."
+ (let* ((path (if (symbol? path) (list path) path)))
+ ;; A Guile 1.x bug specific to optargs precludes moving the
+ ;; defines out of the let
+ (define (property? s)
+ (object-property s 'music-type?))
+ (define (unspecial? s)
+ (not (property? s)))
+ (or (case (length path)
+ ((1) (and (property? (car path)) (cons default path)))
+ ((2) (and (unspecial? (car path)) (property? (cadr path)) path))
+ (else #f))
+ (begin
+ (ly:parser-error
+ (format #f (_ "bad music property ~a")
+ path)
+ location)
+ #f))))
+
(define-public (make-grob-property-set grob gprop val)
- "Make a @code{Music} expression that sets @var{gprop} to @var{val} in
-@var{grob}. Does a pop first, i.e., this is not an override."
+ "Make a @code{Music} expression that overrides a @var{gprop} to
+@var{val} in @var{grob}. Does a pop first, i.e. this is not a
+@code{\\temporary \\override}."
(make-music 'OverrideProperty
'symbol grob
'grob-property gprop
'pop-first #t))
(define-public (make-grob-property-override grob gprop val)
- "Make a @code{Music} expression that overrides @var{gprop} to @var{val}
-in @var{grob}."
+ "Make a @code{Music} expression that overrides @var{gprop} to
+@var{val} in @var{grob}. This is a @code{\\temporary \\override},
+making it possible to @code{\\revert} to any previous value afterwards."
(make-music 'OverrideProperty
'symbol grob
'grob-property gprop
(Voice Slur direction ,DOWN))
general-grace-settings))
+;; Getting a unique context id name
+
+(define-session unique-counter -1)
+(define-safe-public (get-next-unique-voice-name)
+ (set! unique-counter (1+ unique-counter))
+ (format #f "uniqueContext~s" unique-counter))
+
+
(define-safe-public (make-voice-props-set n)
(make-sequential-music
(append
(make-grob-property-revert 'NoteColumn 'horizontal-shift)))))
-(define-safe-public (context-spec-music m context #:optional id)
- "Add \\context CONTEXT = ID to M."
+(define-safe-public (context-spec-music m context #:optional id mods)
+ "Add \\context @var{context} = @var{id} \\with @var{mods} to @var{m}."
(let ((cm (make-music 'ContextSpeccedMusic
'element m
'context-type context)))
(if (string? id)
(set! (ly:music-property cm 'context-id) id))
+ (if mods
+ (set! (ly:music-property cm 'property-operations)
+ (if (ly:context-mod? mods)
+ (ly:get-context-mods mods)
+ mods)))
cm))
-(define-public (descend-to-context m context)
+(define-safe-public (descend-to-context m context #:optional id mods)
"Like @code{context-spec-music}, but only descending."
- (let ((cm (context-spec-music m context)))
+ (let ((cm (context-spec-music m context id mods)))
(ly:music-set-property! cm 'descend-only #t)
cm))
;; articulations on individual events since they can't actually get
;; into a repeat chord given its input syntax.
- (define (keep-element? m)
- (any (lambda (t) (music-is-of-type? m t))
- event-types))
- (define origin (ly:music-property repeat-chord 'origin #f))
- (define (set-origin! l)
- (if origin
- (for-each (lambda (m) (set! (ly:music-property m 'origin) origin)) l))
- l)
+ (define keep-element? (music-type-predicate event-types))
(for-each
(lambda (field)
;; now treat the elements
(set! (ly:music-property repeat-chord 'elements)
(let ((elts
- (set-origin! (ly:music-deep-copy
- (filter keep-element?
- (ly:music-property original-chord
- 'elements))))))
+ (ly:music-deep-copy (filter keep-element?
+ (ly:music-property original-chord
+ 'elements))
+ repeat-chord)))
(for-each
(lambda (m)
(let ((arts (ly:music-property m 'articulations)))
(if (pair? arts)
(set! (ly:music-property m 'articulations)
- (set-origin! (filter! keep-element? arts))))
+ (ly:set-origin! (filter! keep-element? arts)
+ repeat-chord)))
(if (ly:duration? (ly:music-property m 'duration))
- (set! (ly:music-property m 'duration) duration))))
+ (set! (ly:music-property m 'duration) duration))
+ (if (ly:music-property m 'cautionary #f)
+ (set! (ly:music-property m 'cautionary) #f))
+ (if (ly:music-property m 'force-accidental #f)
+ (set! (ly:music-property m 'force-accidental) #f))))
elts)
(append! elts (ly:music-property repeat-chord 'elements))))
(let ((arts (filter keep-element?
(if (pair? arts)
(set! (ly:music-property repeat-chord 'articulations)
(append!
- (set-origin! (ly:music-deep-copy arts))
+ (ly:music-deep-copy arts repeat-chord)
(ly:music-property repeat-chord 'articulations)))))
repeat-chord)
m)
(cond
((music-is-of-type? m 'event-chord)
- (set-and-ret m))
+ (if (any (lambda (m) (music-is-of-type? m 'rhythmic-event))
+ (ly:music-property m 'elements))
+ (set! last-pitch m))
+ m)
((music-is-of-type? m 'note-event)
(cond
((or (ly:music-property m 'pitch #f)
mus))
-(define-public (music-has-type music type)
- (memq type (ly:music-property music 'types)))
-
(define-public (music-clone music . music-properties)
"Clone @var{music} and set properties according to
@var{music-properties}, a list of alternating property symbols and
(defmacro-public def-grace-function (start stop . docstring)
"Helper macro for defining grace music"
- `(define-music-function (parser location music) (ly:music?)
+ `(define-music-function (music) (ly:music?)
,@docstring
(make-music 'GraceMusic
- 'origin location
'element (make-music 'SequentialMusic
'elements (list (ly:music-deep-copy ,start)
music
(defmacro-public define-syntax-function (type args signature . body)
"Helper macro for `ly:make-music-function'.
Syntax:
- (define-syntax-function result-type? (parser location arg1 arg2 ...) (arg1-type arg2-type ...)
+ (define-syntax-function result-type? (arg1 arg2 ...) (arg1-type arg2-type ...)
...function body...)
argX-type can take one of the forms @code{predicate?} for mandatory
predicates, to be used in case of a type error in arguments or
result."
+ (define (has-parser/location? arg where)
+ (let loop ((arg arg))
+ (if (list? arg)
+ (any loop arg)
+ (memq arg where))))
(define (currying-lambda args doc-string? body)
(if (and (pair? args)
(pair? (car args)))
(currying-lambda (car args) doc-string?
`((lambda ,(cdr args) ,@body)))
- `(lambda ,args
- ,(format #f "~a\n~a" (cddr args) (or doc-string? ""))
- ,@body)))
-
- (set! signature (map (lambda (pred)
- (if (pair? pred)
- `(cons ,(car pred)
- ,(and (pair? (cdr pred)) (cadr pred)))
- pred))
- (cons type signature)))
+ (let* ((compatibility? (if (list? args)
+ (= (length args) (+ 2 (length signature)))
+ (and (pair? args) (pair? (cdr args))
+ (eq? (car args) 'parser))))
+ (realargs (if compatibility? (cddr args) args)))
+ `(lambda ,realargs
+ ,(format #f "~a\n~a" realargs (or doc-string? ""))
+ ,@(if (and compatibility?
+ (has-parser/location? body (take args 2)))
+ `((let ((,(car args) (*parser*)) (,(cadr args) (*location*)))
+ ,@body))
+ body)))))
(let ((docstring
(and (pair? body) (pair? (cdr body))
;; When the music function definition contains an i10n doc string,
;; (_i "doc string"), keep the literal string only
`(ly:make-music-function
- (list ,@signature)
+ (list ,@(map (lambda (pred)
+ (if (pair? pred)
+ `(cons ,(car pred)
+ ,(and (pair? (cdr pred)) (cadr pred)))
+ pred))
+ (cons type signature)))
,(currying-lambda args docstring (if docstring (cdr body) body)))))
(defmacro-public define-music-function rest
"Defining macro returning music functions.
Syntax:
- (define-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...)
+ (define-music-function (arg1 arg2 ...) (arg1-type? arg2-type? ...)
...function body...)
argX-type can take one of the forms @code{predicate?} for mandatory
(defmacro-public define-scheme-function rest
"Defining macro returning Scheme functions.
Syntax:
- (define-scheme-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...)
+ (define-scheme-function (arg1 arg2 ...) (arg1-type? arg2-type? ...)
...function body...)
argX-type can take one of the forms @code{predicate?} for mandatory
(defmacro-public define-event-function rest
"Defining macro returning event functions.
Syntax:
- (define-event-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...)
+ (define-event-function (arg1 arg2 ...) (arg1-type? arg2-type? ...)
...function body...)
argX-type can take one of the forms @code{predicate?} for mandatory
(context-spec-music (make-property-set 'skipTypesetting (not bool))
'Score))))
-(define (skip-as-needed music parser)
+(define (skip-as-needed music)
"Replace MUSIC by
<< { \\set skipTypesetting = ##f
LENGTHOF(\\showFirstLength)
the 'length property of the music is
overridden to speed up compiling."
(let*
- ((show-last (ly:parser-lookup parser 'showLastLength))
- (show-first (ly:parser-lookup parser 'showFirstLength))
+ ((show-last (ly:parser-lookup 'showLastLength))
+ (show-first (ly:parser-lookup 'showFirstLength))
(show-last-length (and (ly:music? show-last)
(ly:music-length show-last)))
(show-first-length (and (ly:music? show-first)
(define-session-public toplevel-music-functions
(list
- (lambda (music parser) (expand-repeat-chords!
- (cons 'rhythmic-event
- (ly:parser-lookup parser '$chord-repeat-events))
- music))
- (lambda (music parser) (expand-repeat-notes! music))
- (lambda (music parser) (voicify-music music))
- (lambda (x parser) (music-map music-check-error x))
- (lambda (x parser) (music-map precompute-music-length x))
- (lambda (music parser)
-
- (music-map (quote-substitute (ly:parser-lookup parser 'musicQuotes)) music))
+ (lambda (music) (expand-repeat-chords!
+ (cons 'rhythmic-event
+ (ly:parser-lookup '$chord-repeat-events))
+ music))
+ expand-repeat-notes!
+ voicify-music
+ (lambda (x) (music-map music-check-error x))
+ (lambda (x) (music-map precompute-music-length x))
+ (lambda (music)
+ (music-map (quote-substitute (ly:parser-lookup 'musicQuotes)) music))
;; switch-on-debugging
- (lambda (x parser) (music-map cue-substitute x))
+ (lambda (x) (music-map cue-substitute x))
- (lambda (x parser)
- (skip-as-needed x parser)
- )))
+ skip-as-needed))
;;;;;;;;;;
;;; general purpose music functions
(define-public (pitch-of-note event-chord)
(let ((evs (filter (lambda (x)
- (music-has-type x 'note-event))
+ (music-is-of-type? x 'note-event))
(ly:music-property event-chord 'elements))))
(and (pair? evs)
"Return a flat list of all music with @var{type} (either a single
type symbol or a list of alternatives) inside of @var{music}, not
recursing into matches themselves."
- (extract-music
- music
- (if (cheap-list? type)
- (lambda (m)
- (any (lambda (t) (music-is-of-type? m t)) type))
- (lambda (m) (music-is-of-type? m type)))))
+ (extract-music music (music-type-predicate type)))
-(define*-public (event-chord-wrap! music #:optional parser)
+(define-public (event-chord-wrap! music)
"Wrap isolated rhythmic events and non-postevent events in
-@var{music} inside of an @code{EventChord}. If the optional
-@var{parser} argument is given, chord repeats @samp{q} are expanded
-using the default settings. Otherwise, you need to cater for them
-yourself."
+@var{music} inside of an @code{EventChord}. Chord repeats @samp{q}
+are expanded using the default settings of the parser."
(map-some-music
(lambda (m)
(cond ((music-is-of-type? m 'event-chord)
(set! (ly:music-property m 'articulations) '()))
(make-event-chord (cons m arts))))
(else #f)))
- (if parser
- (expand-repeat-chords!
- (cons 'rhythmic-event
- (ly:parser-lookup parser '$chord-repeat-events))
- music)
- music)))
+ (expand-repeat-notes!
+ (expand-repeat-chords!
+ (cons 'rhythmic-event
+ (ly:parser-lookup '$chord-repeat-events))
+ music))))
(define-public (event-chord-notes event-chord)
"Return a list of all notes from @var{event-chord}."
(car arg))))
(export value-for-spanner-piece)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; measure counter
-
-(define (measure-counter-stencil grob)
- "Print a number for a measure count. The number is centered using
-the extents of @code{BreakAlignment} grobs associated with
-@code{NonMusicalPaperColumn} grobs. In the case of an unbroken measure, these
-columns are the left and right bounds of a @code{MeasureCounter} spanner.
-Broken measures are numbered in parentheses."
- (let* ((orig (ly:grob-original grob))
- (siblings (ly:spanner-broken-into orig)) ; have we been split?
- (bounds (ly:grob-array->list (ly:grob-object grob 'columns)))
- (refp (ly:grob-system grob))
- ;; we use the first and/or last NonMusicalPaperColumn grob(s) of
- ;; a system in the event that a MeasureCounter spanner is broken
- (all-cols (ly:grob-array->list (ly:grob-object refp 'columns)))
- (all-cols
- (filter
- (lambda (col) (eq? #t (ly:grob-property col 'non-musical)))
- all-cols))
- (left-bound
- (if (or (null? siblings) ; spanner is unbroken
- (eq? grob (car siblings))) ; or the first piece
- (car bounds)
- (car all-cols)))
- (right-bound
- (if (or (null? siblings)
- (eq? grob (car (reverse siblings))))
- (car (reverse bounds))
- (car (reverse all-cols))))
- (elts-L (ly:grob-array->list (ly:grob-object left-bound 'elements)))
- (elts-R (ly:grob-array->list (ly:grob-object right-bound 'elements)))
- (break-alignment-L
- (filter
- (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
- elts-L))
- (break-alignment-R
- (filter
- (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
- elts-R))
- (break-alignment-L-ext (ly:grob-extent (car break-alignment-L) refp X))
- (break-alignment-R-ext (ly:grob-extent (car break-alignment-R) refp X))
- (num (markup (number->string (ly:grob-property grob 'count-from))))
- (num
- (if (or (null? siblings)
- (eq? grob (car siblings)))
- num
- (make-parenthesize-markup num)))
- (num (grob-interpret-markup grob num))
- (num (ly:stencil-aligned-to num X (ly:grob-property grob 'self-alignment-X)))
- (num
- (ly:stencil-translate-axis
- num
- (+ (interval-length break-alignment-L-ext)
- (* 0.5
- (- (car break-alignment-R-ext)
- (cdr break-alignment-L-ext))))
- X)))
- num))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following are used by the \offset function
arg offsets))
(else arg)))
+(define-public (grob-transformer property func)
+ "Create an override value good for applying @var{func} to either
+pure or unpure values. @var{func} is called with the respective grob
+as first argument and the default value (after resolving all callbacks)
+as the second."
+ (define (worker self container-part grob . rest)
+ (let* ((immutable (ly:grob-basic-properties grob))
+ ;; We need to search the basic-properties alist for our
+ ;; property to obtain values to offset. Our search is
+ ;; complicated by the fact that calling the music function
+ ;; `offset' as an override conses a pair to the head of the
+ ;; alist. This pair must be discounted. The closure it
+ ;; contains is named `self' so it can be easily recognized.
+ ;; If `offset' is called as a tweak, the basic-property
+ ;; alist is unaffected.
+ (target (find-value-to-offset property self immutable))
+ ;; if target is a procedure, we need to apply it to our
+ ;; grob to calculate values to offset.
+ (vals (cond ((procedure? target) (target grob))
+ ;; Argument lists for a pure procedure pulled
+ ;; from an unpure-pure-container may be
+ ;; different from a normal procedure, so we
+ ;; need a different code path and calling
+ ;; convention for procedures pulled from an
+ ;; container as opposed to from the property
+ ((ly:unpure-pure-container? target)
+ (let ((part (container-part target)))
+ (if (procedure? part)
+ (apply part grob rest)
+ part)))
+ (else target))))
+ (func grob vals)))
+ ;; return the container named `self'. The container self-reference
+ ;; seems like chasing its own tail but gets dissolved by
+ ;; define/lambda separating binding and referencing of "self".
+ (define self (ly:make-unpure-pure-container
+ (lambda (grob)
+ (worker self ly:unpure-pure-container-unpure-part grob))
+ (lambda (grob . rest)
+ (apply worker self ly:unpure-pure-container-pure-part
+ grob rest))))
+ self)
+
(define-public (offsetter property offsets)
"Apply @var{offsets} to the default values of @var{property} of @var{grob}.
Offsets are restricted to immutable properties and values of type @code{number},
@code{number-pair}, or @code{number-pair-list}."
- (define (self grob)
- (let* ((immutable (ly:grob-basic-properties grob))
- ; We need to search the basic-properties alist for our property to
- ; obtain values to offset. Our search is complicated by the fact that
- ; calling the music function `offset' as an override conses a pair to
- ; the head of the alist. This pair must be discounted. The closure it
- ; contains is named `self' so it can be easily recognized. If `offset'
- ; is called as a tweak, the basic-property alist is unaffected.
- (target (find-value-to-offset property self immutable))
- ; if target is a procedure, we need to apply it to our grob to calculate
- ; values to offset.
- (vals
- (if (procedure? target)
- (target grob)
- target))
- (can-type-be-offset?
- (or (number? vals)
- (number-pair? vals)
- (number-pair-list? vals))))
-
+ (define (offset-fun grob vals)
+ (let ((can-type-be-offset?
+ (or (number? vals)
+ (number-pair? vals)
+ (number-pair-list? vals))))
(if can-type-be-offset?
- ; '(+inf.0 . -inf.0) would offset to itself. This will be confusing to a
- ; user unaware of the default value of the property, so issue a warning.
+ ;; '(+inf.0 . -inf.0) would offset to itself. This will be
+ ;; confusing to a user unaware of the default value of the
+ ;; property, so issue a warning.
(if (equal? empty-interval vals)
(ly:warning "default '~a of ~a is ~a and can't be offset"
property grob vals)
(ly:spanner-broken-into orig)
'()))
(total-found (length siblings))
- ; Since there is some flexibility in input syntax,
- ; structure of `offsets' is normalized.
+ ;; Since there is some flexibility in input
+ ;; syntax, structure of `offsets' is normalized.
(offsets
(if (or (not (pair? offsets))
(number-pair? offsets)
offsets)))
(define (helper sibs offs)
- ; apply offsets to the siblings of broken spanners
+ ;; apply offsets to the siblings of broken spanners
(if (pair? offs)
(if (eq? (car sibs) grob)
(offset-multiple-types vals (car offs))
(helper siblings offsets)
(offset-multiple-types vals (car offsets)))))
- (begin
- (ly:warning "the property '~a of ~a cannot be offset" property grob)
- vals))))
- ; return the closure named `self'
- self)
-
+ (begin
+ (ly:warning "the property '~a of ~a cannot be offset" property grob)
+ vals))))
+ (grob-transformer property offset-fun))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; \magnifyMusic and \magnifyStaff
projects / lilypond.git / blobdiff