showing a substructure by length-legato

[AM]

bad code-style, but modify/use it...

 

;;; FUNCTION
;;; expands (merges) length-values in the order of the substructure-list 
;;; by inverting immediate following length-rests.
;;; 


(defun gen-legato-substructure (omn-list substructure-list)
  (loop repeat (length (single-events omn-list))
    with event-list = (single-events omn-list)
    with sub-cnt = 0           
    for cnt = 0 then (incf cnt)
    
    when (and (equal (car (cond ((lengthp (car substructure-list))
                                 (omn :length (nth cnt event-list)))
                                ((pitchp (car substructure-list))
                                 (omn :pitch (nth cnt event-list)))
                                ((velocityp (car substructure-list))
                                 (omn :velocity (nth cnt event-list)))
                                ((articulationp (car substructure-list))
                                 (omn :articulation (nth cnt event-list)))))
                     (nth sub-cnt substructure-list))
              (length-restp (car (nth (1+ cnt) event-list))))
    collect (omn-replace :length (+ (car (omn :length (nth cnt event-list)))
                                    (abs (car (omn :length (nth (1+ cnt) event-list))))) 
                         (nth cnt event-list)) 
    and do (incf cnt)
    and do (incf sub-cnt)
    else collect (nth cnt event-list)
    
    when (= sub-cnt (length substructure-list))
    do (setf sub-cnt 0)))




;;; generating something like noise

(setf mat (flatten (make-omn :pitch (loop repeat 100 collect (rnd-pick '(c4 d4 e4 f4 g4 a4 b4 c5)))
                             :length (loop repeat 100 collect '(1/16 -13/16))
                             :velocity (loop repeat 100 collect (rnd-pick '(p mp mf f)))
                             :articulation (loop repeat 100 collect (rnd-pick '(ord flaut ponte))))))



;;; EXAMPLES: 
;;; makes a "LEGATO" on this seq '(c4 d4 b4 f4)
(setf omn (gen-legato-substructure mat '(c4 d4 b4 f4)))

;;; makes a "LEGATO" on this seq '(ponte ord flaut)
;(setf omn (gen-legato-substructure mat '(ponte ord flaut)))







(def-score example
           (:title "example"
                   :key-signature 'atonal
                   :time-signature '(4 4)
                   :tempo 90)
  
  (instr
   :omn omn
   :channel 1
   :sound 'gm
   :program 'acoustic-grand-piano))