Search the Community

I find the permute function very useful, but I've some across the need to work with a very large number of permutations (all possible 12-note rows, but other situations as well). I think it would be great to have a companion function, something like nth-permutation, that returns the nth permutation of a list, as we know there will be (setq num-perms (factorial (length my-list))) permutations, and they can be traversed in a simple (loop from i upto num-perms (do-stuff (nth-permutation i))). For numbers beyond 10, the list is too large to store in memory. The Wikipedia article on permutations has some excellent strategies on cycling through all permutations one at a time and even offers some pseudo-code. I'm working on one in Common Lisp but I'm pretty much of a newbie. I'll gladly share it if I can get it working. Thanks! Paul

LISP... any solution? i want to DIVIDE a seq into sublists -> when it's asc into a list, "rest" into single-listed values - thanx a lot for some help ;;; input (divide* '(14 12 3 13 15 8 4 10 17 2 16 0 1 6 7 5 11 9)) ;;; output => ((14) (12) (3 13 15) (8) (4 10 17) (2 16) (0 1 6 7) (5 11) (9))

;;; ADD-RND-DUST TO LENGTHS ;;; this function adding RANDOMLY some "dust" to the LENGTHS, so it will be like a little rubato, ;;; or "humanizing"-effect. the ADD-SPAN is in percent (0.1 = 10%) on each length-value. (defun add-rnd-dust (omnseq &key (span '(0.1)) (seed nil) (quantize '(1 2 3 4 5 6 7 8 9))) (let ((rhy (omn :length omnseq)) (sp)) (progn (setf rhy (loop with cnt = 0 for i in rhy do (setf sp (nth cnt span)) when (not (null seed)) do (incf seed) when (> i 0) collect (+ i (car (rnd-number 1 0.0 (* i sp) :seed seed))) else collect (- i (car (rnd-number 1 0.0 (* i sp) :seed seed))) when (< cnt (1- (length span))) do (incf cnt))) (make-omn :length (quantize (float-to-ratio rhy :ratio 1/1) quantize) :pitch (omn :pitch omnseq) :velocity (omn :velocity omnseq) :articulation (omn :articulation omnseq))))) ;;; EXAMPLE (add-rnd-dust '(h c3 h. d3 -h q. f3 q g3) :span '(0.5 0.3 0.2 0.1) :quantize '(1 2 3 4 8) :seed 123) => (ht c3 h.s. d3 -e -q -t e.._3h f3 3q_q g3) (add-rnd-dust '(q c3 q d3 q e3 q f3 q g3) ;;possible add-span per value (1 = 100% of the value, 0.5 = 50% etc.) ;;if it's a list, it will stay on the last value of the span-list :span '(0.4 0.3 0 0 2) ;;how to quantize new lengths :quantize '(1 2 4 8) :seed 123) => (q c3 qt d3 q e3 f3 hs. g3) (add-rnd-dust '(h c3 h. d3 h e3 q. f3 q g3) :span '(0.5) ;; = every value max-add 50% :quantize '(1 2 3 4 8) :seed 2999) => (hs. c3 wt d3 3w.e e3 3wq. f3 q g3) (add-rnd-dust '(q c3 q d3 q e3 q f3 q g3) :span '(0.4 0.3 0 0 2) :quantize '(1 2 4 8) :seed 1111) => (qt c3 qs d3 q e3 f3 q... g3) (add-rnd-dust '(h c3 h d3 h e3 h f3 h g3) :span '(0.3 0.2 0.1 0 0.2) :quantize '(1 2 4 3 5) :seed 2999) => (5dh. c3 5dhq. d3 h e3 f3 he g3)

two functions i needed for working with POLYTEMPO-NETWORK http://philippekocher.ch/#109 http://polytempo.zhdk.ch greetings andré (defun length-to-decimal (alist &key (sum nil)) (let ((list (loop for i in (omn :length alist) collect (float (* i 4))))) (if (equal sum t) (sum list) list))) ;;; result: q = 1 / h. = 3 ...etc... (length-to-decimal '(h. h. 3q 5e 3h)) => (3.0 3.0 0.33333334 0.1 0.6666667) (length-to-decimal '(h. h. 3q 5e 3h) :sum t) => 7.1 (defun length-to-sec (alist tempo &key (sum nil)) (let ((list (loop for i in (omn :length alist) collect (* (/ 60 tempo) (float (* i 4)))))) (if (equal sum t) (sum list) list))) (length-to-sec '(h. h. 3q 5e 3h) 60) => (3.0 3.0 0.33333334 0.1 0.6666667) (length-to-sec '(h. h. 3q 5e 3h) 51) => (3.5294118 3.5294118 0.3921569 0.11764707 0.7843138) (length-to-sec '(h. h. 3q 5e 3h) 51 :sum t) => 8.3529415

