Search the Community

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))))

hi all the following function could be usefull, it's a first sketch, but it seems to work.... if you want to INSERT a new OMN-seq, perhaps in bar 2 on the 3/20 in your BASIC-OMN-sequence... with this function you can do this, it will overwrite your original phrase. test it or tell me whatelse would be better... greetings andré ;;; ------------------------------------------------------------------------ ;;; INSERTING SEQ BY OVERWRITING ;;; ------------------------------------------------------------------------ ;;; SUB (defun get-resolution2 (beat) (cond ((memberp (cadr beat) '(3 6 12 24 48)) 1/24) ((memberp (cadr beat) '(1 2 4 8 16 32)) 1/16) ((memberp (cadr beat) '(5 10 20 40)) 1/20) ((memberp (cadr beat) '(7 14 28 56)) 1/28))) ;;; MAIN: INSERTING SEQ BY OVERWRITING (defun inserting-on-bar/beat* (seq &key insert time-sign bar beat) (let ((resolution (get-resolution2 beat)) (ord-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))) (distance (if (listp (car time-sign)) (+ (car (loop repeat (- bar 1) for i in time-sign collect (/ (* (1- bar) (/ (car i) (cadr i))) (get-resolution2 beat)))) (/ (/ (1- (car beat)) (cadr beat)) (get-resolution2 beat))) (+ (/ (* (1- bar) (/ (car time-sign) (cadr time-sign))) (get-resolution2 beat)) (/ (/ (1- (car beat)) (cadr beat)) (get-resolution2 beat)))))) (omn-to-time-signature (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 (= cnt distance) collect insert-rounded and do (setf cnt (+ (/ (get-span (flatten insert-rounded)) resolution) cnt -1)) else collect (nth cnt new-seq)))) ord-time-sign))) ;;; EXAMPLES (inserting-on-bar/beat* '((e c6 a5 h b5 tie) (q b5 b5 a5 tie) (h a5 q a5) (h. g5)) :insert '(s f3 e3 eb3 d3) :time-sign '(3 4) :bar 2 :beat '(2 16)) (inserting-on-bar/beat* '((e c6 a5 h b5 tie) (q b5 b5 a5 tie) (h a5 q a5) (h. g5)) :insert '(3q c5 b4 bb4 a4) :time-sign '(3 4) :bar 1 :beat '(2 12)) ;;; EXAMPLE WITH different TIME-SIGNATURES (inserting-on-bar/beat* '(e c6 a5 h b5 tie q b5 b5 a5 tie h a5 q a5 h. g5) :insert '(5q c5 b4 bb4 a4) :time-sign '((2 4 1) (3 8 1) (5 8 1) (3 4 1)) :bar 3 :beat '(3 20))

;;; 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)

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

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)

