Search the Community

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)

perhaps there's a OM-solution... in this case it's to hard to find... (search-engine?) otherwise... (defun integer-to-binary-lengths* (alist) (loop for i in alist when (> (abs i) 1) append (append (list 1) (loop repeat (- (abs i) 1) collect 0)) else collect 1)) (integer-to-binary-lengths* '(2 2 2 1 1 4 4 4 4)) (integer-to-binary-lengths* '(6 4 8 5 2 1 10 2))

could be interesting for you... an really extend gen-stacc-function greetings andré ;;; 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))))) ;(center-position-in-list '(1 2 3 4 x 4 3 2 1) :get-value nil) ;(center-position-in-list '(1 2 3 4 x 4 3 2 1) :get-value t) (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/2) '(3 4 5 3 2 1) :stacc-chance 0.5) ;(gen-stacc3 '(1/32 3/32) '(3/32 5/32 14/8) :stacc-chance 0.5) ;;; MAIN (defun gen-stacc* (liste &key (symmetrical 'nil) (stacc-chance 1) (possible-stacc-lengths 'nil) (no-center-stacc 'nil)) (let ((alist liste) (blist) (val) (n (/ 1 (find-max (mapcar 'denominator liste))))) (if (equal symmetrical 'nil) ;;bei unsymmetrischen strukturen (gen-stacc3 (if (equal possible-stacc-lengths 'nil) (list n) possible-stacc-lengths) liste :stacc-chance stacc-chance) ;;bei symmetrischen strukturen (if (evenp (length liste)) (progn (setf alist (gen-stacc3 (if (equal possible-stacc-lengths 'nil) (list n) possible-stacc-lengths) (filter-first (/ (length liste) 2) liste) :stacc-chance stacc-chance)) (setf blist (flatten (loop for i in (reverse (gen-divide 2 alist)) collect (reverse i)))) (append alist blist)) (progn (setf alist (gen-stacc3 (if (equal possible-stacc-lengths 'nil) (list n) possible-stacc-lengths) (filter-first (/ (1- (length liste)) 2) liste) :stacc-chance stacc-chance)) (setf blist (flatten (loop for i in (reverse (gen-divide 2 alist)) collect (reverse i)))) (append alist (if (equal no-center-stacc 't) (list (center-position-in-list liste :get-value t)) (progn (setf val (/ (center-position-in-list liste :get-value t) 3)) (list (* -1 val) val (* -1 val)))) blist)))))) ;; ordinario (gen-stacc* (gen-length '(4 5 6 3 6 5 4) 1/20)) ;; vorgebener stacc-wert (gen-stacc* '(4 5 6 3 6 5 4) :possible-stacc-lengths '(1/4)) ;; wählt rnd die längen der stacc-values (gen-stacc* '(4 5 6 3 6 5 4) :possible-stacc-lengths '(2/32 1/32 5/32 1/4)) ;; rnd-stacc (gen-stacc* (gen-length '(4 5 6 3 6 5 4) 1/32) :stacc-chance 0.4) ;; rnd-stacc mit verschiedenen möglichen stacc-lengths (gen-stacc* (gen-length '(4 5 6 3 6 5 4) 1/32) :stacc-chance 0.7 :possible-stacc-lengths '(2/32 1/32)) ;; symm-strukturen werden berücksichtigt (gen-stacc* (gen-length '(4 5 6 7 6 5 4) 1/32) :symmetrical t :no-center-stacc t) ;; ohne stacc bei center-value (gen-stacc* (gen-length '(4 5 6 7 6 5 4) 1/32) :symmetrical t :no-center-stacc 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))

a "rnd-pick" that works with different "input-formats"... so it's flexible to use... for many (not all) input-cases ;;; subfunction (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 rnd-pick* (alist) (if (and (listp (first alist)) (floatp (second (first alist)))) (weighted-random alist) (rnd-pick alist))) ;;; examples ;;; without weight (rnd-pick* '(1 2 3 4 5)) (rnd-pick* '((1 2 3 4) (3 4 5 7 3) (75 392 2))) ;;; with weight (rnd-pick* '((2 0.2) (3 0.4) (4 0.2))) (rnd-pick* '(((2 3 4 5) 0.2) ((8 796 5) 0.4))) (rnd-pick* '(((1 3) 0.2) (3 0.3)))