for a musical research project where i work with the sorting processes of different sorting algorithms (bubble-sort, heap-sort ...), i have to program such algorithms myself. the ide is that not only the end result of the algorithm is visible but also the constant changes (the mechansim). here the first: bubble-sort. very simple and inelegant programmed - but the thing i need to have :-) bubble-sort: https://en.wikipedia.org/wiki/Bubble_sort have a look to different sorting algorithms: greetings andré ;;; bubble-sort -> with all GEN's to see the process of sorting ;;; end-test "until (equal (sort-asc alist) list)" very uncommon (and strange), ;;; but most simple-stupid test to check the end, only okay for this kind of idea ("watching the process not the endresult") (defun bubble-sort (seq) (let ((alist)) (progn (setf alist (cond ((pitchp (car seq)) (pitch-to-midi seq)) ((lengthp (car seq)) (omn :length seq)) (t seq))) (setf alist (loop until (equal (sort-asc alist) list) with list = alist append (loop for i from 0 to (- (length list) 2) for j from 1 to (- (length list) 1) when (> (nth i list) (nth j list)) collect (setf list (position-swap (list j i) list)) else do (setf list list)))) (cond ((pitchp (car seq)) (midi-to-pitch alist)) (t alist))))) (bubble-sort (rnd-order '(c5 e4 g3 b7))) (bubble-sort (rnd-order '(t s e q h w))) (bubble-sort '(1 6 334 2 6 4 111))

