AM

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;gen-chained-sym-vals.by-markov;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; special-symm-sequences ;;; have look at the possible parameters (&key) ;;; it's generates symm-structures via MARKOV ;;; and the could be "chained" between generations ;;; also with symm.structures... like: (also look at CARTER's work) ;;; => ((1 2 5 8 5 2 1) (3 1 2 2 2 1 3) (8 1 3 1 8) (3 1 2 2 2 1 3) (1 2 5 8 5 2 1)) ;;; chains: 2 1 3 1 2 2 1 3 1 2 ;;; or: ;;; => ((e4 f4 c4 e4 d4 e4 c4 f4 e4) (c4 e4 f4 c4 fs4 c4 f4 e4 c4) (e4 fs4 f4 fs4 e4) (c4 e4 f4 c4 fs4 c4 f4 e4 c4) (e4 f4 c4 e4 d4... ;;; chains: c4 f4 e4 c4 e4 f4 c4 e4 c4 e4 e4 c4 e4 ........etc....... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; main function with amateur-code :-) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun gen-chained-sym-vals.by-markov (&key (generations 'nil) (non-symmetric 'nil) (number-of-vals 20) (basic-seq-lengths '(3 5)) (transition-matrix '((1 (4 1) (5 1) (6 2)) (2 (5 2) (4 1)) (3 (4 1)) (4 (5 1) (2 1)) (5 (1 3) (6 2) (4 1)) (6 (4 1)) (7 (1 1) (6 1)))) (chain-weight 1.0) (possible-chain-length '(1 2 3)) (reduction 0.0) (start-value (car (car transition-matrix)))) (let ((sequence1 0) (sequence2 0) (seq-lengths basic-seq-lengths)) (setq sequence1 (loop repeat (if (equal generations 'nil) (car (list number-of-vals)) (if (equal non-symmetric 'nil) (if (evenp generations) (/ generations 2) (/ (1- generations) 2)) (car (list generations)))) with seq1 with seq with chain1 with slot = (second (gen-markov-from-transitions transition-matrix :size 2 :start start-value)) with seq-splitter = (gen-markov-from-transitions transition-matrix :size (rnd-pick possible-chain-length) :start slot) with seq-lengths = basic-seq-lengths when (equal (prob? chain-weight) 't) do (setq chain1 (append (list (setq slot (second (gen-markov-from-transitions transition-matrix :size 2 :start slot)))) seq-splitter (list (setq slot (second (gen-markov-from-transitions transition-matrix :size 2 :start slot)))))) and do (setq seq (append (butlast chain1) (reverse chain1))) and collect (if (equal (prob? reduction) 't) (append (setq seq (butlast (rest seq)))) (append seq)) else collect (setq seq1 (gen-markov-from-transitions transition-matrix :size (rnd-pick seq-lengths) :start slot) seq (append seq1 (reverse seq1))) do (setq seq-splitter (reverse (filter-last (rnd-pick possible-chain-length) seq))))) (if (equal generations 'nil) (progn (setq sequence2 (filter-first (if (evenp number-of-vals) (/ number-of-vals 2) (/ (1- number-of-vals) 2)) (flatten sequence1))) (if (evenp number-of-vals) (append sequence2 (reverse sequence2)) (append sequence2 (list (rnd-pick (flatten (filter-first 1 transition-matrix)))) (reverse sequence2)))) (if (equal non-symmetric 'nil) (if (evenp generations) (append sequence1 (reverse sequence1)) (append sequence1 (list (gen-sym-markov :seq-length (rnd-pick seq-lengths) :transition-matrix transition-matrix)) (reverse sequence1))) (append sequence1))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; test it! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (gen-chained-sym-vals.by-markov :generations 5 :transition-matrix '((1 (2 1) (3 3) (5 2) (8 1)) (2 (1 2) (5 3)) (3 (1 2) (8 1) (2 3)) (5 (3 2) (2 1) (1 3)) (8 (1 2) (2 2) (3 1)))) (gen-chained-sym-vals.by-markov :generations 5 :transition-matrix '((c4 (d4 1) (e4 3) (f4 2) (fs4 1)) (d4 (c4 2) (f4 3)) (e4 (c4 2) (fs4 1) (d4 3)) (f4 (e4 2) (d4 1) (c4 3)) (fs4 (c4 2) (d4 2) (e4 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;gen-chained-sym-vals.by-markov;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; special-symm-sequences ;;; have look at the possible parameters (&key) ;;; it's generates symm-structures via MARKOV ;;; and the could be "chained" between generations ;;; also with symm.structures... like: (also look at CARTER's work) ;;; => ((1 2 5 8 5 2 1) (3 1 2 2 2 1 3) (8 1 3 1 8) (3 1 2 2 2 1 3) (1 2 5 8 5 2 1)) ;;; chains: 2 1 3 1 2 2 1 3 1 2 ;;; or: ;;; => ((e4 f4 c4 e4 d4 e4 c4 f4 e4) (c4 e4 f4 c4 fs4 c4 f4 e4 c4) (e4 fs4 f4 fs4 e4) (c4 e4 f4 c4 fs4 c4 f4 e4 c4) (e4 f4 c4 e4 d4... ;;; chains: c4 f4 e4 c4 e4 f4 c4 e4 c4 e4 e4 c4 e4 ........etc....... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; main function with amateur-code :-) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun gen-chained-sym-vals.by-markov (&key (generations 'nil) (non-symmetric 'nil) (number-of-vals 20) (basic-seq-lengths '(3 5)) (transition-matrix '((1 (4 1) (5 1) (6 2)) (2 (5 2) (4 1)) (3 (4 1)) (4 (5 1) (2 1)) (5 (1 3) (6 2) (4 1)) (6 (4 1)) (7 (1 1) (6 1)))) (chain-weight 1.0) (possible-chain-length '(1 2 3)) (reduction 0.0) (start-value (car (car transition-matrix)))) (let ((sequence1 0) (sequence2 0) (seq-lengths basic-seq-lengths)) (setq sequence1 (loop repeat (if (equal generations 'nil) (car (list number-of-vals)) (if (equal non-symmetric 'nil) (if (evenp generations) (/ generations 2) (/ (1- generations) 2)) (car (list generations)))) with seq1 with seq with chain1 with slot = (second (gen-markov-from-transitions transition-matrix :size 2 :start start-value)) with seq-splitter = (gen-markov-from-transitions transition-matrix :size (rnd-pick possible-chain-length) :start slot) with seq-lengths = basic-seq-lengths when (equal (prob? chain-weight) 't) do (setq chain1 (append (list (setq slot (second (gen-markov-from-transitions transition-matrix :size 2 :start slot)))) seq-splitter (list (setq slot (second (gen-markov-from-transitions transition-matrix :size 2 :start slot)))))) and do (setq seq (append (butlast chain1) (reverse chain1))) and collect (if (equal (prob? reduction) 't) (append (setq seq (butlast (rest seq)))) (append seq)) else collect (setq seq1 (gen-markov-from-transitions transition-matrix :size (rnd-pick seq-lengths) :start slot) seq (append seq1 (reverse seq1))) do (setq seq-splitter (reverse (filter-last (rnd-pick possible-chain-length) seq))))) (if (equal generations 'nil) (progn (setq sequence2 (filter-first (if (evenp number-of-vals) (/ number-of-vals 2) (/ (1- number-of-vals) 2)) (flatten sequence1))) (if (evenp number-of-vals) (append sequence2 (reverse sequence2)) (append sequence2 (list (rnd-pick (flatten (filter-first 1 transition-matrix)))) (reverse sequence2)))) (if (equal non-symmetric 'nil) (if (evenp generations) (append sequence1 (reverse sequence1)) (append sequence1 (list (gen-sym-markov :seq-length (rnd-pick seq-lengths) :transition-matrix transition-matrix)) (reverse sequence1))) (append sequence1))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; test it! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (gen-chained-sym-vals.by-markov :generations 5 :transition-matrix '((1 (2 1) (3 3) (5 2) (8 1)) (2 (1 2) (5 3)) (3 (1 2) (8 1) (2 3)) (5 (3 2) (2 1) (1 3)) (8 (1 2) (2 2) (3 1)))) (gen-chained-sym-vals.by-markov :generations 5 :transition-matrix '((c4 (d4 1) (e4 3) (f4 2) (fs4 1)) (d4 (c4 2) (f4 3)) (e4 (c4 2) (fs4 1) (d4 3)) (f4 (e4 2) (d4 1) (c4 3)) (fs4 (c4 2) (d4 2) (e4 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;  

New:
Improvement to tuplet brackets placement. MUSICXML-TO-EDITOR function.  
musicxml-to-editor file-name &key application identifier
 
[Function]
 
Arguments and Values:
 
file-name                 a string.
application            a string. The default is "Sibelius".
identifier               a string.
 
Description:
 
The MUSICXML-TO-EDITOR function opens musicxml score files in any musicxml editor, like Sibelius, Finale etc...
 
Examples:
 
First, you need to create a musicxml file from your score:
 
(compile-score 'file-name :output :musicxml :file "file-name")
 
Next:
 
(musicxml-to-editor "file-name")
 
To open the file in Finale:
 
(musicxml-to-editor "file-name" :application "Finale")
 
If the application name is not working you can use the identifier keyword with the bundle-identifier.
For example the Sibelius 7.5 version identifier is "com.avid.Sibelius75"
 
(musicxml-to-editor "file-name" :identifier "com.avid.Sibelius75")
 
 

Next week I will show you how to do all this in Opusmodus with build in functions especially for omn plists manipulation.

;;;function which replaces/rewrites the component in OMN-seq (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 (pitchp (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)))) (setf seq1 '(s gs3 ppp tasto q.t cs4 pppp tasto s f4 ppp tasto)) (omn-component-replace seq1 '(5/16 7/16 3/32))  

With SEED:
(defun rnd-division (n &key (sum 1.0) seed) (do-verbose ("rnd-division") (rnd-seed seed) (let ((values (loop repeat (- n 1) with a = sum with b collect (setf b (random* a :seed (seed))) do (setf a (- a b))))) (append values (list (- sum (sum values))))))) (rnd-division 5 :seed 5) => (0.0052785673 0.09165209 0.06036401 0.65849 0.1842153) (rnd-division 3 :sum 9.8 :seed 87) => (3.9023237 0.8761092 5.0215673)  
To add seed to the function use RANDOM* OM function.

Ambient soundtrack, thanks to gen-controller function for the algorithmic parameters automation ;-)

 
SB.

Will be part of the next update.

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

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

Final name and functionality:
(gen-transform '(0 0 0 0 0 0 0 0 0 0) :interval '(4 12 7) :prob 0.5) (gen-transform '(1/4 1/4 1/4 1/4 1/4) :interval '(-1/32 1/32) :prob 0.5) (gen-transform '(c1 c2 c3 c4 c5 c6) :interval '(1 -1) :prob 0.7) (gen-transform '((c1 c2 c3) (c4 c5 c6)) :interval '(1 -1) :prob 0.7) (gen-transform '((c1 c2 c3) (c4 c5 c6)) :interval '((1 -1) (-13 11)) :prob '(0.7 0.8))  

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)  

There is no error. The GEN-RATOTE is not working with OMN form list now.
What you see above is what you will get with the next update.
Here, the function is working fine already. 

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)  

Hi, 
 
new piece, Quartet with piano.
 

 
Stéphane.
 

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)  

Final function:
(defun modify-time-signature (time-signature &key compress (exclude '((0 0))) (span '10/4) (numerator 20)) (do-verbose ("modify-time-signature") (let ((ts (if compress (compress-time-signatures time-signature) time-signature))) (loop for i in ts when (and (> (third i) 1) (< (/ (first i) (second i)) span) (< (* (first i) (third i)) numerator) (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) (1 4 4) (1 4 4) (1 4 4) (3 4 2) (1 8 19) (1 32 8) (1 8 5) (1 8 5))) (modify-time-signature bars) => ((5 4 4) (2 4 1) (4 4 1) (4 4 1) (4 4 1) (6 4 1) (19 8 1) (8 32 1) (5 8 1) (5 8 1)) (modify-time-signature bars :compress t) => ((5 4 4) (14 4 1) (6 4 1) (19 8 1) (8 32 1) (10 8 1)) (modify-time-signature bars :exclude '(1 4)) => ((5 4 4) (1 4 2) (1 4 4) (1 4 4) (1 4 4) (6 4 1) (19 8 1) (8 32 1) (5 8 1) (5 8 1)) (modify-time-signature bars :exclude '((1 4) (1 8)) :compress t) => ((5 4 4) (1 4 14) (6 4 1) (1 8 19) (8 32 1) (1 8 10)) (modify-time-signature bars :exclude '((1 32)) :span '4/4) => ((5 4 4) (2 4 1) (4 4 1) (4 4 1) (4 4 1) (6 4 1) (19 8 1) (1 32 8) (5 8 1) (5 8 1)) (modify-time-signature bars :numerator 7) => ((5 4 4) (2 4 1) (4 4 1) (4 4 1) (4 4 1) (6 4 1) (1 8 19) (1 32 8) (5 8 1) (5 8 1)) |#  

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

Here is my solution:
;; ----------------------------------------------------------------------- ;; length-round ;; ----------------------------------------------------------------------- (defun find-length-base (length base) (prog (out i) (setf out nil) (setf i base) loop (cond ((not (null out)) (return out))) (setf out (if (<= length base) base)) (setf base (+ i base)) (go loop))) (defun length-round (sequence &key (round 1/4) section exclude) (do-verbose ("length-round") (labels ((length-round-1 (length round) (let ((out (- (find-length-base length round) length))) (list length (if (minusp length) (abs out) (neg! out))))) (length-round-l (list round) (flatten (loop for i in list collect (length-round-1 i round)))) (length-round-ls (list round) (let* ((len (length list)) (round (gen-trim* len (list! round)))) (loop for i in list for x in round collect (length-round-l i x)))) (length-round* (list round) (if (listsp list) (length-round-ls list round) (length-round-l list round)))) (let ((len (length sequence))) (if exclude (maybe-section (lambda (x) (length-round* x round)) sequence (num-exclude len exclude)) (maybe-section (lambda (x) (length-round* x round)) sequence section)))))) (length-round '(1/16 -1/16 2/32 5/7 4/20 6/20 3/20 5/16)) => (1/16 -3/16 -1/16 5/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) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round 1/8) => ((1/16 -1/16 -1/16 3/16 1/16 -1/16 5/7 -1/28) (1/5 -1/20 3/10 -3/40 3/20 -1/10 5/16 -1/16)) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8 1/4)) => ((1/16 -1/16 -1/16 3/16 1/16 -1/16 5/7 -1/28) (1/5 -1/20 3/10 -1/5 3/20 -1/10 5/16 -3/16)) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8) :section 0) => ((1/16 -1/16 -1/16 3/16 1/16 -1/16 5/7 -1/28) (1/5 3/10 3/20 5/16)) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8) :exclude 0) => ((1/16 -1/16 1/16 5/7) (1/5 -1/20 3/10 -3/40 3/20 -1/10 5/16 -1/16))  

;;; Example, you generate binary (setf bin (gen-binary-euclidean 2 12 1 9)) =>((1 0 0 0 0 0 1 0 0 0 0 0) (1 0 1 1 1 0 1 1 1 0 1 1)) ;;; You map the binary to length (setf bmap (binary-map bin 's)) =>((1/16 -1/16 -1/16 -1/16 -1/16 -1/16 1/16 -1/16 -1/16 -1/16 -1/16 -1/16) (1/16 -1/16 1/16 1/16 1/16 -1/16 1/16 1/16 1/16 -1/16 1/16 1/16)) ;;; lot of rest ;;; with length reduce you will apply a kind ;;; of "legato effect" , no rest, only length to length: (setf final (length-reduce bmap)) =>((3/8 3/8) (1/8 1/16 1/16 1/8 1/16 1/16 1/8 1/16 1/16)) It is a quick example just for give you the general idea...
 
SB.

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

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)  

now edited!

;;; little markov-game: ;;; gen-markov => analyze the output => produce new rules => gen-markov ;;; make x-times the list-plot and you will see how the system most of the times ;;; comes to a "constant STATE" (defun self-analyzing/generating-markov (transitions size generations) (loop repeat generations with list = (gen-markov-from-transitions transitions :size size :start 1) append (setq list (gen-markov-from-transitions (gen-markov-transitions list) :size size :start (car (last list)))))) ;;; a "neutral table with 4 values" (setf transition-table '((1 (1 1) (2 1) (3 1) (4 1)) (2 (1 1) (2 1) (3 1) (4 1)) (3 (1 1) (2 1) (3 1) (4 1)) (3 (1 1) (2 1) (3 1) (4 1)) (4 (1 1) (2 1) (3 1) (4 1)))) ;;; evaluate a few times and have a look on the output (list-plot (self-analyzing/generating-markov transition-table 20 20) :point-radius 0 :style :fill)