-;; part-combiner.
-
-
-
-(define noticed '())
-(define part-combine-listener '())
-(define-public (set-part-combine-listener x)
- (set! part-combine-listener x))
-
-(define-public (notice-the-events-for-pc context lst)
- (set! noticed (acons (ly:context-id context) lst noticed)))
-
-(define-public (make-new-part-combine-music music-list)
- (let*
- ((m (make-music-by-name 'NewPartCombineMusic))
- (m1 (context-spec-music (car music-list) 'Voice "one"))
- (m2 (context-spec-music (cadr music-list) 'Voice "two"))
- (props '((denies Thread)
- (consists Rest_engraver)
- (consists Note_heads_engraver)
- )))
-
- (ly:set-mus-property! m 'elements (list m1 m2))
- (ly:set-mus-property! m1 'property-operations props)
- (ly:set-mus-property! m2 'property-operations props)
- (ly:run-translator m2 part-combine-listener)
- (ly:run-translator m1 part-combine-listener)
- (ly:set-mus-property! m 'split-list
- (determine-split-list (reverse (cdr (assoc "one" noticed)))
- (reverse (cdr (assoc "two" noticed)))))
- (set! noticed '())
-
- m))
-
-
-
-;;
-;; due to a bug in the GUILE evaluator,
-;; stack traces result in core dumps.
-;; therefore we retain debugging code.
-;;
-
-;;
-;; todo: this is too hairy.
-;;
-(define-public (determine-split-list evl1 evl2)
- "EVL1 and EVL2 should be ascending"
-
- (define ev1 (list->vector evl1))
- (define ev2 (list->vector evl2))
- (define (when v i)
- (car (vector-ref v i)))
- (define (what v i)
- (cdr (vector-ref v i)))
-
- (define chord-threshold 8)
-
- (define result
- (list->vector
- (map (lambda (x)
- (cons x '()))
- (uniq-list
- (merge (map car evl1) (map car evl2) ly:moment<?)))))
-
- (define (analyse-time-step i1 i2 ri
- active1
- active2)
-
- (define (analyse-tie-start active ev)
- (if (equal? (ly:get-mus-property ev 'name) 'TieEvent)
- (acons 'tie ri active)
- active
- ))
-
- (define (analyse-tie-end active ev)
- (if (equal? (ly:get-mus-property ev 'name) 'NoteEvent)
- (assoc-remove! active 'tie)
- active) )
-
- (define (active<? a b)
- (cond
- ((symbol<? (car a) (car b)) #t)
- ((symbol<? (car b) (car b)) #f)
- (else
- (< (cdr a) (cdr b)))
- ))
-
- (define (analyse-span-event active ev)
- (let*
- ((name (ly:get-mus-property ev 'name))
- (key (cond
- ((equal? name 'SlurEvent) 'slur)
- ((equal? name 'PhrasingSlurEvent) 'tie)
- ((equal? name 'BeamEvent) 'beam)
- ((equal? name 'CrescendoEvent) 'cresc)
- ((equal? name 'DecrescendoEvent) 'decr)
- (else #f)) )
- (sp (ly:get-mus-property ev 'span-direction))
- )
-
- (if (and (symbol? key) (ly:dir? sp))
- (if (= sp STOP)
- (assoc-remove! active key)
- (acons key ri active))
- active)
- ))
+;; accidentals
+
+(define-public (set-accidentals-properties extra-natural
+ auto-accs auto-cauts
+ context)
+ (context-spec-music
+ (make-sequential-music
+ (append (if (boolean? extra-natural)
+ (list (make-property-set 'extraNatural extra-natural))
+ '())
+ (list (make-property-set 'autoAccidentals auto-accs)
+ (make-property-set 'autoCautionaries auto-cauts))))
+ context))
+
+(define-public (set-accidental-style style . rest)
+ "Set accidental style to STYLE. Optionally takes a context argument,
+e.g. 'Staff or 'Voice. The context defaults to Voice, except for piano styles, which
+use GrandStaff as a context. "
+ (let ((context (if (pair? rest)
+ (car rest) 'Staff))
+ (pcontext (if (pair? rest)
+ (car rest) 'GrandStaff)))
+ (ly:export
+ (cond
+ ;; accidentals as they were common in the 18th century.
+ ((equal? style 'default)
+ (set-accidentals-properties #t '(Staff (same-octave . 0))
+ '() context))
+ ;; accidentals from one voice do NOT get cancelled in other voices
+ ((equal? style 'voice)
+ (set-accidentals-properties #t '(Voice (same-octave . 0))
+ '() context))
+ ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century.
+ ;; This includes all the default accidentals, but accidentals also needs cancelling
+ ;; in other octaves and in the next measure.
+ ((equal? style 'modern)
+ (set-accidentals-properties #f '(Staff (same-octave . 0) (any-octave . 0) (same-octave . 1))
+ '() context))
+ ;; the accidentals that Stone adds to the old standard as cautionaries
+ ((equal? style 'modern-cautionary)
+ (set-accidentals-properties #f '(Staff (same-octave . 0))
+ '(Staff (any-octave . 0) (same-octave . 1))
+ context))
+ ;; Multivoice accidentals to be read both by musicians playing one voice
+ ;; and musicians playing all voices.
+ ;; Accidentals are typeset for each voice, but they ARE cancelled across voices.
+ ((equal? style 'modern-voice)
+ (set-accidentals-properties #f
+ '(Voice (same-octave . 0) (any-octave . 0) (same-octave . 1)
+ Staff (same-octave . 0) (any-octave . 0) (same-octave . 1))
+ '()
+ context))
+ ;; same as modernVoiceAccidental eccept that all special accidentals are typeset
+ ;; as cautionaries
+ ((equal? style 'modern-voice-cautionary)
+ (set-accidentals-properties #f
+ '(Voice (same-octave . 0))
+ '(Voice (any-octave . 0) (same-octave . 1)
+ Staff (same-octave . 0) (any-octave . 0) (same-octave . 1))
+ context))
+ ;; stone's suggestions for accidentals on grand staff.
+ ;; Accidentals are cancelled across the staves in the same grand staff as well
+ ((equal? style 'piano)
+ (set-accidentals-properties #f
+ '(Staff (same-octave . 0)
+ (any-octave . 0) (same-octave . 1)
+ GrandStaff (any-octave . 0) (same-octave . 1))
+ '()
+ pcontext))
+ ((equal? style 'piano-cautionary)
+ (set-accidentals-properties #f
+ '(Staff (same-octave . 0))
+ '(Staff (any-octave . 0) (same-octave . 1)
+ GrandStaff (any-octave . 0) (same-octave . 1))
+ pcontext))
+ ;; do not set localKeySignature when a note alterated differently from
+ ;; localKeySignature is found.
+ ;; Causes accidentals to be printed at every note instead of
+ ;; remembered for the duration of a measure.
+ ;; accidentals not being remembered, causing accidentals always to be typeset relative to the time signature
+ ((equal? style 'forget)
+ (set-accidentals-properties '()
+ '(Staff (same-octave . -1))
+ '() context))
+ ;; Do not reset the key at the start of a measure. Accidentals will be
+ ;; printed only once and are in effect until overridden, possibly many
+ ;; measures later.
+ ((equal? style 'no-reset)
+ (set-accidentals-properties '()
+ '(Staff (same-octave . #t))
+ '()
+ context))
+ (else
+ (ly:warning (_ "unknown accidental style: ~S" style))
+ (make-sequential-music '()))))))