i didn't find a OM-library-solution for this kind of thing, so i coded it... if you want to REPLACE the articulation of some specific pitches. perhaps all 'd4 sould be PONTE... you could use this. it was necessary to code it like that, because otherwise you get in trouble with the empty parameter-slots... should work fine greetings andré ;;; SUBFUNCTIONS (defun eliminate-nil (alist) (loop for i in alist when (not (null i)) collect i)) (defun complete-event-slots (omn-list) (let ((omn-art (omn :articulation (single-events (flatten omn-list))))) (single-events (omn-replace :articulation (flatten (eliminate-nil (loop for i in omn-art for cnt = 0 then (incf cnt) when (equal (car i) '-) collect (nth (1- cnt) omn-art) else collect i))) omn-list)))) ;(complete-event-slots '(5q a4 ff pizz 5q e3 -e 5q a4 f)) ;;; MAIN FUNCTION (defun replace-articulation-of-a-pitch (omn-list &key pitches articulation (chance 1.0)) (loop for i in (complete-event-slots (flatten omn-list)) when (and (member (car (omn :pitch i)) pitches) (prob? chance)) append (omn-component-replace i (list articulation)) else append i)) ;;; EXAMPLE (replace-articulation-of-a-pitch '(5q a4 ff pizz 5q e3 p -q 5q d4 pizz) :pitches '(a4 d4) :articulation 'ponte :chance 1.0) -> (5q a4 ff ponte 5q e3 p pizz -q 5q d4 p ponte)

hi all does anybody already coded a FUNCTION to replace string-pitches by natural or artificial harmonics? is the specific notehead in OM (for the artificials)? would/could be very practical... perhaps if you have fast phrases in a large ambitus... the function - if it would be very well coded - could search for the nearest/closest fingering... greetings andré

hi all is there a possibility to SAVE my output - the OMN-lists - (rnd-generated structures) in a seperate file? that by EVALUATION the OMN-lists will be written in a sepeart/new-generated file? ...so that i have not to re-import it via MIDI (makes a lot of strange rhythms) thanks for help andré

Hi all, I just would like to give Torsten a massive THX for sharing his knowledge and code here at the forum(not just Torsten). I learn so much from you in various areas that I try to use. I have used PWGL in the past and will dig deep into what you have done and how, when it comes to make OM and PWGL to "work together". If I can get OM, PWGL and Max to exchange data I am in kind of heaven. Finally I have retired from work and have time to do what I like most. Thank you Torsten and all the other persons that share code and knowledge. /Lasse

(defun merge-voices** (seq &key insert bar/beat) (car (last (let ((bar) (beat) (distance)) (progn (setf bar (loop for i in bar/beat collect (car i)) beat (loop for j in bar/beat collect (cadr j))) (loop for ba in bar for be in beat for ins in insert with time-sign = (get-time-signature seq) with ord-time-sign = (get-time-signature seq) do (setf time-sign (if (listp (car time-sign)) (loop for i in time-sign when (> (caddr i) 1) append (loop repeat (caddr i) collect (list (car i) (cadr i))) else collect (list (car i) (cadr i))) (append time-sign)) distance (if (listp (car time-sign)) (+ (sum (loop repeat (- ba 1) for i in time-sign collect (/ (car i) (cadr i)))) (/ (1- (car be)) (cadr be))) (+ (* (1- ba) (/ (car time-sign) (cadr time-sign))) (/ (1- (car be)) (cadr be))))) do (setf ins (append (list (neg! distance)) ins)) do (setf seq (omn-to-time-signature (length-rest-merge (flatten (merge-voices (omn-merge-ties seq) ins))) ord-time-sign)) collect seq do (setf time-sign ord-time-sign))))))) (merge-voices** '((q c4 c4 c4 c4) (q c4 c4 c4 c4) (q c4 c4 c4 c4)) :insert '((q a4 a4 a4)) :bar/beat '((2 (2 8)))) (merge-voices** '((q c4 c4 c4 c4) (q c4 c4 c4 c4) (q c4 c4 c4 c4) (q c4 c4 c4 c4)) :insert '((q b5 b5 b5) (e a4 a4 a4)) :bar/beat '((2 (2 8)) (3 (2 16))))

;;; SPLITS CHORDS INTO APP/ACC ;;; SUB -> could be replaced by an original-OPMPO-function (defun omn-component-replace (omn-sequence replace-component) (make-omn :length (if (lengthp (car replace-component)) (append replace-component) (omn :length omn-sequence)) :pitch (if (or (pitchp (car replace-component)) (chordp (car replace-component))) (append replace-component) (omn :pitch omn-sequence)) :velocity (if (velocityp (car replace-component)) (append replace-component) (omn :velocity omn-sequence)) :articulation (if (articulationp (car replace-component)) (append replace-component) (omn :articulation omn-sequence)))) ;;; MAIN (defun split-chord-to-app/acc (omn-list &key (type 'app)) (let ((i)) (loop repeat (length (single-events (flatten omn-list))) for cnt = 0 then (incf cnt) do (setf i (nth cnt (single-events (flatten omn-list)))) when (chordp (car (omn :pitch i))) append (append (list (append (list type) (list'e) (butlast (melodize (car (omn :pitch i)))))) (omn-component-replace i (last (melodize (car (omn :pitch i)))))) and do (incf cnt) and do (setf i (nth cnt (single-events (flatten omn-list)))) else append i))) (split-chord-to-app/acc '(e c4 ppp d4 ff pizz e4f4 g4 a4) :type 'acc) (split-chord-to-app/acc '(e c4 ppp d4 ff pizz e4f4 g4 a4) :type 'app) (split-chord-to-app/acc '(e c4 ppp d4 ff pizz e4f4c5 g4 a4) :type 'acc) (split-chord-to-app/acc '(e c4 ppp d4 ff pizz e4f4c5 g4 a4) :type 'app)

here is a function that can be used for "post-..." of an OMN score... you could INSERT a sequence by BAR/BEAT (a slightly modified variant of OVERWRITE), so you can place your insert exactly! greetings andré ;;; INSERTING (defun get-resolution2 (be) (cond ((member (cadr be) '(3 6 12 24 48)) 1/24) ((member (cadr be) '(1 2 4 8 16 32)) 1/16) ((member (cadr be) '(5 10 20 40)) 1/20) ((member (cadr be) '(7 14 28 56 1)) 1/28))) (defun insert (seq &key insert bar/beat) (car (last (let ((bar) (beat) (resolution) (distance)) (progn (setf bar (loop for i in bar/beat collect (car i)) beat (loop for j in bar/beat collect (cadr j))) (loop for ba in bar for be in beat for ins in insert with time-sign = (get-time-signature seq) with ord-time-sign = (get-time-signature seq) ;with ins-rounded = '(0) with ins-add = '(0) do (setf resolution (get-resolution2 be) time-sign (if (listp (car time-sign)) (loop for i in time-sign when (> (caddr i) 1) append (loop repeat (caddr i) collect (list (car i) (cadr i))) else collect (list (car i) (cadr i))) (append time-sign)) distance (if (listp (car time-sign)) (+ (sum (loop repeat (- ba 1) for i in time-sign collect (/ (/ (car i) (cadr i)) (get-resolution2 be)))) (/ (/ (1- (car be)) (cadr be)) (get-resolution2 be)) ;;; ins-rounded add (/ (get-span (flatten ins-add)) (get-resolution2 be)) ) (+ (/ (* (1- ba) (/ (car time-sign) (cadr time-sign))) (get-resolution2 be)) (/ (/ (1- (car be)) (cadr be)) (get-resolution2 be)) ;;; ins-rounded add (/ (get-span (flatten ins-add)) (get-resolution2 be))) )) do (setf seq (omn-to-time-signature (length-rest-merge (flatten (loop repeat (length (omn-to-time-signature seq (list (numerator resolution) (denominator resolution)))) for cnt = 0 then (incf cnt) with new-seq = (omn-to-time-signature seq (list (numerator resolution) (denominator resolution))) with ins-rounded = (append ins (rest (length-rational-quantize (list (apply '+ (mapcar 'abs (omn :length ins)))) :round resolution))) when (= cnt distance) collect ins-rounded and do (setf ins-add (append ins-rounded ins-add)) else collect (nth cnt new-seq)))) ord-time-sign)) do (setf time-sign ord-time-sign) collect (omn-merge-ties seq))))))) ;;; EXAMPLES: ;;; with changing time-signatures (insert '((e c6 a5 h b5 q tie) (q b5 b5 a5 tie) (q a5 q a5) (h. g5)) :insert '((-3q 3q c5 b4 bb4 a4) (-3q 3q c4 b3 bb3 a3)) ;;; bar numbers has to be in ascending order! :bar/beat '((1 (1 12)) (3 (1 12)))) (insert '((e c6 a5 h b5 q tie) (q b5 b5 a5 tie) (q a5 q a5) (h. g5)) :insert '((-2/12)) :bar/beat '((2 (2 12)))) ;;; with constant time-signature (insert '((e c6 a5 h b5 tie) (q b5 b5 a5 tie) (h a5 q a5) (h. g5)) :insert '((3q c5 b4 bb4 a4) (-3q 3q c4 b3 bb3 a3)) ;;; bar numbers has to be in ascending order! :bar/beat '((1 (7 12)) (3 (2 12)))) (insert '((e c6 a5 h b5 tie) (q b5 b5 a5 tie) (h a5 q a5) (h. g5)) :insert '((-h.)) :bar/beat '((2 (1 4))))

i think, it works like that :-) now, you could OVERWRITE you original OMN sequentially with inserts... (it's very useful for "post-production" of your generated score!). i have changed the input-format (bar/beat), and it also works with changing time-signatures... i know, janusz or the opmp-programmers could code it smarter, but my concept/code seems to work... so take it and optimize it!!! greetings andré p.s. when wil be approx. the release of vers 2 of OPMO? ;;; OVERWRITING (defun get-resolution2 (be) (cond ((member (cadr be) '(3 6 12 24 48)) 1/24) ((member (cadr be) '(1 2 4 8 16 32)) 1/16) ((member (cadr be) '(5 10 20 40)) 1/20) ((member (cadr be) '(7 14 28 56 1)) 1/28))) (defun overwrite (seq &key insert bar/beat) (car (last (let ((bar) (beat) (resolution) (distance)) (progn (setf bar (loop for i in bar/beat collect (car i)) beat (loop for j in bar/beat collect (cadr j))) (loop for ba in bar for be in beat for ins in insert with time-sign = (get-time-signature seq) with ord-time-sign = (get-time-signature seq) do (setf resolution (get-resolution2 be) time-sign (if (listp (car time-sign)) (loop for i in time-sign when (> (caddr i) 1) append (loop repeat (caddr i) collect (list (car i) (cadr i))) else collect (list (car i) (cadr i))) (append time-sign)) distance (if (listp (car time-sign)) (+ (sum (loop repeat (- ba 1) for i in time-sign collect (/ (/ (car i) (cadr i)) (get-resolution2 be)))) (/ (/ (1- (car be)) (cadr be)) (get-resolution2 be))) (+ (/ (* (1- ba) (/ (car time-sign) (cadr time-sign))) (get-resolution2 be)) (/ (/ (1- (car be)) (cadr be)) (get-resolution2 be))))) do (setf seq (omn-to-time-signature (length-rest-merge (omn-merge-ties (flatten (loop repeat (length (omn-to-time-signature seq (list (numerator resolution) (denominator resolution)))) for cnt = 0 then (incf cnt) with new-seq = (omn-to-time-signature seq (list (numerator resolution) (denominator resolution))) with ins-rounded = (append ins (rest (length-rational-quantize (list (apply '+ (omn :length ins))) :round resolution))) when (= cnt distance) collect ins-rounded and do (setf cnt (+ (/ (get-span (flatten ins-rounded)) resolution) cnt -1)) else collect (nth cnt new-seq))))) ord-time-sign)) do (setf time-sign ord-time-sign) collect seq)))))) ;;; EXAMPLES: ;;; with changing time-signatures (overwrite '((e c6 a5 h b5 q tie) (q b5 b5 a5 tie) (q a5 q a5) (h. g5)) :insert '((3q c5 b4 bb4 a4) (3q c4 b3 bb3 a3)) :bar/beat '((1 (2 12)) (3 (1 12)))) ;;; with constant time-signature (overwrite '((e c6 a5 h b5 tie) (q b5 b5 a5 tie) (h a5 q a5) (h. g5)) :insert '((3q c5 b4 bb4 a4) (3q c4 b3 bb3 a3)) :bar/beat '((1 (7 12)) (3 (2 12))))