reset a pitch-sequence on a specific pitch (lowest, highest, middle pitch of the sequence) ;;;; SUB (defun center-position-in-list (list &key (get-value 'nil)) (let ((pos)) (progn (setf pos (if (evenp (length list)) (/ (length list) 2) (/ (1+ (length list)) 2))) (if (equal get-value 'nil) (append pos) (nth (1- pos) list))))) ;;; MAIN (defun reset-pitch-sequence (pitch-sequence pitch &key (type 'low)) (let ((pitch1 (cond ((equal type 'low) (car (find-ambitus pitch-sequence :type :pitch))) ((equal type 'high) (cadr (find-ambitus pitch-sequence :type :pitch))) ((equal type 'center) (center-position-in-list pitch-sequence :get-value t))))) (pitch-transpose (car (pitch-to-interval (list (if (chordp pitch1) (car (pitch-melodize pitch1)) (append pitch1)) pitch))) pitch-sequence))) (reset-pitch-sequence '(gs2 g2 a2 fs2 ds2 f2 e2) 'fs3 :type 'low) => (b3 bb3 c4 a3 fs3 gs3 g3) (reset-pitch-sequence '(gs2 g2 a2 fs2 ds2 f2 e2) 'fs3 :type 'high) => (f3 e3 fs3 eb3 c3 d3 cs3) (reset-pitch-sequence '(gs2 g2 a2 fs2 ds2 f2 e2) 'fs3 :type 'center) => (f3 e3 fs3 eb3 c3 d3 cs3)

same with gen-integer-step (defun gen-integer-step* (n intervals &key (offset 0) (every-x 1) (reverse nil)) (let ((n (* n every-x)) (seq)) (setf seq (find-everyother every-x (subseq (gen-integer-step 0 (+ n offset) intervals) offset (+ n offset)))) (if (equal reverse nil) seq (reverse seq)))) (gen-integer-step* 20 '(1 -2 3 1)) => (0 1 -1 2 3 4 2 5 6 7 5 8 9 10 8 11 12 13 11 14) (gen-integer-step* 20 '(1 -2 3 1) :every-x 2) => (0 -1 3 2 6 5 9 8 12 11 15 14 18 17 21 20 24 23 27 26) (gen-integer-step* 20 '(1 -2 3 1) :offset 6 :every-x 4 :reverse t) => (59 56 53 50 47 44 41 38 35 32 29 26 23 20 17 14 11 8 5 2) ;;;; in combination with "reading-list-by-steps" (defun reading-list-by-steps (&key steps values (start (car values))) (let ((pos (car (position-item start values)))) (append (list (nth pos values)) (loop for i in steps do (setf pos (+ pos i)) when (> pos (length values)) do (setf pos (+ 0 i)) collect (nth pos values))))) (list-plot (reading-list-by-steps :steps (gen-repeat 5 '(1 2 -1 3 4 -1)) :values (gen-integer-step* 100 '(1 2 3 1) :offset 4 :reverse t)) :join-points t)

same with fibonacci (defun fibonacci* (n &key (offset 0) (every-x 1) (reverse nil)) (let ((n (* n every-x)) (seq)) (setf seq (find-everyother every-x (subseq (fibonacci 0 (+ n offset)) offset (+ n offset)))) (if (equal reverse nil) seq (reverse seq)))) (fibonacci* 5 :offset 2) => (1 2 3 5 8) (fibonacci* 5 :offset 5 :every-x 2) => (5 13 34 89 233) (fibonacci* 5 :offset 5 :every-x 2 :reverse t) => (233 89 34 13 5) ;;;; in combination with "reading-list-by-steps" (defun reading-list-by-steps (&key steps values (start (car values))) (let ((pos (car (position-item start values)))) (append (list (nth pos values)) (loop for i in steps do (setf pos (+ pos i)) when (> pos (length values)) do (setf pos (+ 0 i)) collect (nth pos values))))) (list-plot (reading-list-by-steps :steps '(1 -1 4 -3 2 -1 3 -2 4 1 1 -1) :values (fibonacci* 14 :offset 6 :reverse t) :start 89) :join-points t)

a little prime-function-extension (defun primes* (n &key (offset 0) (every-x 1) (reverse nil)) (let ((n (* n every-x)) (seq)) (progn (setf seq (find-everyother every-x (subseq (primes (+ n offset)) offset (+ n offset)))) (if (equal reverse nil) seq (reverse seq))))) (primes* 4 :offset 0) => (2 3 5 7) (primes* 4 :offset 1) => (3 5 7 11) (primes* 6 :offset 8) => (23 29 31 37 41 43) (primes* 5 :offset 5 :every-x 2) => (13 19 29 37 43) (primes* 5 :offset 3 :every-x 4) => (7 19 37 53 71) (primes* 5 :offset 5 :every-x 3 :reverse t) => (61 47 37 23 13) ;;;; in combination with "reading-list-by-steps" (defun reading-list-by-steps (&key steps values (start (car values))) (let ((pos (car (position-item start values)))) (append (list (nth pos values)) (loop for i in steps do (setf pos (+ pos i)) when (> pos (length values)) do (setf pos (+ 0 i)) collect (nth pos values))))) (list-plot (reading-list-by-steps :steps '(1 2 -1 3 4 -1) :values (primes* 10 :offset 4 :reverse t)) :join-points t)

;;; alternative function for GEN-SYMMETRICAL: in combination ;;; with FIND-UNIQUE => symmetries with unique items (except ;;; what is generated by symmetry) (defun gen-symmetrical* (n list) (let ((list (rnd-order list)) (newlist (rest list)) (center (car list))) (if (> n (* 2 (length list))) 'list-has-too-few-items (if (evenp n) (progn (setf list (rnd-unique (/ n 2) newlist)) (append list (reverse list))) (progn (setf list (rnd-unique (/ (1- n) 2) (rest newlist))) (append list (list center) (reverse list))))))) (gen-symmetrical* 5 '(1 2 3 4 5 6 7 8)) (gen-symmetrical* 9 '(1 2 3 4 5 6 7 8)) (gen-symmetrical* 30 '(1 2 3 4 5 6 7 8)) => list-has-too-few-items ; error-message

;;; CODE (defun shift-proportions (integer-seq shift &key (type 'primes)) (let ((number-seq)) (progn (setf number-seq (cond ((equal type 'primes) (primes 30)) ((equal type 'fibonacci) (fibonacci 1 20)) ((equal type 'decimal) (gen-integer-step 1 200 1)))) (setf number-seq (append (reverse (neg! number-seq)) number-seq)) (loop for i in integer-seq when (> i 0) collect (nth (+ (car (position-item i number-seq)) shift) number-seq) else collect (nth (- (car (position-item i number-seq)) shift) number-seq))))) ;;; EXAMPLE => the integer-seq must include only values from ":type"-system (shift-proportions '(1 2 3 4 5 -3 2 -1 3 -8) 1 :type 'decimal) => (2 3 4 5 6 -4 3 -2 4 -9) (shift-proportions '(1 2 -13 4 5 -3 2 -1 3 -8) 8 :type 'decimal) => (9 10 -21 12 13 -11 10 -9 11 -16) (shift-proportions '(3 5 -17 -11 23) 1 :type 'primes) => (5 7 -19 -13 29) (shift-proportions '(3 5 -17 -11 23) 5 :type 'primes) => (17 19 -37 -29 43) (shift-proportions '(-5 55 -34 233 -89) 1 :type 'fibonacci) => (-8 89 -55 377 -144) (shift-proportions '(-5 55 -34 233 -89) 3 :type 'fibonacci) => (-21 233 -144 987 -377)

is there another way to code such a function/idea? this is (at the moment) a "theoretically function"... no concret use - l'art pour l'art :-) thanx for smarter LISP-code-IDEAS! andré ;;; evaluate PROGN (as a reset) (progn (defstruct counter n) (defvar cnt) (setf cnt (make-counter :n -1)) (defun read-list-in-steps (alist) (nth (setf (counter-n cnt) (1+ (counter-n cnt))) alist))) ;;; evaluate a view times, so one value after the other will be in the output ;;; you have to evaluate the progn-seq before every new start!!! (read-list-in-steps '(1 2 3 4 5 6)) (read-list-in-steps '(c4 f4 e4 f4 g5))