%%% -*- Mode: Scheme -*- %%% Based on: %%% part-combiner.scm -- Part combining, staff changes. %%% %%% source file of the GNU LilyPond music typesetter %%% %%% (c) 2004--2007 Han-Wen Nienhuys #(use-modules (oop goops)) #(define-class () (event-list #:init-value '() #:accessor events #:init-keyword #:events) (when-moment #:accessor when #:init-keyword #:when) (tuning #:accessor tuning #:init-keyword #:tuning) (split-index #:accessor split-index) (vector-index) (state-vector) ;;; ;; spanner-state is an alist ;; of (SYMBOL . RESULT-INDEX), which indicates where ;; said spanner was started. (spanner-state #:init-value '() #:accessor span-state)) #(define-method (write (x ) file) (display (when x) file) (display " evs = " file) (display (events x) file) (display " active = " file) (display (span-state x) file) (display "\n" file)) #(define-method (note-events (vs )) (define (f? x) (equal? (ly:event-property x 'class) 'note-event)) (filter f? (events vs))) #(define-method (previous-voice-state (vs )) (let ((i (slot-ref vs 'vector-index)) (v (slot-ref vs 'state-vector))) (if (< 0 i) (vector-ref v (1- i)) #f))) %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #(define-class () (configuration #:init-value '() #:accessor configuration) (when-moment #:accessor when #:init-keyword #:when) ;; voice-states are states starting with the Split-state or later ;; (is #:init-keyword #:voice-states #:accessor voice-states) (synced #:init-keyword #:synced #:init-value #f #:getter synced?)) #(define-method (write (x ) f) (display (when x) f) (display " = " f) (display (configuration x) f) (if (synced? x) (display " synced ")) (display "\n" f)) %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #(define (previous-span-state vs) (let ((p (previous-voice-state vs))) (if p (span-state p) '()))) #(define (make-voice-states evl) (let ((vec (list->vector (map (lambda (v) (make #:when (caar v) #:tuning (cdar v) #:events (map car (cdr v)))) evl)))) (do ((i 0 (1+ i))) ((= i (vector-length vec)) vec) (slot-set! (vector-ref vec i) 'vector-index i) (slot-set! (vector-ref vec i) 'state-vector vec)))) #(define (make-split-state vs1 vs2) "Merge lists VS1 and VS2, containing Voice-state objects into vector of Split-state objects, crosslinking the Split-state vector and Voice-state objects " (define (helper ss-idx ss-list idx1 idx2) (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f)) (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f)) (min (cond ((and state1 state2) (moment-min (when state1) (when state2))) (state1 (when state1)) (state2 (when state2)) (else #f))) (inc1 (if (and state1 (equal? min (when state1))) 1 0)) (inc2 (if (and state2 (equal? min (when state2))) 1 0)) (ss-object (if min (make #:when min #:voice-states (cons state1 state2) #:synced (= inc1 inc2)) #f))) (if state1 (set! (split-index state1) ss-idx)) (if state2 (set! (split-index state2) ss-idx)) (if min (helper (1+ ss-idx) (cons ss-object ss-list) (+ idx1 inc1) (+ idx2 inc2)) ss-list))) (list->vector (reverse! (helper 0 '() 0 0) '()))) #(define (analyse-spanner-states voice-state-vec) (define (helper index active) "Analyse EVS at INDEX, given state ACTIVE." (define (analyse-tie-start active ev) (if (equal? (ly:event-property ev 'class) 'tie-event) (acons 'tie (split-index (vector-ref voice-state-vec index)) active) active)) (define (analyse-tie-end active ev) (if (equal? (ly:event-property ev 'class) 'note-event) (assoc-remove! active 'tie) active)) (define (analyse-absdyn-end active ev) (if (or (equal? (ly:event-property ev 'class) 'absolute-dynamic-event) (and (equal? (ly:event-property ev 'class) 'crescendo-event) (equal? STOP (ly:event-property ev 'span-direction)))) (assoc-remove! (assoc-remove! active 'cresc) 'decr) active)) (define (active (length notes1) 1) (put 'apart)) ((> (length notes2) 1) (put 'apart)) ((= 1 (+ (length notes2) (length notes1))) (put 'apart)) ((and (= (length durs1) 1) (= (length durs2) 1) (not (equal? (car durs1) (car durs2)))) (put 'apart)) (else (if (and (= (length pitches1) (length pitches2))) (if (and (pair? pitches1) (pair? pitches2) (< chord-threshold (ly:pitch-steps (ly:pitch-diff (car pitches1) (car pitches2))))) (put 'apart) ;; copy previous split state from spanner state (begin (if (previous-voice-state vs1) (copy-state-from voice-state-vec1 (previous-voice-state vs1))) (if (previous-voice-state vs2) (copy-state-from voice-state-vec2 (previous-voice-state vs2))) (if (and (null? (span-state vs1)) (null? (span-state vs2))) (put 'chords))))))))) (if (< result-idx (vector-length result)) (let* ((now-state (vector-ref result result-idx)) (vs1 (car (voice-states now-state))) (vs2 (cdr (voice-states now-state)))) (cond ((not vs1) (put 'apart)) ((not vs2) (put 'apart)) (else (let ((active1 (previous-span-state vs1)) (active2 (previous-span-state vs2)) (new-active1 (span-state vs1)) (new-active2 (span-state vs2))) (if (and (synced? now-state) (equal? active1 active2) (equal? new-active1 new-active2)) (analyse-notes now-state) ;; active states different: (put 'apart))) ;; go to the next one, if it exists. (analyse-time-step (1+ result-idx))))))) (define (analyse-a2 result-idx) (if (< result-idx (vector-length result)) (let* ((now-state (vector-ref result result-idx)) (vs1 (car (voice-states now-state))) (vs2 (cdr (voice-states now-state)))) (if (and (equal? (configuration now-state) 'chords) vs1 vs2) (let ((notes1 (note-events vs1)) (notes2 (note-events vs2))) (cond ((and (= 1 (length notes1)) (= 1 (length notes2)) (equal? (ly:event-property (car notes1) 'pitch) (ly:event-property (car notes2) 'pitch))) (set! (configuration now-state) 'unisono)) ((and (= 0 (length notes1)) (= 0 (length notes2))) (set! (configuration now-state) 'unisilence))))) (analyse-a2 (1+ result-idx))))) (define (analyse-solo12 result-idx) (define (previous-config vs) (let* ((pvs (previous-voice-state vs)) (spi (if pvs (split-index pvs) #f)) (prev-split (if spi (vector-ref result spi) #f))) (if prev-split (configuration prev-split) 'apart))) (define (put-range x a b) ;; (display (list "put range " x a b "\n")) (do ((i a (1+ i))) ((> i b) b) (set! (configuration (vector-ref result i)) x))) (define (put x) ;; (display (list "putting " x "\n")) (set! (configuration (vector-ref result result-idx)) x)) (define (current-voice-state now-state voice-num) (define vs ((if (= 1 voice-num) car cdr) (voice-states now-state))) (if (or (not vs) (equal? (when now-state) (when vs))) vs (previous-voice-state vs))) (define (try-solo type start-idx current-idx) "Find a maximum stretch that can be marked as solo. Only set the mark when there are no spanners active. return next idx to analyse. " (if (< current-idx (vector-length result)) (let* ((now-state (vector-ref result current-idx)) (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2))) (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1))) (silent-notes (if silent-state (note-events silent-state) '())) (solo-notes (if solo-state (note-events solo-state) '()))) (cond ((not (equal? (configuration now-state) 'apart)) current-idx) ((> (length silent-notes) 0) start-idx) ((not solo-state) (put-range type start-idx current-idx) current-idx) ((and (null? (span-state solo-state))) ;; ;; This includes rests. This isn't a problem: long rests ;; will be shared with the silent voice, and be marked ;; as unisilence. Therefore, long rests won't ;; accidentally be part of a solo. ;; (put-range type start-idx current-idx) (try-solo type (1+ current-idx) (1+ current-idx))) (else (try-solo type start-idx (1+ current-idx))))) ;; try-solo start-idx)) (define (analyse-moment result-idx) "Analyse 'apart starting at RESULT-IDX. Return next index. " (let* ((now-state (vector-ref result result-idx)) (vs1 (current-voice-state now-state 1)) (vs2 (current-voice-state now-state 2)) (notes1 (if vs1 (note-events vs1) '())) (notes2 (if vs2 (note-events vs2) '())) (n1 (length notes1)) (n2 (length notes2))) (max ;; we should always increase. (cond ((and (= n1 0) (= n2 0)) (put 'apart-silence) (1+ result-idx)) ((and (= n2 0) (equal? (when vs1) (when now-state)) (null? (previous-span-state vs1))) (try-solo 'solo1 result-idx result-idx)) ((and (= n1 0) (equal? (when vs2) (when now-state)) (null? (previous-span-state vs2))) (try-solo 'solo2 result-idx result-idx)) (else (1+ result-idx))) ;; analyse-moment (1+ result-idx)))) (if (< result-idx (vector-length result)) (if (equal? (configuration (vector-ref result result-idx)) 'apart) (analyse-solo12 (analyse-moment result-idx)) (analyse-solo12 (1+ result-idx))))) ; analyse-solo12 (analyse-spanner-states voice-state-vec1) (analyse-spanner-states voice-state-vec2) (analyse-time-step 0) (analyse-a2 0) (analyse-solo12 0) (set! result (map (lambda (x) (cons (when x) (configuration x))) (vector->list result))) result)) %%% #(define-public (add-quotable parser name mus) (let* ((tab (eval 'musicQuotes (current-module))) (context-list (recording-group-emulate (context-spec-music mus 'Voice) (ly:parser-lookup parser 'partCombineListener)))) (if (pair? context-list) (hash-set! tab name ;; cdr : skip name string (list->vector (reverse! (cdar context-list) '())))))) reduction = #(define-music-function (parser location part1 part2) (ly:music? ly:music?) (make-part-combine-music parser (list music1 music2))) %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; %%%;;; %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;#(use-modules (oop goops)) #(define (prob->music prob) (let ((music (make-music (ly:prob-property prob 'name)))) (map (lambda (property) (set! (ly:music-property music (car property)) (cdr property))) (ly:prob-mutable-properties prob)) music)) #(define (partcombine->music music1 music2 layout) (let* ((context-list '()) (result (list)) (now-mom (ly:make-moment 0 0)) (global (ly:make-global-context layout)) (mom-listener (ly:make-listener (lambda (tev) (set! now-mom (ly:event-property tev 'moment))))) (new-context-listener (ly:make-listener (lambda (sev) (let* ((child (ly:event-property sev 'context)) (musics (list)) (accumulate-event-listener (ly:make-listener (lambda (ev) (if (ly:prob? (ly:event-property ev 'music-cause)) (set! musics (cons (prob->music (ly:event-property ev 'music-cause)) musics)))))) (save-acc-listener (ly:make-listener (lambda (tev) (if (pair? musics) (begin (set! result (cons (list (string->symbol (ly:context-id child)) now-mom (reverse! musics)) result)) (set! musics (list)))))))) (ly:add-listener accumulate-event-listener (ly:context-event-source child) 'music-event) (ly:add-listener save-acc-listener (ly:context-event-source global) 'OneTimeStep)))))) (ly:add-listener new-context-listener (ly:context-events-below global) 'AnnounceNewContext) (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare) (ly:interpret-music-expression (make-part-combine-music parser (list music1 music2)) global) (reverse! result))) #(define (duration->moment ly-duration) (let* ((log2 (ly:duration-log ly-duration)) (dots (ly:duration-dot-count ly-duration)) (num.den (ly:duration-factor ly-duration)) (num (car num.den)) (den (cdr num.den))) (if (= 0 num) (ly:make-moment 0 0) (let ((rational-moment (let* ((m (expt 2 (- log2))) (factor (/ num den))) (/ (do ((i 0 (1+ i)) (delta (/ m 2) (/ delta 2))) ((= i dots) m) (set! m (+ m delta))) factor)))) (ly:make-moment (numerator rational-moment) (denominator rational-moment)))))) #(define (moment->duration moment) ;; this is not correct (ly:make-duration 0 0 (ly:moment-main-numerator moment) (ly:moment-main-denominator moment))) #(define (music-duration music) (let ((this-duration (ly:music-property music 'duration))) (if (ly:duration? this-duration) this-duration (let* ((child (ly:music-property music 'element)) (child-duration (and (ly:music? child) (music-duration child)))) (if (ly:duration? child-duration) child-duration (let loop ((children (ly:music-property music 'elements))) (if (null? children) #f (let ((child-duration (music-duration (car children)))) (if (ly:duration? child-duration) child-duration (loop (cdr children))))))))))) #(define-class () (music-events #:init-value '() #:accessor events-of) (last-moment #:init-value (ly:make-moment 0 0) #:accessor last-moment-of)) #(define-method (add-music-event (music-acc ) music-event moment) (let* ((last-music-duration (and (not (null? (events-of music-acc))) (music-duration (car (events-of music-acc))))) (skip-moment (ly:moment-sub (ly:moment-sub moment (last-moment-of music-acc)) (if (ly:duration? last-music-duration) (duration->moment last-music-duration) (ly:make-moment 0 0)))) (skip-duration (moment->duration skip-moment))) (if (and (not (= 0 (ly:moment-main-numerator skip-moment))) (ly:duration? skip-duration)) (set! (events-of music-acc) (cons (make-music 'EventChord 'elements (list (make-music 'SkipEvent 'duration skip-duration))) (events-of music-acc)))) (set! (last-moment-of music-acc) moment) (set! (events-of music-acc) (cons music-event (events-of music-acc))))) #(define-method (music-sequence (music-acc )) (make-music 'SequentialMusic 'elements (reverse (events-of music-acc)))) #(define-method (music-voice (music-acc ) name) (make-music 'ContextSpeccedMusic 'create-new #t 'property-operations '() 'context-id name 'context-type 'Voice 'element (music-sequence music-acc))) #(define (combine-two-musics music1 music2) (let ((music-acc (make )) (music-acc2 (make ))) (map (lambda (id-mom-musics) (let* ((id (first id-mom-musics)) (moment (second id-mom-musics)) (music-events (third id-mom-musics)) (music (make-music 'EventChord 'elements music-events))) (case id ((two) (add-music-event music-acc2 music moment)) ((one shared solo) (add-music-event music-acc music moment))))) (partcombine->music music1 music2 $defaultlayout)) (list (music-sequence music-acc) (music-sequence music-acc2)))) reductionB = #(define-music-function (parser location part1 part2) (ly:music? ly:music?) (let* ((seqs1+2 (combine-two-musics part1 part2)) (notes1+2 (first seqs1+2)) (notes2 (second seqs1+2))) #{ << $notes1+2 $notes2 >> #}))