AM

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

(defun testp (n1 n2 &key (test '=)) (progn (cond ((pitchp n1) (setf n1 (pitch-to-midi n1) n2 (pitch-to-midi n2))) ((velocityp n1) (setf n1 (get-velocity n1) n2 (get-velocity n2)))) (eval (list test n1 n2)))) (testp 'cs4 'd4 :test '<) (testp 'cs4 'd4 :test '/=) (testp 'cs4 'cs4 :test '=) (testp 'mp 'mf :test '<) (testp 12 13 :test '=)

nice, but didn't found this function in the library, so you has to code...

when i evaluate this: (setf pianomainHarm (tonality-map (append (gen-repeat 4 '((scale2))) (gen-repeat 4 '((scale1))) (gen-repeat 4 '((scale3))) ) pianomain)) Error: > Error: scale2 is not a tonality or a chord. > While executing: make-tonality, in process Listener-1(6). > Type cmd-. to abort, cmd-\ for a list of available restarts. > Type :? for other options. so, take a look what is your scale2 etc or it's in YOUR library, so i can't test YOUR score/code

i have to learn more about lisp :-)

(apply #'mapcar #'(lambda (&rest all) all) lists)) this is really cool! :-)

;;; in "pure lisp" with NIL when lists have not the same length (defun trans* (lists) (loop repeat (car (last (sort-asc (mapcar 'length lists)))) for cnt = 0 then (incf cnt) collect (loop for i in lists collect (nth cnt i)))) (trans* '((1 2 3 4) (a b c d) (11 12 13 14) (k l m n))) (trans* '((1 2 3 4) (a b c d e) (11 12 13 14 14 16) (k l m n o p q r s t))) (trans* '((1 2 3 4) (a b c d e) (11 12 13 14) (k l m n r s t)))

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)

new version, for LISTS with different-lengths => compensated ;;; SUB (defun compensate-list-lengths (somelists &key (value 0)) (let ((maxlength (find-max (mapcar 'length somelists)))) (loop for i in somelists when (< (length i) maxlength) collect (append i (loop repeat (- maxlength (length i)) collect value)) else collect i))) ;;; MAIN (defun sum-list-items (somelists &key (each-step nil)) (let ((somelists (compensate-list-lengths somelists)) (lista (car somelists)) (firstlist (car somelists))) (progn (setf somelists (loop for x in (rest somelists) collect (setf lista (loop for i in lista for j in x collect (+ i j))))) (if (equal each-step t) (append (list firstlist) somelists) (car (last somelists)))))) ;;; (sum-list-items '((1 0 4 4 4 4 4 4 0 1) (81 0 0 0) (0 0 1 1 99 200))) => (82 0 5 5 103 204 4 4 0 1)

it's not decimal-to-binary!!! another idea... for example... 6 => 1 0 0 0 0 0 = a "1" and 5 times a "0")

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

i think a different idea!? in my code: sum first item of all lists sum second... sum third... ... but perhaps i'm wrong

very simple, i used something like this for my work... but is there somthing like this in OM? greetings andré (defun sum-list-items* (somelists &key (each-step nil)) (let ((lista (car somelists)) (firstlist (car somelists))) (progn (setf somelists (loop for x in (rest somelists) collect (setf lista (loop for i in lista for j in x collect (+ i j))))) (if (equal each-step t) (append (list firstlist) somelists) (car (last somelists)))))) (sum-list-items* '((1 0 0 1) (1 0 0 0) (0 0 1 1))) (sum-list-items* '((1 0 0 1) (1 0 0 0) (0 0 1 1)) :each-step t) (sum-list-items* '((1 0 8 1) (2 0 0 0) (0 -1 3 1))) (sum-list-items* '((1 0 8 1) (2 0 0 0) (0 -1 3 1)) :each-step t)

here's an example of the combination of gen-symmetrical* + gen-stacc* (length-list-plot (gen-stacc* (gen-length (gen-symmetrical* 8 (reverse (gen-divide 3 (primes 12))) :style 'unique :type 'hierarchic) 1/32) :symmetrical t :possible-stacc-lengths '(2/32 1/32 3/32)))

some extensions to the basic function... greetings andré ;;; SUB (defun rnd-pick* (alist) (if (and (listp (first alist)) (floatp (second (first alist)))) (weighted-random alist) (rnd-pick alist))) (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))) ;;; MAIN (defun gen-symmetrical* (n list &key (type 'nil)) (if (equal type 'hierarchic) (progn (let ((alist (butlast list)) (center (last list))) (if (> n (* 2 (length list))) 'list-has-too-few-items (if (evenp n) (progn (setf alist (loop repeat (/ n 2) for i in alist collect (rnd-pick* i))) (append alist (reverse alist))) (progn (setf alist (loop repeat (/ (1- n) 2) for i in alist collect (rnd-pick* i))) (append alist (list (rnd-pick* (flatten center))) (reverse alist))))))) (progn (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))))))))) ;;ordinario (gen-symmetrical* 5 '(1 2 3 4 5 6 7 8)) ;;unmittelbare wiederholungen möglich (gen-symmetrical* 9 '(1 2 3 4 5 6 7 8) :repeat t) ;;werte kommen nur doppelt vor durch die symmetrie- ;;bildung, aber nicht auf einer der symmetrieseiten. (gen-symmetrical* 9 '(1 2 3 4 5 6 7 8) :style 'unique) (gen-symmetrical* 30 '(1 2 3 4 5 6 7 8) :style 'unique) ;;=> list-has-too-few-items ;;bei ":type 'hierarchic" wird immer zuerst aus der ;;ersten sublist ausgewählt, dann aus der zweiten etc... (gen-symmetrical* 6 '((a b c) (6 7) (8 9) (10 11)) :style 'unique :type 'hierarchic) ;;auch mit weight möglich (gen-symmetrical* 5 '(((1 0.2) (2 0.8)) ((4 0.1) (5 0.9)) (6 7) (8 9) (10 11)) :style 'unique :type 'hierarchic)

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

you are right, but it is okay for my use - if someone wants to make it smarter, it is very welcome - but I have to do some other things :-)

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

THANX!!! andré

perhaps something like that? only a sketch... modify it... don't work in all cases... ;;; SUBFUNCTIONS ;;; TAKES A GIVEN TONAILTY AND EXPAND IT FOR X OCTAVES (defun multiple-expand-tonality (&key startpitch octaves tonality) (remove-duplicates (loop repeat octaves with pitch = startpitch with cnt = 0 when (= cnt (length tonality)) do (setq cnt 0) append (expand-tonality (list pitch (nth cnt tonality))) do (incf cnt) do (setq pitch (car (pitch-transpose 12 (list pitch))))))) ;;; EXPAND A TONALITY BY STEPS -> in a sense of schillinger? (defun tonality-with-scale-expansion (tonality expansion-nr) (let ((expansion (nth expansion-nr '(0 1 2 3 4 5 6)))) (reading-list-by-steps :steps (gen-repeat 53 expansion) :values (multiple-expand-tonality :startpitch 'c0 :octaves 8 :tonality (list tonality)) :start 'c0))) ;;; READS THE PITCHSEQUQNZ IN A TONALITY NOT AS INTERVALS , READS IT AS STEPS (IN A GIVEN PITCHFIELD) (defun get-steps (tonality pitches) (let ((tonality-space (multiple-expand-tonality :startpitch 'c0 :octaves 8 :tonality (list tonality)))) (difference (loop for i in pitches append (position-item i tonality-space))))) ;;; READS A LIST NY STEPS AND NOT BY INTERVALS -> USEFULL WHEN WORKING WITH PITCHFIELDS ;;; ALSO AVAILABLE IN TONALITY-MAP!!! (defun reading-list-by-steps (&key steps values start) (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))))) ;;; filter-pitches-octave-independent (defun filter-pitches-octave-independent (pitches filter-pitch &key (bandwith 10)) (let ((search-field (loop for j in filter-pitch append (append (reverse (loop repeat (/ bandwith 2) with p1 = (pitch-to-midi j) collect (setq p1 (- p1 12)))) (list (pitch-to-midi j)) (loop repeat (/ bandwith 2) with p2 = (pitch-to-midi j) collect (setq p2 (+ p2 12))))))) (loop for i in (pitch-to-midi pitches) when (not (null (member i search-field))) collect (midi-to-pitch i)))) ;;; MAIN_FUNCTION --------------------------------------------------------------------------------------------------------------------- (defun expand-melody (expansion-nr tonality melody) (let ((start-pitch (nth expansion-nr (expand-tonality (list 'c4 (car (list tonality)))))) (new-tonality (tonality-with-scale-expansion tonality expansion-nr))) (pitch-transpose-start start-pitch (reading-list-by-steps :steps (get-steps 'major melody) :values new-tonality :start (car (filter-pitches-octave-independent new-tonality (list start-pitch))))))) (expand-melody 1 'major '(c4 f4 e4 f4 g4 a4)) (expand-melody 2 'major '(c4 f4 e4 f4 g4 a4)) (expand-melody 3 'major '(c4 f4 e4 f4 g4 a4)) (expand-melody 4 'major '(c4 f4 e4 f4 g4 a4))

is it possible to do such a (nonsense-function) with mapcar (then with loop)? -> how should i handle the &key (y 1) with mapcar? possible? a function without &key is clear but with &key ....??? thanx for a note (defun testfu (value &key (y 1)) (* (random 10) value y)) (loop for i in '(1 2 3 4 5) for j in '(1 2 3 4 5) collect (testfu i :y j))