;;; SWAPS THE POSITIONS SYMMETRICALLY AND RANDOMIZED ;;; n => number of generations, output: last gen or all gens... ;;; new-version works also for symmetrical-sequences! (special cas) (defun rnd-symmetrical-position-swap (n liste &key (out 'all)) (let ((n1) (n2)) (progn (setf liste (loop repeat n do (setf n1 (random (1- (list-length-divide liste))) n2 (random (1- (list-length-divide liste)))) collect (progn (setf liste (position-swap (list (list n1 n2) (list (- (1- (length liste)) n1) (- (1- (length liste)) n2))) liste))))) (cond ((equal out 'last) (car (last liste))) ((equal out 'all) (append liste)))))) (rnd-symmetrical-position-swap 2 '(1 2 3 4 3 2 1) :out 'last) (rnd-symmetrical-position-swap 5 '(1 2 3 4 5 6) :out 'last) (rnd-symmetrical-position-swap 2 '(a b c d e f g h) :out 'all)

;;; ---------------------------------------------------------------- ;;; modifying proprtions by add/sub of the smallest/largest values ;;; number of elements is constant / sum of the seq also constant ;;; n => number of generations ;;; prop-list => integers ;;; :style => sharpen or flatten ;;; ---------------------------------------------------------------- (defun modify-proportions (n prop-list &key (style 'sharpen)) (let ((rest-pos (loop for i in prop-list for cnt = 0 then (incf cnt) when (< i 0) collect cnt)) (prop-list (abs! prop-list)) (liste)) (progn (setf liste (append (list prop-list) (loop repeat n when (or (= (length (find-above 1 prop-list)) 1) (= (length (find-unique prop-list)) 1)) collect prop-list else collect (setf prop-list (loop for i in prop-list for cnt = 0 then (incf cnt) collect (cond ((= cnt (position (find-closest 2 (find-above 1 prop-list)) prop-list)) (if (equal style 'sharpen) (1- i) (1+ i))) ((= cnt (position (find-max prop-list) prop-list)) (if (equal style 'sharpen) (1+ i) (1- i))) (t i))))))) (loop for i in liste collect (loop for k in i for cnt = 0 then (incf cnt) when (memberp cnt rest-pos) collect (* -1 k) else collect k))))) ;;; examples (modify-proportions 8 '(4 3 -2 7 3 2 7) :style 'sharpen) (modify-proportions 8 '(4 3 -2 7 3 2 7) :style 'flatten) (omn-to-time-signature (gen-length (modify-proportions 8 '(4 3 2 7) :style 'sharpen) 1/16) '(4 4)) (omn-to-time-signature (gen-length (modify-proportions 8 '(4 3 2 7) :style 'flatten) 1/16) '(4 4)) (list-plot (modify-proportions 10 '(5 3 2 -7 1 8 2)) :point-radius 0 :style :fill) ...works not in all CASES (when :style 'flatten), but okay...

;;; GETTING THE LENGTH-PROPORTIONS AS INTEGERS (defun get-proportions (omn_seq &key (abs 'nil)) (let ((denoms)) (progn (setf denoms (remove-duplicates (loop for i in (omn :length omn_seq) collect (denominator (abs i))))) (loop for i in (omn :length omn_seq) collect (if (equal abs 't) (* (abs i) (apply 'lcm denoms)) (* i (apply 'lcm denoms))))))) ;; examples (get-proportions '(-3q 3h_h. d3 mf)) (get-proportions '(5q 5q 5q 5q 5q -e -s t t -q)) (get-proportions '(5q 5q 5q 5q 5q -e -s t t -q) :abs t) (get-proportions '(-e -t t t t t t t t t -s. -q)) ;;; HOW TO USE (setf rhy '(-3h 3q_5h. 5q 5q c4)) (setf props (get-proportions rhy :abs nil)) ;;; you can use that for GEN-LENGTH-CONSTANT ;; ordinary (gen-length-constant props 'w.) ;; a bit advanced (gen-length-constant props 'h.) ;; crazy (gen-length-constant props 'h._e)

...an idea to manipulate lists of pitches/rhythms by "sampling" ;;; subfunction (defun sampling-list (liste start-position seq-length) (loop repeat seq-length for cnt = start-position then (incf cnt) when (= cnt (length liste)) do (setf cnt 0) collect (nth cnt liste))) ;;; MAIN: ;;; an value-list will be sampled by start-pos-list in the length of seq-length-list (defun structural-interferences (n value-list start-pos-list seq-length-list) (let ((start-pos-list (remove (length value-list) start-pos-list :test #'<))) (loop repeat n for start-pos = 0 then (incf start-pos) for seq-length = 0 then (incf seq-length) when (= start-pos (length start-pos-list)) do (setf start-pos 1) when (= seq-length (length seq-length-list)) do (setf seq-length 0) append (sampling-list value-list (nth start-pos start-pos-list) (nth seq-length seq-length-list))))) ;;something (list-plot (structural-interferences 21 '(1 2 3 4 5) '(0 1 2 3 4 5 6 7 8 9) '(1 3 2 4 1 2 2 3 1 1 1 1)) :point-radius 1 :style :fill) ;;"self-similar" (list-plot (structural-interferences 21 '(3 2 1 5 4 2) '(2 1 0 4 3 1) '(3 2 1 5 4 2)) :point-radius 1 :style :fill)

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)

if you want to augm/dim the LENGTH of a special technique... you could use that... or extend it... (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

here is a little "sketched" function STEP-TO-PITCH , perhaps OM could further develop the function... ;;; FUNCTION (defun step-to-pitch (&key steps pitches start) (let ((pos (car (position-item start pitches)))) (append (list (nth pos pitches)) (loop for i in steps ;; setting pos by add the step to pos do (setf pos (+ pos i)) ;; when pitch-range to small then reset to lowest pitch+step ;; could be a more intelligent solution when (> pos (length pitches)) do (setf pos (+ 0 i)) collect (nth pos pitches))))) ;;; EXAMPLES (step-to-pitch :steps '(1 1 -1 2 2 -1) :pitches '(c4 d4 e4 f4 g4 a4) :start 'c4) ;; => (c4 d4 e4 d4 f4 a4 g4) (step-to-pitch :steps '(1 1 -1 2 2 -1) :pitches (expand-tonality '(c4 chromatic)) :start 'c4) ;; => (c4 cs4 d4 cs4 ds4 f4 e4) (step-to-pitch :steps '(1 1 -1 2 2 -1 5) :pitches (expand-tonality '(c4 messiaen-mode6)) :start 'c4) ;; => (c4 d4 e4 d4 f4 gs4 fs4 gs4)

bad code-style, but modify/use it... ;;; FUNCTION ;;; expands (merges) length-values in the order of the substructure-list ;;; by inverting immediate following length-rests. ;;; (defun gen-legato-substructure (omn-list substructure-list) (loop repeat (length (single-events omn-list)) with event-list = (single-events omn-list) with sub-cnt = 0 for cnt = 0 then (incf cnt) when (and (equal (car (cond ((lengthp (car substructure-list)) (omn :length (nth cnt event-list))) ((pitchp (car substructure-list)) (omn :pitch (nth cnt event-list))) ((velocityp (car substructure-list)) (omn :velocity (nth cnt event-list))) ((articulationp (car substructure-list)) (omn :articulation (nth cnt event-list))))) (nth sub-cnt substructure-list)) (length-restp (car (nth (1+ cnt) event-list)))) collect (omn-replace :length (+ (car (omn :length (nth cnt event-list))) (abs (car (omn :length (nth (1+ cnt) event-list))))) (nth cnt event-list)) and do (incf cnt) and do (incf sub-cnt) else collect (nth cnt event-list) when (= sub-cnt (length substructure-list)) do (setf sub-cnt 0))) ;;; generating something like noise (setf mat (flatten (make-omn :pitch (loop repeat 100 collect (rnd-pick '(c4 d4 e4 f4 g4 a4 b4 c5))) :length (loop repeat 100 collect '(1/16 -13/16)) :velocity (loop repeat 100 collect (rnd-pick '(p mp mf f))) :articulation (loop repeat 100 collect (rnd-pick '(ord flaut ponte)))))) ;;; EXAMPLES: ;;; makes a "LEGATO" on this seq '(c4 d4 b4 f4) (setf omn (gen-legato-substructure mat '(c4 d4 b4 f4))) ;;; makes a "LEGATO" on this seq '(ponte ord flaut) ;(setf omn (gen-legato-substructure mat '(ponte ord flaut))) (def-score example (:title "example" :key-signature 'atonal :time-signature '(4 4) :tempo 90) (instr :omn omn :channel 1 :sound 'gm :program 'acoustic-grand-piano))

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

Hello i tried to have a function who could move one atom or a list anyplace in another list , but now i would like to have the options to move this atom or list with or without parenthesis , see option a option b option a2 option b2 . I have no idea how i can implement several result options in a function , could you please explain me how to do that Thank you Patrick her are the functions i'd use as helping functions (defun list-diff (L1 L2) (cond ((null L1) nil) ((null (member (first L1) L2)) (cons (first L1) (list-diff (rest L1) L2))) (t (list-diff (rest L1) L2)) ) ) (defun hasSublistp (lst) (cond ((null lst) nil) ((listp (first lst)) t) (t (hasSublistp (rest lst))))) This is the final one (defun consxp (rang item lis ) (setq oldlist lis) (setq newlist ( nthcdr rang oldlist )) (setq litem (list item)) (cond ( ( and ( listp item ) (hassublistp oldlist )) ; OPTION A (append (list-diff oldlist newlist ) (list item) (nthcdr rang oldlist ))) ; OPTION B (append (list-diff oldlist newlist ) item (nthcdr rang oldlist ))) (( and ( atom item ) (hassublistp oldlist )) ; OPTION A2 (append (list-diff oldlist newlist ) (cons (list item) (nthcdr rang oldlist )))) ; OPTION B2 (append (list-diff oldlist newlist ) (cons item (nthcdr rang oldlist )))) (( listp item ) (append (list-diff oldlist newlist ) item (nthcdr rang oldlist ))) (( atom item ) (append (list-diff oldlist newlist ) (cons item (nthcdr rang oldlist )))))) ; ( consxp 2 '( a d a) '(a (d) c )) option a ) for example

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; LENGTH-REST-RATIO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; to TEST in a OMN- or LENGTH-sequence (defun length-rest-ratio (seq) (let ((liste (omn :length seq))) (loop for i in liste when (< i 0) sum (abs i) into -bag when (> i 0) sum i into +bag finally (return (ratio-to-float (* +bag (/ 1 (+ +bag -bag)))))))) (length-rest-ratio '(e. q. -q)) (length-rest-ratio '(-2 3 4 -1 -1)) (length-rest-ratio '(e. c4 ppp -q. q d3 e3 f3)) ;;; evaluate this test a few times (if (> (length-rest-ratio (rnd-repeat 10 '(1 2 3 4 -1 -2 -3 -4))) 0.5) (append 'more-lengths) (append 'more-rests))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; i needed a function who changes randomly lengths to rests ;;; step by step, and modify (enlarge) its rest-values over x-generations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun modify-lengths-to-rests (liste &key (items 1) (step -1) (factor 2) (enlarge-type 'add)) (let ((liste (loop for j in liste when (< j 0) collect (cond ((equal enlarge-type 'add) (+ step j)) ((equal enlarge-type 'augmented) (* factor j))) else collect j))) (loop for i in liste with repl = (rnd-pick (remove 0 liste :test #'>)) with cnt = 0 when (and (equal i repl) (< cnt items)) collect (* -1 (abs repl)) and do (incf cnt) else collect i))) ;;;; examples-1 -> ONE generation ;;;; evaluate a few times to see how it works (modify-lengths-to-rests '(1 1 1 2 2 2 3 3 3 4 4 4 -5 5 5) :items 1 :enlarge-type 'add) ;enlarge only values < 0 (modify-lengths-to-rests '(1 1 1 2 2 2 3 3 3 4 4 4 -5 5 5) :items 2 :enlarge-type 'add) ;enlarge only values < 0 (modify-lengths-to-rests '(1 1 1 2 2 2 3 3 3 4 4 4 -5 5 5) :items 3 :enlarge-type 'add) ;enlarge only values < 0 ;;;; examples-2 ;;;; recursiv - with x-generations (loop repeat 10 with seq = '(1 2 3 4 4 4 5 6 7) collect (setf seq (modify-lengths-to-rests seq :items 1 :enlarge-type 'augmented))) (loop repeat 10 with seq = '(1 2 3 4 4 4 5 6 7) collect (setf seq (modify-lengths-to-rests seq :items 1 :enlarge-type 'add)))

