AM

so i could search articulation-patterns in my BOTS => is it complicated? i would need it urgent :-)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; WHEN PATTERN-MATCH => T ;;; THEN WEIGHETD RANDOM DECIDING THE NEXT VALUE ;;; with :gate/:keyword = extra AND-function ;;; with :evaluate => you could evaluate a function-output directly ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; subfunctions (defun pattern-match (liste pattern) (loop for z in liste with cnt = 0 with pattern_cnt = 0 when (or (equal (nth cnt pattern) z) (equal '? (nth cnt pattern))) do (incf pattern_cnt) and do (incf cnt) else do (setq cnt (setq pattern_cnt 0)) when (equal pattern_cnt (length pattern)) collect 't into bag and do (return (car bag)))) (defun test.pm.omn (seq pattern) (let ((seq (if (omn-formp seq) (cond ((lengthp (car pattern)) (omn :length seq)) ((pitchp (car pattern))(omn :pitch seq)) ((velocityp (car pattern)) (omn :velocity seq))) (append seq)))) (pattern-match seq pattern))) (defun weighted-random (list) (loop for item in list with rand-num = (random (loop for x in list sum (second x))) for add = (second item) then (+ add (second item)) when (< rand-num add) return (first item))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; mainfunction (defun test.pm+chance (test.seq pattern values/weights &key keyword gate (evaluate 'nil)) (let ((out)) (setf out (if (and (test.pm.omn test.seq pattern) (equal keyword gate)) (weighted-random values/weights) (append gate))) (if (equal evaluate 't) (eval out) (append out)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; example => works also with OMN etc... (test.pm+chance '(1 2 3 4 5 4 3 5 6 7 2) '(5 ? 3) '((a 0.5) (b 0.15) (c 0.375) (d 0.21))) ;; more examples (test.pm+chance '(1 2 3 4 5 4 3 5 6 7 2) '(5 ? 3) '((a 0.5) (b 0.25) (c 0.25)) :gate 'no-entry :keyword 'no-entry) ;; => key correct (test.pm+chance '(1 2 3 4 5 4 3 5 6 7 2) '(5 ? 3) '((a 0.5) (b 0.5)) :gate 'no-entry :keyword 'whatever) ;; key incorrect ;; example with :evaluate T (test.pm+chance '(1 2 3 4 5 4 3 5 6 7 2) '(5 ? 3) '(((cons 'a 'b) 0.5) ((cons 'c 'd) 0.5)) :evaluate t)

yes, because with it, i could code more "multi-usable" functions :-)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; WHEN PATTERN-MATCH => T ;;; THEN MARKOV PRODUCES THE NEXT VALUES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; subfunctions (defun pattern-match (liste pattern) (loop for z in liste with cnt = 0 with pattern_cnt = 0 when (or (equal (nth cnt pattern) z) (equal '? (nth cnt pattern))) do (incf pattern_cnt) and do (incf cnt) else do (setq cnt (setq pattern_cnt 0)) when (equal pattern_cnt (length pattern)) collect 't into bag and do (return (car bag)))) (defun test.pm.omn (seq pattern) (let ((seq (if (omn-formp seq) (cond ((lengthp (car pattern)) (omn :length seq)) ((pitchp (car pattern))(omn :pitch seq)) ((velocityp (car pattern)) (omn :velocity seq))) (append seq)))) (pattern-match seq pattern))) ;; mainfuction (defun test.pm+markov (seq pattern start-slot transitions &key (size 1)) (if (test.pm.omn seq pattern) (if (= size 1) (car (rest (gen-markov-from-transitions transitions :size (1+ size) :start start-slot))) (rest (gen-markov-from-transitions transitions :size (1+ size) :start start-slot))) (append start-slot))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf transitions '((a (a 2) (b 1)) (b (a 2) (b 1)))) (setq test-omn '(t fs4 pp tasto g4 ppp tasto -s. t e4 pppp tasto -s. t eb4 pp tasto -het - t)) ;; examples1 (test.pm+markov test-omn '(pp ppp) 'a transitions) ;; evaluate a few times (test.pm+markov test-omn '(fs4 g4) 'a transitions) ;; evaluate a few times (test.pm+markov test-omn '(g2) 'a transitions) ;; evaluate a few times => no match => no new value (test.pm+markov test-omn '(1/32 -3/32) 'a transitions) ;; evaluate a few times ;; examples2 (test.pm+markov test-omn '(pp) 'a transitions :size 5) ;; evaluate a few times (test.pm+markov test-omn '(g4 e4) 'a transitions :size 3) ;; evaluate a few times ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

is there an articulationp like a pitchp etc???

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; PATTERN MATCH FUNCTIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; i needed some PATTERN_MATCH-FUNCTIONS (also with wildcards) ;;; in my projects to check sequences ;;; output is t/nil - ;;; implement it if you whant :-) regards, andré ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun pattern-match (liste pattern) (loop for z in liste with cnt = 0 with pattern_cnt = 0 when (or (equal (nth cnt pattern) z) (equal '? (nth cnt pattern))) do (incf pattern_cnt) and do (incf cnt) else do (setq cnt (setq pattern_cnt 0)) when (equal pattern_cnt (length pattern)) collect 't into bag and do (return (car bag)))) (pattern-match '(1 2 3 4 5 6 7 8) '(2 ? 3)) => nil (pattern-match '(1 2 3 4 5 6 7 8) '(2 ?)) => t ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test.pm.length (seq pattern) (let ((seq (if (omn-formp seq) (omn :length seq) (append seq)))) (pattern-match seq pattern))) (defun test.pm.pitch (seq pattern) (let ((seq (if (omn-formp seq) (omn :pitch seq) (append seq)))) (pattern-match seq pattern))) (defun test.pm.velocity (seq pattern) (let ((seq (if (omn-formp seq) (omn :velocity seq) (append seq)))) (pattern-match seq pattern))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ASHBY-OPERATOR => some nonsense-sound-examples ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; little function for mapping... (defun eliminate-repetitions (liste) (let ((liste (append liste (list 'nil)))) (loop repeat (1- (length liste)) with cnt = 0 when (not (equal (nth cnt liste) (nth (+ 1 cnt) liste))) collect (nth cnt liste) do (incf cnt)))) ;;; some examples ;(setq integers ; (flatten (ashby-operator-1 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)))) (setq integers (flatten (ashby-operator-1 '( 3 1 4 0 7 8 9 10 5 6 2 11)))) ;(setq integers ; (flatten (ashby-operator-1 (gen-sieve '(c4 c7) '(1 2 3))))) ;;; mapping (setq pitches (eliminate-repetitions (integer-to-pitch integers))) (def-score example (:key-signature 'chromatic :time-signature '(4 8) :tempo '(e 176) :layout (bracket-group (piano-grand-layout 'piano))) (piano :omn (setq omn-list (make-omn :pitch pitches :length (loop repeat (length pitches) collect 1/32))) :sound 'gm-piano)) #| (def-score example-reverse (:key-signature 'chromatic :time-signature '(4 8) :tempo '(e 176) :layout (bracket-group (piano-grand-layout 'piano))) (piano :omn (setq omn-list (make-omn :pitch (reverse pitches) :length (loop repeat (length pitches) collect 1/32))) :sound 'gm-piano)) |#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ASHBY-OPERATOR: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; i coded somethings special, that i have seen in a book ;;; of HEINZ VON FOERSTER (my favorite writer/philosopher..) ;;; https://en.wikipedia.org/wiki/Heinz_von_Foerster ;;; => i didn't found this ASHBY-algo (he is writing about it) ;;; anywhere else, but for me it was interesting to code it. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; every list of integers (from 0 to ?) will end with "0" ;;; perhaps you could map it with whatever you want ....... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ashby-operator-1 (liste) (append (list liste) (loop with slot-pos with slot-val with slot-product ;; choose two positions in the list do (setq slot-pos (loop repeat 2 collect (random (length liste)))) ;; picks the values from the positions do (setq slot-val (list (nth (first slot-pos) liste) (nth (second slot-pos) liste)) ;; gen the product of the two values slot-product (* (first slot-val) (second slot-val))) ;; replace the value of the first pos with the (first (explode slot-product)) ;; or when it's < 10 with 0 do (setq liste (loop for i in liste for cnt = 0 then (incf cnt) when (= cnt (first slot-pos)) collect (if (> slot-product 9) (first (explode slot-product)) (append 0)) else collect i)) ;; replace the value of the second pos with the (second (explode slot-product)) ;; or or when it's < 10 with the slot-product collect (setq liste (loop for i in liste for cnt = 0 then (incf cnt) when (= cnt (second slot-pos)) collect (if (> slot-product 9) (second (explode slot-product)) (append slot-product)) else collect i)) into bag ;; collects all into bag ;; when LISTE only '(0 0 0 0 0 ...) return all generations when (= (sum liste) 0) do (return bag)))) ;;;examples (ashby-operator-1 '(0 1 2 3 4 5 6 7 8 9)) (list-plot (flatten (ashby-operator-1 '(0 1 2 3 4 5 6 7 8 9 11))) :point-radius 0.1 :style :fill :line-width 1) (integer-to-pitch (ashby-operator-1 '(0 1 2 3 4 5 6 7 8 9 10 11))) (chordize-list (integer-to-pitch (remove-duplicates (ashby-operator-1 '(0 1 2 3 5 8 13)))))

yes, but... it has some error... > Error: No length specified before first pitch > While executing: (:internal parse-omn-note), in process Listener-1(6). > Type cmd-. to abort, cmd-\ for a list of available restarts. > Type :? for other options. only when i do gen-rotate with the sequence the sequence works with perhaps (gen-retrograde seq) or... the sequence (produced by rnd-bots) is for example, something like that... ((et b1 f gettato t f1 ff ord et cs3 mf gettato t fs3 f tasto d5 tasto et g5 mf gettato t eb7 ff ord et a6 f gettato)) and works fine without (gen-rotate

is there a function to ROTATE a complete omn-sequence? (like a sample) .... thanks for help!

bad code but nice results... :-) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; rnd-symm-expand => generates rnd-symm transpositions ;;;; in different sequences (intervals, OMN-form,rhythms... ;;;; :chance => 0.0 - 1.0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun rnd-symm-expand (seq &key (possible-intervals '(12 -12)) (chance 1)) (let ((row) (firstpart) (rev-secondpart) (out)) (setq row (if (pitchp (first seq)) (pitch-to-midi seq) (append seq))) (setq firstpart (loop repeat (if (evenp (length row)) (/ (length row) 2) (/ (1- (length row)) 2)) for cnt = 0 then (incf cnt) collect (nth cnt row))) (setq rev-secondpart (loop repeat (if (evenp (length row) ) (/ (length row) 2) (/ (1- (length row)) 2)) for cnt = (- (length row) 1) then (decf cnt) collect (nth cnt row))) (loop for i in firstpart for j in rev-secondpart with int = 0 do (if (prob? chance) (setq int (rnd-pick possible-intervals)) (setq int 0)) collect (+ i int) into bag1 collect (+ j (* -1 int)) into bag2 when (= (length bag2) (if (evenp (length row)) (/ (length row) 2) (/ (1- (length row)) 2))) do (if (evenp (length row)) (setq out (append bag1 (reverse bag2))) (setq out (append bag1 (list (nth (length firstpart) row)) (reverse bag2))))) (if (pitchp (first seq)) (midi-to-pitch out) (append out)))) ;;;examples (rnd-symm-expand '(0 0 0 0 0 0 0 0 0 0) :possible-intervals '(4 12 7) :chance 0.5) (rnd-symm-expand '(1/4 1/4 1/4 1/4 1/4) :possible-intervals '(-1/32 1/32) :chance 0.5) (rnd-symm-expand '(c1 c2 c3 c4 c5 c6) :possible-intervals '(1 -1) :chance 0.5)

perfect...! a kind of... (compress-time-signatures bars) was my next step... so... thanx to you!! perhaps, both in ONE?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; modify time-signatures like '(1 4 3) to (3 4 1), ;;; helps me after (split-tuplet-lengths) to clean up ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; with the :exclude and :threshold ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun modify-time-signature-repetitions (time-signature-seq &key (exclude '((0 0))) (threshold '10/4) (numerator-threshold 20)) (loop for i in time-signature-seq when (and (> (third i) 1) (< (/ (first i) (second i)) threshold) (< (* (first i) (third i)) numerator-threshold) (not (if (listp (first exclude)) (loop for x in exclude when (equal (butlast i) x) collect t) (equal (butlast i) exclude)))) collect (list (* (first i) (third i)) (second i) 1) else collect i)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq bars '((5 4 4) (1 4 2) (3 4 2) (1 8 5) (1 32 8))) (modify-time-signature-repetitions bars) (modify-time-signature-repetitions bars :exclude '(1 4)) (modify-time-signature-repetitions bars :exclude '((1 4) (1 8))) (modify-time-signature-repetitions bars :exclude '((1 32)) :threshold '4/4) (modify-time-signature-repetitions bars :numerator-threshold 7) ;; because i don't want 200/4 - bars :-) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

it's allready in my USER LIBRARY... just say when you are not interested in such things - i know you have a lot of work without these extra-stuff... :-) i'm very happy with OPUSMODUS!

VERY NICE CODE... but your function does not do the same as mine ...perhaps a misunderstanding / a different idea! ...you compensate EVERY value, my code only compensates when "rhy" is changing (length-round '(1/16 3/16 2/32 5/7 4/20 6/20 3/20 5/16)) => (1/16 -3/16 3/16 -1/16 1/16 -3/16 5/7 -1/28 1/5 -1/20 3/10 -1/5 3/20 -1/10 5/16 -3/16) ..after the 1/16 it's not necessary to "round" with -3/16, because -> also with teh other values here with my code -> i only want to compensate when "denominators" are changing => have a look at markings (bold) (length-compensate2 '((1 16) (3 16) (2 32) (5 7) (4 20) (6 20) (3 20) (5 16))) => (1/16 3/16 1/16 -3/16 5/7 -1/28 1/5 3/10 3/20 -1/10 5/16 -3/16)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; a little function to compensate special-rhy-changes ;;; to 1/4-note structure... (or all :compensating-to -values) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; best format-solution was 1/32 => '(1 32) etc... otherwise ;;; i get in trouble with 1/8 = 4/32 - what is mathematicclay ;;; correct - but bringing BUGS to the output ;;; if anybody could transform things '(2/32) to '(2 32) or ;;; '(3/12) to '(3 12) would be nice, i coudn't code it. this ;;; things are necessary because the function makes decicions ;;; bewtween the denominators, so there sould be constant!!!! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun length-compensate2 (liste &key (compensating-to '(1 4))) (butlast (loop for event in (loop for i in (append liste (list (list (* -1 (first compensating-to)) (/ 1 (second compensating-to))))) collect (list (first i) (/ 1 (second i)))) with nenner with modulo with event_stack with add_duration = 0 with corr_event when (or (null event_stack) (= (second event_stack) (second event))) do (setq add_duration (+ add_duration (abs (first event))) event_stack event corr_event nil) else do (progn (setq nenner (/ (/ 1 (second event_stack)) (second compensating-to)) modulo (mod add_duration nenner)) (if (/= modulo 0) (setq corr_event (* (* -1 (- nenner modulo)) (second event_stack)))) (setq add_duration (abs (first event)))) when (not (equal corr_event 'nil)) collect corr_event and do (setq corr_event nil) collect (* (first event) (second event)) do (setq event_stack event)))) ;example-1 (length-compensate2 (loop repeat 5 collect (rnd-pick '((1 16) (-1 16) (2 32) (5 7) (13 9) (4 20) (6 20) (3 20) (5 16))))) ;exampl-2 (length-compensate2 (loop repeat 5 collect (rnd-pick '((1 16) (-1 16) (2 32) (5 7) (13 9) (4 20) (6 20) (3 20) (5 16)))) :compensating-to '(1 8))

i know, but only mathematically!! -> you remember the problem with gen-stacc? => we discussed that with rangarajan? for some functions it's necessary that 2/20 will not be "reduced" to 1/20 => https://opusmodus.com/forums/topic/528-gen-stacc-question/#comment-1446

thanx, but i see my idea don't work with that... concrete: i want to split 2/20 into exactly '(2 20) function with numerator/denominator it will be '(1 10) - not what i need also with (explode '2/20) => (1 / 1 0) is there any solution?

hi all i need a little lisp-help... i want to split things like this perhaps 'an3 into '(a n 3) is there a way? thanx andré

thanx!!! a.

a short - and perhaps stupid - question... what's the idea for this function, useful for ...? practical purpose? thanx for a short hint!

thank you, i just like it :-) know everythings seems complete...

;;;;; ;;;;; gen-stacc2 and gen-stacc3 => usefull tools to build little variants ;;;; subfunctions => also possible with prob? (defun weighted-random (list) (loop for item in list with rand-num = (random (loop for x in list sum (second x))) for add = (second item) then (+ add (second item)) when (< rand-num add) return (first item))) (defun weighted-t/nil (on-weight) (let ((off-weight (- 1 on-weight))) (weighted-random (list (list 't on-weight) (list 'nil off-weight))))) ;;;; mainfunctions (defun gen-stacc (liste) (if (numberp liste) (if (> (numerator liste) 1) (list (/ 1 (denominator liste)) (/ (* -1 (- (numerator liste) 1)) (denominator liste))) (list liste)) (loop for i in liste append (if (> (numerator i) 1) (list (/ 1 (denominator i)) (/ (* -1 (- (numerator i) 1)) (denominator i))) (list i))))) (gen-stacc '(1/32 7/32 9/32 17/32)) (gen-stacc '(3/8)) ;; (defun gen-stacc2 (n liste &key (stacc-chance 1)) (loop for i in liste when (and (> i n) (equal (weighted-t/nil stacc-chance) 't)) append (list n (* -1 (- (abs i) n))) else collect i)) (gen-stacc2 1/32 '(1/32 7/32 9/32 17/32) :stacc-chance 0.5) ;; (defun gen-stacc3 (n-liste liste &key (stacc-chance 1)) (loop for i in liste with n do (setq n (rnd-pick n-liste)) when (and (> i n) (equal (weighted-t/nil stacc-chance) 't)) append (list n (* -1 (- (abs i) n))) else collect i)) (gen-stacc3 '(1/32 5/32) '(1/32 7/32 5/32 9/32 17/32 3/8 9/32 17/32) :stacc-chance 0.5) ;;;;;;

a concrete example (but musical-nonsense)... of a TRANSITION produced by a special markov-program 1) functions/subfuctions ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun add-transition-weight (transition-list value add-weight) (loop for j in transition-list collect (append (list (first j)) (loop repeat (1- (length j)) for cnt = 1 then (incf cnt) when (equal (first (nth cnt j)) value) collect (list (first (nth cnt j)) (+ add-weight (second (nth cnt j)))) else collect (nth cnt j))))) ;;;;;;;;;;;;;;;;;;;;;;;;;; (defun count-repetitions (value-list) (let ((seq (append value-list (list 'nil)))) (loop repeat (1- (length seq)) with count = 1 for cnt1 = 0 then (incf cnt1) for cnt2 = 1 then (incf cnt2) when (equal (nth cnt1 seq) (nth cnt2 seq)) do (incf count) when (not (equal (nth cnt1 seq) (nth cnt2 seq))) collect count and do (setq count 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun eliminate-repetitions (liste) (let ((liste (append liste (list 'nil)))) (loop repeat (1- (length liste)) with cnt = 0 when (not (equal (nth cnt liste) (nth (+ 1 cnt) liste))) collect (nth cnt liste) do (incf cnt)))) (eliminate-repetitions '(1 1 2 3 4 4 4 1 1 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun gen-markov-from-transitions-with-tendency (transitions size generations value &key (add-weight 1) (start (first (first transitions)))) (loop repeat generations with list = (gen-markov-from-transitions transitions :size size :start start ) with weight = add-weight with weight-growth = 0 do (setq transitions (add-transition-weight transitions value weight)) append (setq list (gen-markov-from-transitions transitions :size size :start (filter-first-last 1 list))) do (incf weight (incf weight-growth)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2) example and possible implementation => create a TRANSITION to value 3 (=> to pitch eb4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;evaluate a few times, to check it;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list-plot ;;non-neutral-table (setq integers (gen-markov-from-transitions-with-tendency '((1 (1 1) (2 4) (3 1)) (2 (1 1) (4 1) (3 3)) (3 (1 4) (3 5) (4 3)) (4 (1 1) (3 2) (4 3))) 10 20 3 :add-weight 3)) :point-radius 0 :style :fill) #| ;;another example with different mapping (list-plot ;;non-neutral-table (setq integers (gen-markov-from-transitions-with-tendency '((1 (1 1) (2 4) (3 1)) (2 (1 1) (4 1) (3 3) (6 1)) (3 (1 4) (3 5) (4 3) (6 1) (5 1)) (4 (1 1) (3 2) (4 3) (5 2) (6 1)) (5 (1 1) (3 1) (4 1)) (6 (2 3) (1 2) (3 1) (5 1))) 10 20 3 :add-weight 3)) :point-radius 0 :style :fill) (setq integers (replace-map '((5 -5) (1 0) (2 6) (3 14) (4 20) (6 25)) integers)) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;gen an example-score;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def-score example (:key-signature 'chromatic :time-signature '(4 8) :tempo '(e 176) :layout (bracket-group (piano-grand-layout 'piano))) (piano :omn (make-omn :pitch (eliminate-repetitions (integer-to-pitch integers)) :length (gen-length (count-repetitions integers) 1/32)) :sound 'gm-piano))

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)