;;; gets the position => bar and beat where the value is ;;; => could be used in combination with "inserting-on-bar/beat*", ;;; if you are looking for a specific value to sprout a sequqnce ;;; FUNCTION (defun get-position (seq value &key (get 'all)) (let ((beat) (bar (car (loop for i in seq for bar = 1 then (incf bar) append (loop for j in (single-events i) when (pattern-matchp j (list value)) collect bar))))) (progn (setf beat (loop for k in (loop for i in (single-events (nth (1- bar) seq)) when (not (pattern-matchp i (list value))) append (omn :length i) else collect 'match) when (numberp k) collect (abs k) into bag when (equal k 'match) do (return (list (1+ (numerator (abs (sum bag)))) (denominator (abs (sum bag)))))))) (cond ((equal get 'all) (list bar beat)) ((equal get 'bar) (append bar)) ((equal get 'beat) (append beat))))) ;;; EXAMPLES: (setf seq '((h c4 q q) (e f4 pp f4 mp f4) (-3q 3q cs5 -3q h))) (get-position seq 'cs5 :get 'all) (get-position seq 'cs5 :get 'bar) (get-position seq 'cs5 :get 'beat) (get-position seq 'pp :get 'all)

here is a first version => replaces a PITCH by a sequence - overwriting the "old seq" - not very easy to CODE/understand how to do it :-) take a look an perhaps you have some more/better/extending ideas... a better way to solve the problems? greetings andré ;;; -------------------------------------------------------------------------------------------- ;;; FUNCTIONS ;;; -------------------------------------------------------------------------------------------- (defun get-resolution (seq pattern) (let ((val)) (progn (setq val (loop for i in (single-events seq) when (pattern-matchp i pattern) collect (denominator (car (omn :length i))))) (cond ((memberp (car val) '(3 6 12 24 48)) 1/24) ((memberp (car val) '(2 4 8 16 32)) 1/16) ((memberp (car val) '(5 10 20 40)) 1/20) ((memberp (car val) '(7 14 28 56)) 1/28))))) (defun replace-pitch-by-sequence (seq pitch insert) (let ((resolution (get-resolution seq pitch))) (omn-merge-ties (flatten (loop repeat (length (omn-to-time-signature seq (list (numerator resolution) (denominator resolution)))) for cnt = 0 then (incf cnt) with new-seq = (omn-to-time-signature seq (list (numerator resolution) (denominator resolution))) with insert-rounded = (append insert (rest (length-rational-quantize (list (apply '+ (omn :length insert))) :round resolution))) when (pattern-matchp (nth cnt new-seq) pitch) collect insert-rounded and do (incf cnt (/ (apply '+ (abs! (omn :length insert-rounded))) resolution)) collect (nth cnt new-seq)))))) ;;; -------------------------------------------------------------------------------------------- ;;; EXAMPLES ;;; -------------------------------------------------------------------------------------------- (setf seq '(3q cs5 c5 b4 q c4 d4 e. e4 s f4 h g4)) (setf omn-new (replace-pitch-by-sequence seq (list (rnd-pick (omn :pitch seq))) ;; for tests: takes rnd-pitches (rnd-pick '((t gs5 g5 fs5 f5 e5) ;; for tests: takes rnd-inserts (q gs5 -e e gs5) (3q gs5 tie q gs5) (s gs5 tie q gs5))))) (setf omn-old seq) ;;; -------------------------------------------------------------------------------------------- (def-score test (:title "test" :key-signature 'atonal :time-signature '(4 4) :tempo 90 :layout (bracket-group (treble-layout 'new) (treble-layout 'old))) (new :omn omn-new ;; OMN with iNSERT :channel 1 :port 1 :sound 'gm :program 'acoustic-grand-piano) (old :omn omn-old ;; OMN without iNSERT :channel 1 :port 1 :sound 'gm :program 'acoustic-grand-piano))