don't know if this already exists in the library ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; chord-multiplication like boulez ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun chord-multiplication (chord1 chord2 &key (chord 'nil)) (let ((liste (sort-asc (remove-duplicates (loop for i in chord1 append (pitch-transpose-start i chord2)))))) (if (equal chord 't) (chordize liste) (append liste)))) (defun all-chord-multiplications (liste &key (chord 'nil)) (let ((liste (loop for i in (combination 2 liste) collect (chord-multiplication (first i) (second i))))) (if (equal chord 't) (chordize liste) (append liste)))) ;;; EXAMPLES ;;; with 2 chords (chord-multiplication '(eb4 a4 d5) '(ab4 g5) :chord 't) ;;; all possible multiplications (combinations of 2) in a diveded list (setf divided-list '((eb4 a4 d5) (ab4 g5) (e4 gs4 db4) (b3 f4 bb4 c5))) (all-chord-multiplications divided-list :chord 't) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; A WAY TO MUTATE/MODIFY A PROPORTION-LIST FOR "gen-length-constant" ;;;; the SUM in all generations is CONSTANT ;;;; FUNCTION (defun modify-prop-seq (generations values &key (value-step 1) (chance 1.0)) (append (list values) (loop repeat (- generations 1) with rnd-seq with new-seq do (if (prob? chance) (setq rnd-seq (rnd-sample-seq 2 values) new-seq (list (+ (car rnd-seq) value-step) (- (car (rest rnd-seq)) value-step)) values (loop for i in (pattern-map (list (append (list rnd-seq) (list new-seq))) values) when (> i 0) collect i)) (append values)) collect values))) ;;;; tests (modify-prop-seq 5 '(1 2 3 4 5 6 7 8 9)) (modify-prop-seq 5 '(2 1 8 5 1 3) :value-step 1 :chance 0.9) (modify-prop-seq 5 '(4 4 4 4 4) :value-step 1 :chance 0.5) ;;;; practical-use -> every generation in 1 bar (loop for i in (modify-prop-seq 5 '(2 1 8 5 1 3) :value-step 1 :chance 0.8) collect (gen-length-constant i '4/4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; function (-> don't know if this is already existing in opusmodus) (defun expand-intervals/integers (seq &key (type 'add) (value 1)) (cond ((equal type 'add) (loop for i in seq when (> i 0) collect (+ i value) when (< i 0) collect (- i value) when (= i 0) collect i)) ((equal type 'multiply) (loop for i in seq collect (* i value))) ((equal type 'expt) (loop for i in seq when (>= i 0) collect (expt i value) else collect (* (expt i value) -1))) ((equal type 'fibonacci) (loop for i in seq when (>= i 0) collect (+ i (fibonacci i)) else collect (- i (fibonacci (abs i))))))) ;;; examples (expand-intervals/integers '(0 -1 1 -2 2 -3 3) :type 'add :value 2) (expand-intervals/integers '(0 -1 1 -2 2 -3 3) :type 'multiply :value 2) (expand-intervals/integers '(0 -1 1 -2 2 -3 3) :type 'expt :value 2) (expand-intervals/integers '(0 -1 1 -2 2 -3 3 -4 4 -5 5) :type 'fibonacci)