take it as a sketch... you can see the input/output greetings andré p.s. could be nice, if we combine it with a/the/my overwrite-function p.s.s an overwrite-function could be very very smart for work... think: for example: you have coded some music but you would overwrite the last two quaternotes of bar 5 in the violin.... !? ;;; ------------------------------------------------------------------------ ;;; INSERTING ON BAR/BEAT ;;; ------------------------------------------------------------------------ (defun inserting-on-bar/beat (insert &key time-sign bar beat) (let ((extra-rest (* -1 (/ (- (car beat) 1) (cadr beat)))) (basic-time-sign time-sign) (time-sign (if (listp (car time-sign)) (loop for i in time-sign when (> (caddr i) 1) append (loop repeat (caddr i) collect (list (car i) (cadr i))) else collect (list (car i) (cadr i))) (append time-sign)))) (omn-to-time-signature (length-rest-merge (flatten (append (if (> bar 1) (list (if (listp (car time-sign)) (loop repeat (- bar 1) for i in time-sign collect (* -1 (/ (car i) (cadr i)))) (* -1 (1- bar) (/ (car time-sign) (cadr time-sign)))))) (length-rational-quantize (if (/= 0 extra-rest) (append (list extra-rest) insert) insert) :round (if (listp (car time-sign)) (/ (car (nth bar time-sign)) (cadr (nth bar time-sign))) (/ (car time-sign) (cadr time-sign))))))) basic-time-sign))) ;;; ------------------------------------------------------------------------ ;;; INSERTING ON BAR/BEAT ;;; ------------------------------------------------------------------------ (inserting-on-bar/beat '(s c4 d4 e4 f4 pp) :time-sign '(4 4) :bar 2 :beat '(3 16)) (inserting-on-bar/beat '(5q c4 d4 e4 f4 pp) :time-sign '(4 4) :bar 2 :beat '(2 20)) (inserting-on-bar/beat '(3q c4 d4 e4 f4 pp) :time-sign '(4 4) :bar 1 :beat '(5 12)) (inserting-on-bar/beat '(s c4 d4 e4 f4 pp) :time-sign '((2 4 1) (3 8 1) (5 8 1) (3 4 1)) :bar 3 :beat '(3 16))

https://en.wikipedia.org/wiki/Collatz_conjecture ;;experiment with COLLATZ-conjecture ;;https://en.wikipedia.org/wiki/Collatz_conjecture (defun collatz (start-value number-of-value) (loop repeat number-of-value with value = start-value when (evenp value) do (setq value (/ value 2)) else do (setq value (+ (* 3 value) 1)) collect value)) (list-plot (collatz 15 20) :zero-based t :point-radius 2 :join-points t) ;;;;;;;;;;;; ;;same function like fibonacci-transition but now with COLLATZ. ;;don't know if that makes sense - just a bit code :-) (defun transition-with-collatz (number-of-values start-val value-a value-b) (let ((coll-length) (coll-seq) (all-seq)) (setq coll-length (loop for cnt = 1 then (incf cnt) collect (sum (collatz start-val cnt)) into bag when (> (car (last bag)) number-of-values) do (return (1- (length bag)))) coll-seq (collatz start-val coll-length) all-seq (append (reverse coll-seq) (loop repeat (- number-of-values (sum coll-seq)) collect 1))) (loop for i in all-seq append (loop repeat i for cnt = 0 then (incf cnt) when (= cnt 0) collect value-b else collect value-a)))) ;;example-1 => only the process => makes sense when using a lot of values... (list-plot (transition-with-collatz 500 56 1 2) :zero-based t :point-radius 2 :join-points t)

;;; -------------------------------------------------------------------------- ;;; "mirror image" of a cutout ;;; -------------------------------------------------------------------------- ;;; this function is generating a "mirror image" of a cutout ;;; by random-length/pos or by event-numbers ;;; the "untaken" part will be replaced by rests ;;; the "special thing is" to connect it exactly/immediately to the original-seq ;;; and as filtered-seq you could use it in an other part/instrument ;;; i coded it for my current work... so, take it or delete it! (defun mirror-seq (n omn-list &key (type 'r)) (let ((single-seq (single-events omn-list)) (seq) (rests)) (progn (setf seq (flatten (loop repeat (if (listp n) (cadr n) (1+ (random (- (length single-seq) n)))) for i in single-seq collect i))) (setf rests (neg! (apply '+ (mapcar 'abs (omn :length (flatten seq)))))) (setf seq (cond ((equal type 'r) (gen-retrograde seq)) ((equal type 'i) (pitch-invert seq)) ((equal type 'ri) (pitch-invert (gen-retrograde seq))))) (setf seq (flatten (loop repeat (if (listp n) (- (cadr n) (car n)) n) for i in (single-events seq) collect i))) (flatten (list rests seq))))) ;;; examples ;;; if n = integer -> random-seq ;;; if n = integer-list -> event-posititon => constant ;;; types r / i / ri (setf seq '(e. b3 mf c4 s d4 pp q eb4 e4 f4 t fs4)) ;;; retro (setf exp1 (mirror-seq 2 seq :type 'r)) (setf exp2 (mirror-seq '(1 4) seq :type 'r)) ;;; retro/inv ;(setf exp1 (mirror-seq 2 seq :type 'ri)) ;(setf exp2 (mirror-seq '(1 4) seq :type 'ri)) ;;; inv ;(setf exp1 (mirror-seq 2 seq :type 'i)) ;(setf exp2 (mirror-seq '(1 4) seq :type 'i)) (def-score only-anonsense-example (:title "exp" :key-signature 'atonal :time-signature '(4 4) :tempo 124 :layout (bracket-group (treble-layout 'original) (treble-layout 'exp1) (bass-layout 'exp2))) (original :omn seq :channel 1 :port 1 :sound 'gm :program 'acoustic-grand-piano) (exp1 :omn (pitch-transpose 0 exp1) :channel 1 :port 1 :sound 'gm :program 'acoustic-grand-piano) (exp2 :omn (pitch-transpose 0 exp2) :channel 1 :port 1 :sound 'gm :program 'acoustic-grand-piano)) added 3 minutes later in comination with length-augmentation (and tranpositions) you could generate a "distorted mirror image" in an other part/instrument

use it if you like.. i needed it as a subfuction for length-legato* ... greetings andré (defun symmp (seq) (let ((seq2 (if (evenp (length seq)) (list (filter-first (/ (length seq) 2) seq) (reverse (filter-last (/ (length seq) 2) seq))) (list (filter-first (/ (1- (length seq)) 2) seq) (reverse (filter-last (/ (1- (length seq)) 2) seq)))))) (if (null (member 'nil (loop for i in (car seq2) for j in (cadr seq2) when (equal i j) collect 'T else collect 'NIL))) 't))) (symmp '(-1 2 3 5 5 3 2 -1)) (symmp '(-1 2 3 5 7 5 3 2 -1)) (symmp '(-1 2 3 4 5 3 2 -1)) (symmp '(c4 d4 fs5 d4 c4)) (symmp '(c4 d4 fs5 d4 b4)) (symmp '(mf f mp mp f mf)) (symmp '(mf f f mp fff f mf))

an idea/extension could be to "filter-events" not only by singular pitches/lengths... but also by motifs, means sequences => "filter a PATTERN" function-name: filter-pattern

hi all i'm trying to code a PM-function with an OVERWRITE, so that the global-lengths stays correct... i'm working this evening with some ideas for that and this is only a first sketch of a basic idea, don't know if it will work later... i have one little ordinary problem: to find/insert/overwrite i have to split the original sequence into small parts... that's the RESOLUTION, so i have a list with OMN-events in the span of the resolution. and a lot of TIEs -> at the end i would like to remove the tied-lengths by ordinary lengths? how? filter-tie works not with all insert-examples.... what can i do...? thanx andré ;;; -------------------------------------------------------------------------------------------- ;;; OVERWRITE -> überschreibt eine sequenz bei PM -> resolution einstellbar ;;; -------------------------------------------------------------------------------------------- ;;; ausgangs-sequenz (setf seq '(q c4 d4 e. e4 s f4 h g4)) ;;; inserts => test different INSERTS (setf insert '(t gs5 g5 fs5 f5 e5)) ;(setf insert '(q gs5 -e e gs5)) ;(setf insert '(1/24 gs5 1/24 1/24)) ;;; pattern => if such a pattern matched => now INSERT starting at PITCH f4 (setf pattern '(? f4)) ;;; resolution of SCANNING/INSERTING (setf resolution 1/16) ;;; -------------------------------------------------------------------------------------------- (setf omn-old seq) (setf omn-new (loop repeat (length (omn-to-time-signature seq (list (numerator resolution) (denominator resolution)))) for cnt = 0 then (incf cnt) with new-seq = (omn-to-time-signature seq (list (numerator resolution) (denominator resolution))) with insert-rounded = (append insert (rest (length-rational-quantize (list (apply '+ (omn :length insert))) :round resolution))) when (pattern-matchp (nth cnt new-seq) pattern) collect insert-rounded and do (incf cnt (/ (apply '+ (abs! (omn :length insert-rounded))) resolution)) collect (nth cnt new-seq))) (setf omn-new (flatten omn-new)) ;;; -------------------------------------------------------------------------------------------- (def-score test (:title "test" :key-signature 'atonal :time-signature '(4 4) :tempo 90 :layout (bracket-group (treble-layout 'new) (treble-layout 'old))) (new :omn omn-new :channel 1 :port 1 :sound 'gm :program 'acoustic-grand-piano) (old :omn omn-old :channel 1 :port 1 :sound 'gm :program 'acoustic-grand-piano)) added 4 minutes later some other ideas to the main problems or some great solutions are very welcome :-)

extendig SINGLE-EVENTS with optional-datas (like instrument-name, or whatelse) and reading/filtering this EVENT-LIST by a key-value -> useful for instrumentation... greetings andré ;;; --------------------------------------------------------------------------------------------- ;;; extending single-events with optional-datas ;;; --------------------------------------------------------------------------------------------- ;; SUBFUNCTION (defun memberp (n liste) (not (equal 'nil (member n liste)))) ;; MAINFUNCTION (defun create-extended-single-events (omn-list &key (optional-data1 nil) (optional-data2 nil) (optional-data3 nil)) (loop for i in (single-events omn-list) for data-cnt = 0 then (incf data-cnt) when (< (car (omn :length i)) 0) collect (append (list (first i)) (gen-repeat 6 'nil)) else collect (append (loop repeat 4 for cnt = 0 then (incf cnt) collect (nth cnt i)) (append (list (nth data-cnt optional-data1) (nth data-cnt optional-data2) (nth data-cnt optional-data3)))))) (create-extended-single-events '(e c4 mp stacc e. -h e. p ord e e4 stacc) :optional-data1 '(trp fl trp trp fl clar) :optional-data2 '(1 3 2 4 3 5 3 1 1)) ;; events are extended with the optional-data1-x => ((e c4 mp stacc trp 1 nil) (e. c4 mp nil fl 3 nil) (-h nil nil nil nil nil nil) (e. c4 p ord trp 4 nil) (e e4 p stacc fl 3 nil)) ;;; --------------------------------------------------------------------------------------------- ;;; reads events by key-values!! ;;; --------------------------------------------------------------------------------------------- ;;; now, with this function, you can filter all EVENTS with key-value X. all others will be replaced ;;; by RESTS, so the time-length-structure will be not destroyed. you can say: i need all EVENTS ;;; with key-value 'trp in the trumpet-voice, or all EVENTS with key-value 'c4 for .... (defun read-single-events-by (event-stream &key (key-value 'c4)) (loop for i in event-stream when (memberp key-value i) collect i else collect (append (list (length-invert (first i))) (gen-repeat 6 'nil)))) (read-single-events-by '((e c4 mp stacc trp 1 nil) (e. c4 p ord fl 3 nil) (e e4 p stacc trp 2 nil)) :key-value 'trp) ;; shows all EVENTS with key-value 'trp (other events are replaced by rests) => ((e c4 mp stacc trp 1 nil) (-3/16 nil nil nil nil nil nil) (e e4 p stacc trp 2 nil)) (read-single-events-by '((e c4 mp stacc trp 1 nil) (e. c4 p ord fl 3 nil) (e e4 p stacc trp 2 nil)) :key-value '3) ;; shows all EVENTS with key-value '3 (other events are replaced by rests) => ((-1/8 nil nil nil nil nil nil) (e. c4 p ord fl 3 nil) (-1/8 nil nil nil nil nil nil)) (read-single-events-by '((e c4 mp stacc trp 1 nil) (e. c4 p ord fl 3 nil) (e e4 p stacc trp 2 nil)) :key-value 'ord) ;; shows all EVENTS with key-value 'ord (other events are replaced by rests) => ((-1/8 nil nil nil nil nil nil) (e. c4 p ord fl 3 nil) (-1/8 nil nil nil nil nil nil))

(defun modify-length-of-a-technique (omn-list &key technique (factor 1) (modification 'augmentation)) (flatten (loop for i in (single-events omn-list) when (equal (car (omn :articulation i)) technique) collect (cond ((equal modification 'augmentation) (length-augmentation factor i)) ((equal modification 'diminution) (length-diminution factor i))) else collect i))) (modify-length-of-a-technique '(q d4 mf ponte e fs4 tasto -e. e g4 tasto q gs4 ponte) :technique 'ponte :factor 10 :modification 'augmentation) ;; also 'diminution

modifying stephane' s code (defun replace-length-of-a-technique (omn-list &key technique length) (flatten (loop for i in (single-events omn-list) when (equal (nth 3 i) technique) collect `(,(rnd-pick* length) ,(nth 1 i) ,(nth 2 i) ,(nth 3 i)) else collect i))) (replace-length-of-a-technique '(e. c4 p tasto d4 ponte e4) :technique 'tasto :length '(1/32)) (replace-length-of-a-technique '(e. c4 p tasto d4 ponte e4 d4 tasto f5 tasto) :technique 'tasto :length '(1/32 2/32 3/32)) ;; rnd

if you want to change VELOCITY of a technique... (defun replace-velocity-of-a-technique (omn-list &key technique velocity) (flatten (loop for i in (single-events omn-list) when (equal (car (omn :articulation i)) technique) collect (pattern-map (list (list (list '? technique) (list velocity technique))) i) else collect i))) (replace-velocity-of-a-technique '(e. c4 p tasto d4 ponte e4) :technique 'tasto :velocity 'f)