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  

Thank you André.
 
I've made that based on you code for replace pitch on technique:
 
;;; REPLACE-PITCH-OF-A-TECHNIQUE ;;; Based on code from AM. (replace-velocity-of-a-technique) (defun replace-pitch-of-a-technique (omn-list &key technique pitch) (flatten (loop for i in (single-events omn-list) when (equal (nth 3 i) technique) collect `(,(nth 0 i) ,(rnd-pick pitch) ,(nth 2 i) ,(nth 3 i)) else collect i))) (replace-pitch-of-a-technique '(e. c4 p tasto d4 ponte e4) :technique 'tasto :pitch '(g6)) (replace-pitch-of-a-technique '(e. c4 p tasto d4 ponte e4 d4 tasto f5 tasto) :technique 'tasto :pitch '(g4 e5 a6)) S.

(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 '=)  

For generating a harmonic rhythm, I needed to merge notes that are tied. If extracting only the length values with omn directly, then all ties are lost.
 
 (omn :length '((h c4 pizz q arco+tie) (q h tie) (h.)))
 => ((1/2 1/4) (1/4 1/2) (3/4))
 
So, I wrote myself a function that merges the lengths of tied notes.
 
 (lengths-with-merged-ties '((h c4 pizz q arco+tie) (q h tie) (h.)))
 => (1/2 1/2 5/4)
 
 
The definition is below.
 
Best,
Torsten
 
(defun lengths-with-merged-ties (sequence) "Returns a flat list of lengths that preserves the lengths in sequence including their tied notes. Example: (lengths-with-merged-ties '((h c4 pizz q arco+tie) (q h tie) (h.))) => (1/2 1/2 5/4) Contrast: (omn :length '((h c4 pizz q arco+tie) (q h tie) (h.))) => ((1/2 1/4) (1/4 1/2) (3/4))" (butlast (reduce #'(lambda (&optional accum pair2) (when (and accum pair2) (append (butlast accum 2) (if (equal (first (last accum)) 'tie) (list (+ (first (last (butlast accum))) (first pair2)) (second pair2)) (list (first (last (butlast accum))) (first pair2) (second pair2))) ))) (matrix-transpose (list (omn :length (flatten-omn sequence)) (mapcar #'(lambda (arts) (when (member 'tie arts) 'tie)) (mapcar #'disassemble-articulations (omn :articulation (flatten-omn sequence))))))))) ;; I shared the function disassemble-articulations alongside similar functions before, ;; but repeat it here for your convenience (defun disassemble-articulations (art) "Splits a combined OMN articulations into a list of its individual attributes. Example: (disassemble-articulations 'leg+ponte) => (leg ponte)" (mapcar #'intern (split-string (symbol-name art) :separator "+")))  

(apply #'mapcar #'list '((1 3 5) (2 4 6)))  

Here is another approach to implement the same thing, but a but more concisely in just one line (most of the code below is the documentation :)
(defun mat-trans (lists)   "Matrix transformation.    (mat-trans '((a1 a2 a3) (b1 b2 b3) (c1 c2 c3) ...))    => ((a1 b1 c1 ...) (a2 b2 c2 ...) (a3 b3 c3 ...))"   (apply #'mapcar #'(lambda (&rest all) all) lists))  

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)  

I've made this long time ago, bit different but may be also of interest, this function use a specs of number of "1" and "0" in input:
 
;;; GEN-BINARY_INTEGER (defun gen-binary-integer (one-list zero-list &key (flatten t)) (do-verbose ("gen-binary-integer") (if flatten (flatten (loop for i in one-list for o in (gen-trim (length one-list) zero-list) collect (append (gen-repeat i '(1)) (gen-repeat o '(0)) ))) (loop for i in one-list for o in (gen-trim (length one-list) zero-list) collect (append (gen-repeat i '(1)) (gen-repeat o '(0)) ))))) #| USAGE (gen-binary-integer '(3 4 3 2 4 2 5) '(1 1 3)) => (1 1 1 0 1 1 1 1 0 1 1 1 0 0 0 1 1 0 1 1 1 1 0 1 1 0 0 0 1 1 1 1 1 0) (gen-binary-integer '(3 4 3 2 4 2 5) '(1 1 3) :flatten nil) => ((1 1 1 0) (1 1 1 1 0) (1 1 1 0 0 0) (1 1 0) (1 1 1 1 0) (1 1 0 0 0) (1 1 1 1 1 0)) (setf intg '(3 2 4 5 3)) (setf zero-k '(1 2 1 3)) (gen-binary-integer intg zero-k) => '(1 1 1 0 1 1 0 0 1 1 1 1 0 1 1 1 1 1 0 0 0 1 1 1 0) |# S.

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)  

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)  

Nice idea! I reduced your code a bit by using case instead of nested if statements, and in particular higher-order programming. This should do this same.
 
Moreover, you can now do things you could not do before like comparing with >=.
 
(add-interval-if-length '((q c4 d4 e4 f4 e g4 a4) (e f4 e4 q d4 c4 a4 g4 h f4)) :interval-list '(3 4) :test #'>= :length-val 'q)
=> ((q c4eb4 mf q d4fs4 mf q e4g4 mf q f4a4 mf e g4 mf e a4 mf) (e f4 mf e e4 mf q d4f4 mf q c4e4 mf q a4c5 mf q g4b4 mf h f4gs4 mf))
 
Best,
Torsten
 
;;; ============================================== ;;; UTILITY FUNCTIONS ;;; (defun add-interval-if-length-aux (omn &key (test #'>) (length-val 1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (let ((s-events (single-events omn))) (loop for e in s-events for i in (gen-trim (length s-events) interval-list) when (funcall test (omn-encode (first e)) length-val) append (omn-replace :pitch (chord-interval-add (list i) (list (second e))) e) else append e))) ;(add-interval-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '(10 11)) ;;; ============================= ;;; MAIN FUNCTION (defun add-interval-if-length (omn &key (test #'>) (length-val 1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (do-verbose ("add-interval-if-length") (let ((test-fn (case test (> #'>) (< #'<) (= #'=) (otherwise test)))) (if (listp (car omn)) (mapcar #'(lambda (x) (add-interval-if-length-aux x :test test-fn :length-val (omn-encode length-val) :interval-list interval-list)) omn) (add-interval-if-length-aux omn :test test-fn :length-val (omn-encode length-val) :interval-list interval-list))))) ;(add-interval-if-length '((q c4 d4 e4 f4 e g4 a4) (e f4 e4 q d4 c4 a4 g4 f4)) :interval-list '(10 11)) ;(add-interval-if-length '((q c4 d4 e4 f4 e g4 a4) (e f4 e4 q d4 c4 a4 g4 h f4)) :interval-list '(3 4) :test #'>= :length-val 'q)  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;; ADD-INTERVAL-IF-LENGTH ;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; USAGE #| (setf seq '((e c4 p stacc d4 stacc e4 stacc f4 stacc q g4 g3) (q c4 mf e c6 b5 a5 g5 f5 d5) (s e4 f4 e4 d4 q g4 b4 d5) (q g5 ff marc g4 marc h c5 ))) ; with default parameters (add-interval-if-length '(1/4 c4 d4 e4 1/8 e4 f4)) (add-interval-if-length seq) ; with specified condition (add-interval-if-length seq :condition '<) (add-interval-if-length seq :condition '=) ; with specifird conditions en length value specification (add-interval-if-length seq :condition '= :length-val '1/4) |# ;;; CODE ;;; ============================================== ;;; UTILITY FUNCTIONS (defun add-interval-if-length-greater* (omn &key (length-val '1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (let ((s-events (single-events omn))) (loop for e in s-events for i in (gen-trim (length s-events) interval-list) when (> (omn-encode (first e)) length-val) append (omn-replace :pitch (chord-interval-add (list i) (list (second e))) e) else append e))) (defun add-interval-if-length-greater (omn &key (length-val '1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (if (listp (car omn)) (mapcar (lambda(x) (add-interval-if-length-greater* x :length-val (omn-encode length-val) :interval-list interval-list)) omn) (add-interval-if-length-greater* omn :length-val (omn-encode length-val) :interval-list interval-list))) ;(add-interval-if-length-greater '((q c4 d4 e4 f4 e g4 a4)(e f4 e4 q d4 c4 a4 g4 f4)) :interval-list '(10 11)) ;(add-interval-if-length-greater* '(q c4 d4 e4 f4 e g4 a4) :interval-list '(10 11)) (defun add-interval-if-length-lesser* (omn &key (length-val '1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (let ((s-events (single-events omn))) (loop for e in s-events for i in (gen-trim (length s-events) interval-list) when (< (omn-encode (first e)) length-val) append (omn-replace :pitch (chord-interval-add (list i) (list (second e))) e) else append e))) (defun add-interval-if-length-lesser (omn &key (length-val '1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (if (listp (car omn)) (mapcar (lambda(x) (add-interval-if-length-lesser* x :length-val (omn-encode length-val) :interval-list interval-list)) omn) (add-interval-if-length-lesser* omn :length-val (omn-encode length-val) :interval-list interval-list))) ;(add-interval-if-length-lesser '((q c4 d4 e4 f4 e g4 a4)(e f4 e4 q d4 c4 a4 g4 f4)) :length-val '1/2 :interval-list '(10 11)) ;(add-interval-if-length-lesser '(q c4 d4 e4 f4 e g4 a4) :length-val '1/4 :interval-list '(10 11)) (defun add-interval-if-length-equal* (omn &key (length-val '1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (let ((s-events (single-events omn))) (loop for e in s-events for i in (gen-trim (length s-events) interval-list) when (equal (omn-encode (first e)) length-val) append (omn-replace :pitch (chord-interval-add (list i) (list (second e))) e) else append e))) (defun add-interval-if-length-equal (omn &key (length-val '1/8) (interval-list '(4 3 4 7 4 3 5 4 7 3))) (if (listp (car omn)) (mapcar (lambda(x) (add-interval-if-length-equal* x :length-val (omn-encode length-val) :interval-list interval-list)) omn) (add-interval-if-length-equal* omn :length-val (omn-encode length-val) :interval-list interval-list))) ;(add-interval-if-length-equal '((q c4 d4 e4 f4 e g4 a4)(e f4 e4 q d4 c4 a4 g4 f4)) :length-val '1/4 :interval-list '(10 11)) ;(add-interval-if-length-equal '(q c4 d4 e4 f4 e g4 a4) :length-val '1/4 :interval-list '(10 11)) ;(add-interval-if-length-equal '(q c4 d4 e4 f4 e g4 a4) :length-val 'q :interval-list '(10 11)) ;;; MAIN FUNCTION ;;; ============================= (defun add-interval-if-length (omn &key (condition '>) (length-val '1/8)(interval-list '(4 3 4 7 4 3 5 4 7 3))) (do-verbose ("add-interval-if-length") (if (equal condition '>) (add-interval-if-length-greater omn :length-val length-val :interval-list interval-list) (if (equal condition '<) (add-interval-if-length-lesser omn :length-val length-val :interval-list interval-list) (if (equal condition '=) (add-interval-if-length-equal omn :length-val length-val :interval-list interval-list) ))))) SB.

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

Hello,
 
a small piece for piano solo.
Score script attached to this post.
 

 
SB.
Jeu2PourPiano.opmo

you could work with omn-replace (from OM-library)? ...or some other code... have a look... greetings andré
;;; THREE SIMILAR FUNCTIONS FROM MY USER LIBRARY ;;; recognizes the parameter who has to be replaced (defun omn-component-replace (omn-sequence replace-component) (make-omn :length (if (lengthp (car replace-component)) (append replace-component) (omn :length omn-sequence)) :pitch (if (or (pitchp (car replace-component)) (chordp (car replace-component))) (append replace-component) (omn :pitch omn-sequence)) :velocity (if (velocityp (car replace-component)) (append replace-component) (omn :velocity omn-sequence)) :articulation (if (articulationp (car replace-component)) (append replace-component) (omn :articulation omn-sequence)))) ;;; the same with multiple inputs at once (defun omn-component-replace2 (omn-sequence replace-component) (car (last (loop for i in replace-component collect (setf omn-sequence (make-omn :length (if (lengthp (car i)) (append i) (omn :length omn-sequence)) :pitch (if (pitchp (car i)) (append i) (omn :pitch omn-sequence)) :velocity (if (velocityp (car i)) (append i) (omn :velocity omn-sequence)) :articulation (if (articulationp (car i)) (append i) (omn :articulation omn-sequence)))))))) ;;; replaces a single element (defun omn-single-element-replace (omn-list old new) (let ((new-list (loop for i in (cond ((lengthp old) (omn :length (flatten omn-list))) ((pitchp old) (omn :pitch (flatten omn-list))) ((velocityp old) (omn :velocity (flatten omn-list))) ((articulationp old) (omn :articulation (flatten omn-list)))) when (equal i old) collect new else collect i))) (omn-component-replace (flatten omn-list) new-list))) ;;;;;;;;;;;;;;;;;; ;;; EXAMPLES (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)) => (qs gs3 ppp tasto q.. cs4 pppp tasto s. f4 ppp tasto) (omn-component-replace2 '(S C4 PPP TASTO Q.T D4 PPPP TASTO S E4 PPP TASTO) '((p) (ponte) (e2 b2 d2))) => (S E2 P PONTE Q.T B2 PONTE S D2 PONTE) (omn-single-element-replace '(t gs4 pppp tasto a4 tasto bb4 tasto -t) 'bb4 'c4) => (t gs4 pppp tasto a4 tasto c4 tasto -) (omn-single-element-replace '(t gs4 pppp tasto a4 tasto bb4 tasto -t) 'pppp 'ff) => (t gs4 ff tasto a4 tasto bb4 tasto -)  

Below is a link another way to write functions that process OMN more easily by defining only a function processing the parameter you are interested in, and then turning that quasi-automatically into a function that supports arbitrary OMN expressions (including nested expressions, preserving the nesting, and rests).  
 
Best,
Torsten

you could work with omn-replace (from OM-library)? ...or some other code... have a look... greetings andré
;;; THREE SIMILAR FUNCTIONS FROM MY USER LIBRARY ;;; recognizes the parameter who has to be replaced (defun omn-component-replace (omn-sequence replace-component) (make-omn :length (if (lengthp (car replace-component)) (append replace-component) (omn :length omn-sequence)) :pitch (if (or (pitchp (car replace-component)) (chordp (car replace-component))) (append replace-component) (omn :pitch omn-sequence)) :velocity (if (velocityp (car replace-component)) (append replace-component) (omn :velocity omn-sequence)) :articulation (if (articulationp (car replace-component)) (append replace-component) (omn :articulation omn-sequence)))) ;;; the same with multiple inputs at once (defun omn-component-replace2 (omn-sequence replace-component) (car (last (loop for i in replace-component collect (setf omn-sequence (make-omn :length (if (lengthp (car i)) (append i) (omn :length omn-sequence)) :pitch (if (pitchp (car i)) (append i) (omn :pitch omn-sequence)) :velocity (if (velocityp (car i)) (append i) (omn :velocity omn-sequence)) :articulation (if (articulationp (car i)) (append i) (omn :articulation omn-sequence)))))))) ;;; replaces a single element (defun omn-single-element-replace (omn-list old new) (let ((new-list (loop for i in (cond ((lengthp old) (omn :length (flatten omn-list))) ((pitchp old) (omn :pitch (flatten omn-list))) ((velocityp old) (omn :velocity (flatten omn-list))) ((articulationp old) (omn :articulation (flatten omn-list)))) when (equal i old) collect new else collect i))) (omn-component-replace (flatten omn-list) new-list))) ;;;;;;;;;;;;;;;;;; ;;; EXAMPLES (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)) => (qs gs3 ppp tasto q.. cs4 pppp tasto s. f4 ppp tasto) (omn-component-replace2 '(S C4 PPP TASTO Q.T D4 PPPP TASTO S E4 PPP TASTO) '((p) (ponte) (e2 b2 d2))) => (S E2 P PONTE Q.T B2 PONTE S D2 PONTE) (omn-single-element-replace '(t gs4 pppp tasto a4 tasto bb4 tasto -t) 'bb4 'c4) => (t gs4 pppp tasto a4 tasto c4 tasto -) (omn-single-element-replace '(t gs4 pppp tasto a4 tasto bb4 tasto -t) 'pppp 'ff) => (t gs4 ff tasto a4 tasto bb4 tasto -)  

(let ((i -1)) (defun next (liste) (nth (mod (incf i) (length liste)) liste))) ;;; (next '(a b c d e f)) SB.

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

Thanks. For completeness, below is a link to another rnd-pick variant with probability support. 
 
Best,
Torsten
 

Some changes to the Text & Lyrics tools.
If you used one of them please check the new functions.
The text-to-pitch function is replaced with TEXT-MAP with more options and functionality.
 
text-map map text &key flat rnd-order otherwise seed
 
[Function]
 
Arguments and Values:
map                a list of lists (<letter><symbol>) text               a string, a string list list of a list of letters. flat               T or NIL. The default is T. rnd-order          T or NIL. The default is NIL. otherwise          Nil, symbol or list of symbols. The default is NIL. seed               an integer - ensure the same result each time the code is evaluated.                    The default is NIL. Description:
 
This function converts a body of text into any symbol (parameter). It’s a further way to use words ("text") or a list of letters to create parametric material. Notice, that the function creates lists for each word and that punctuation is ignored.
 
In the following examples we will map a text to integers.
First we create a map:
(defparameter *map-integer1*   '(((a à á â ã ä å æ ą) 0)     (b 1)     ((c ç ć) 2)     (d 3)     ((e è é ê ë ę) 4)     (f 5)     (g 6)     (h 7)     ((i ì î ï) 8)     (j 9)     (k 10)     ((l ł) 11)     (m 12)     ((n ñ ń) 13)     ((o ò ó ô õ ö) 14)     (p 15)     (q 16)     (r 17)     ((s ś) 18)     (t 19)     ((u ù ú û ü) 20)     (v 21)     (w 22)     (x 23)     ((y ý ÿ) 24)     ((z ż ź) 25))) (setf text '("To be, or not to be, that is the question")) (text-map *map-integer1* text) => ((19 14) (1 4) (14 17) (13 14 19) (19 14) (1 4)     (19 7 0 19) (8 18) (19 7 4) (16 20 4 18 19 8 14 13))  
In the following map each letter is mapped into a list of two integer values. The letter (a à á â ã ä å æ ą) is mapped to 0 and -12. Every time the letter (a à á â ã ä å æ ą) is processed, 0 or -12 integer is picked at random.
(defparameter *map-integer2*   '(((a à á â ã ä å æ ą) (0 -12))     (b (1 -1))     ((c ç ć) (2 -2))     (d (3 -3))     ((e è é ê ë ę) (4 -4))     (f (5 -5))     (g (6 -6))     (h (7 -7))     ((i ì î ï) (8 -8))     (j (9 -9))     (k (10 -10))     ((l ł) (11 -11))     (m (12 -12))     ((n ñ ń) (13 -13))     ((o ò ó ô õ ö) (14 -14))     (p (15 -15))     (q (16 -16))     (r (17 -14))     ((s ś) (18 -18))     (t (19 -19))     ((u ù ú û ü) (20 -20))     (v (21 -21))     (w (22 -22))     (x (23 -23))     ((y ý ÿ) (24 -24))     ((z ż ź) (25 -25)))) (text-map *map-integer2* text) => ((19 -14) (-1 -4) (14 17) (-13 -14 -19) (-19 -14)     (1 4) (19 7 0 -19) (-8 18) (19 -7 -4)     (-16 20 -4 -18 19 8 -14 -13)) (text-map *map-integer2* text) => ((-19 14) (1 -4) (-14 17) (13 14 19) (19 14)     (1 4) (19 7 0 19) (8 18) (19 -7 -4)     (16 20 4 18 -19 8 -14 -13))  
A seed will ensure the same result each time the code is evaluated:
(text-map *map-integer2* text :seed 48) => ((19 -14) (1 -4) (14 -14) (-13 -14 19) (19 -14)     (-1 4) (19 7 -12 -19) (8 18) (-19 -7 4)     (16 -20 -4 18 19 -8 -14 -13))  
In the following examples we map a text to lengths. If a letter is mapped to a nested list ((e e. s)) then the entire list is selected.
(defparameter *map-length*   '(((a à á â ã ä å æ ą) ((s s s)))     (b ((s e s)))     ((c ç ć) ((e s s)))     (d ((s s e)))     ((e è é ê ë ę) ((e e. s)))     (f ((q e. s)))     (g ((e. e s)))     (h ((q s s)))     ((i ì î ï) ((s e. e)))     (j ((s e. e)))     (k ((s s q)))     ((l ł) ((e s e.)))     (m ((e e e)))     ((n ñ ń) ((e q e)))     ((o ò ó ô õ ö) ((q e e)))     (p ((e e q)))     (q ((q q. e)))     (r ((h q. e)))     ((s ś) ((q e q.)))     (t ((h e e)))     ((u ù ú û ü) ((e q. q)))     (v ((q. e h)))     (w ((e e h)))     (x ((q e q.)))     ((y ý ÿ) ((q q q)))     ((z ż ź) ((q h q))))) (text-map *map-length* text) => ((h e e q e e) (s e s e e. s) (q e e h q. e)     (e q e q e e h e e) (h e e q e e) (s e s e e. s)     (h e e q s s s s s h e e) (s e. e q e q.)     (h e e q s s e e. s)     (q q. e e q. q e e. s q e q. h e e s e. e q e e e q e)) (text-map *map-length* text :flat nil) => ((h e e) (q e e) (s e s) (e e. s) (q e e) (h q. e)     (e q e) (q e e) (h e e) (h e e) (q e e) (s e s) (e e. s)     (h e e) (q s s) (s s s) (h e e) (s e. e) (q e q.) (h e e)     (q s s) (e e. s) (q q. e) (e q. q) (e e. s) (q e q.)     (h e e) (s e. e) (q e e) (e q e))  
With the rnd-order option we can randomise the order of the elements in the list:
(text-map *map-length* text :flat nil :rnd-order t) => ((h e e) (q e e) (s e s) (s e. e) (e e q) (h e q.)     (e q e) (e q e) (h e e) (h e e) (e q e) (s e s) (s e e.)     (e h e) (q s s) (s s s) (e e h) (e. e s) (q. q e) (e h e)     (s q s) (s e e.) (q. e q) (q. e q) (s e e.) (q q. e)     (e h e) (s e e.) (e q e) (e e q))  
In the following examples we map text to pitches.
First we create a simple map with a letter mapped to a single pitch:
(defparameter *map-pitch1*   '(((a à á â ã ä å æ ą) c3)     (b cs3)     ((c ç ć) d3)     (d eb3)     ((e è é ê ë ę) e3)     (f f3)     (g fs3)     (h g3)     ((i ì î ï) gs3)     (j a4)     (k bb3)     ((l ł) b3)     (m c4)     ((n ñ ń) cs4)     ((o ò ó ô õ ö) d4)     (p eb4)     (q e4)     (r f4)     ((s ś) fs4)     (t g4)     ((u ù ú û ü) gs4)     (v a4)     (w bb4)     (x b4)     ((y ý ÿ) c5)     ((z ż ź) cs5))) (text-map *map-pitch1* text) => ((g4 d4) (cs3 e3) (d4 f4) (cs4 d4 g4) (g4 d4)     (cs3 e3) (g4 g3 c3 g4) (gs3 fs4) (g4 g3 e3)     (e4 gs4 e3 fs4 g4 gs3 d4 cs4))  
Here we map a letter to a list of two pitches:
(defparameter *map-pitch2*   '(((a à á â ã ä å æ ą) (c4 c3))     (b (cs4 b3))     ((c ç ć) (d4 bb3))     (d (eb4 a3))     ((e è é ê ë ę) (e4 gs3))     (f (f4 g3))     (g (fs4 fs3))     (h (g4 f3))     ((i ì î ï) (gs4 e3))     (j (a4 eb3))     (k (bb4 d3))     ((l ł) (b4 cs3))     (m (c5 c3))     ((n ñ ń) (cs5 b2))     ((o ò ó ô õ ö) (d5 bb2))     (p (eb5 a2))     (q (e5 gs2))     (r (f5 g2))     ((s ś) (fs5 fs2))     (t (g5 f2))     ((u ù ú û ü) (gs5 e2))     (v (a5 eb2))     (w (bb5 d2))     (x (b5 cs2))     ((y ý ÿ) (c6 c2))     ((z ż ź) (cs6 b1)))) (text-map *map-pitch2* text) => ((g5 bb2) (b3 e4) (bb2 f5) (b2 d5 f2) (f2 d5) (b3 gs3)     (f2 f3 c4 f2) (gs4 fs5) (g5 g4 gs3)     (gs2 gs5 gs3 fs2 f2 gs4 bb2 cs5))  
Example with a velocity map:
(defparameter *map-velocity*   '(((a à á â ã ä å æ ą) ppp)     (b ppp)     ((c ç ć) ppp)     (d pp)     ((e è é ê ë ę) pp)     (f pp)     (g p)     (h p)     ((i ì î ï) p)     (j mp)     (k mp)     ((l ł) mp)     (m mf)     ((n ñ ń) mf)     ((o ò ó ô õ ö) mf)     (p f)     (q f)     (r f)     ((s ś) ff)     (t ff)     ((u ù ú û ü) ff)     (v fff)     (w fff)     (x fff)     ((y ý ÿ) ffff)     ((z ż ź) ffff))) (text-map *map-velocity* '(o p u s m o d u s)) => (mf f ff ff mf mf pp ff ff)  
Example with binary map:
(defparameter *map-binary*   '(((a à á â ã ä å æ ą) ((1)))     (b ((1 0)))     ((c ç ć) ((1 1)))     (d ((1 0 0)))     ((e è é ê ë ę) ((1 0 1)))     (f ((1 1 0)))     (g ((1 1 1)))     (h ((1 0 0 0)))     ((i ì î ï) ((1 0 0 1)))     (j ((1 0 1 0)))     (k ((1 0 1 1)))     ((l ł)  ((1 1 0 0)))     (m ((1 1 0 1)))     ((n ñ ń) ((1 1 1 0)))     ((o ò ó ô õ ö) ((1 1 1 1)))     (p ((1 0 0 0 0)))     (q ((1 0 0 0 1)))     (r ((1 0 0 1 0)))     ((s ś) ((1 0 0 1 1)))     (t ((1 0 1 0 0)))     ((u ù ú û ü) ((1 0 1 0 1)))     (v ((1 0 1 1 0)))     (w ((1 0 1 1 1)))     (x ((1 1 0 0 0)))     ((y ý ÿ) ((1 1 0 0 1)))     ((z ż ź) ((1 1 0 1 0))))) (text-map *map-binary* '(o p u s m o d u s)) => ((1 1 1 1) (1 0 0 0 0) (1 0 1 0 1) (1 0 0 1 1)     (1 1 0 1) (1 1 1 1) (1 0 0) (1 0 1 0 1) (1 0 0 1 1))  
Example with otherwise option.
(setf map4       '((e e3)         (f f3)         (g fs3)         (h g3)         (i gs3)         (j a4)         (k bb3)         (l b3)         (m c4)         (n cs4)         (o d4))) (text-map map4 '(o p u s m o d u s)) => (d4 c4 d4)  
The result of the expression above is not equal to the length of the (o p u s m o d u s) list because the letters d, p, s and u are not in the map. Use the otherwise option to get the same count:
(text-map map4 '(o p u s m o d u s) :otherwise '((eb4e5) (f3fs4))) => (d4 (eb4e5) (f3fs4) (eb4e5) c4 d4 (eb4e5) (f3fs4) (f3fs4))  
In the following examples our maps are created algorithmically:
(setf map       (mapcar 'list               (make-alphabet)               (integer-to-pitch (gen-integer-step 0 26 '(1 -2 3 1))))) => ((a c4) (b cs4) (c b3) (d d4) (e eb4) (f e4) (g d4) (h f4)     (i fs4) (j g4) (k f4) (l gs4) (m a4) (n bb4) (o gs4) (p b4)     (q c5) (r cs5) (s b4) (t d5) (u eb5) (v e5) (w d5) (x f5)     (y fs5) (z g5)) (text-map map text) => ((d5 gs4) (cs4 eb4) (gs4 cs5) (bb4 gs4 d5) (d5 gs4)     (cs4 eb4) (d5 f4 c4 d5) (fs4 b4) (d5 f4 eb4)     (c5 eb5 eb4 b4 d5 fs4 gs4 bb4)) (setf map2       (mapcar 'list               (make-alphabet)               (mapcar 'list                       (integer-to-pitch                        (gen-integer-step 0 26 '(1 -2 3 1)))                       (integer-to-pitch                        (gen-integer-step -6 26 '(1 -2 3 1)))))) => ((a (c4 fs3)) (b (cs4 g3)) (c (b3 f3)) (d (d4 gs3))     (e (eb4 a3)) (f (e4 bb3)) (g (d4 gs3)) (h (f4 b3))     (i (fs4 c4)) (j (g4 cs4)) (k (f4 b3)) (l (gs4 d4))     (m (a4 eb4)) (n (bb4 e4)) (o (gs4 d4)) (p (b4 f4))     (q (c5 fs4)) (r (cs5 g4)) (s (b4 f4)) (t (d5 gs4))     (u (eb5 a4)) (v (e5 bb4)) (w (d5 gs4)) (x (f5 b4))     (y (fs5 c5)) (z (g5 cs5))) (text-map map2 text :seed 63) => ((d5 d4) (g3 a3) (d4 cs5) (bb4 gs4 d5) (d5 d4) (g3 a3)     (d5 b3 c4 d5) (c4 f4) (d5 f4 eb4)     (c5 eb5 eb4 b4 d5 c4 gs4 bb4))  
In the next example we map a group of letters to a group of pitches.
Example:  a = (c4 cs4 d4) b = (c4 cs4 d4) and c = (c4 cs4 d4) etc...
(setf map3       (mapcar 'list               (gen-divide 3 (make-alphabet))               (integer-to-pitch (gen-divide 3 (gen-integer 26))))) => (((a b c) (c4 cs4 d4)) ((d e f) (eb4 e4 f4))     ((g h i) (fs4 g4 gs4)) ((j k l) (a4 bb4 b4))     ((m n o) (c5 cs5 d5)) ((p q r) (eb5 e5 f5))     ((s t u) (fs5 g5 gs5)) ((v w x) (a5 bb5 b5))     ((y z) (c6 cs6 d6))) (text-map map3 text) => ((g5 c5) (cs4 f4) (c5 f5) (cs5 d5 g5) (gs5 d5)     (c4 f4) (fs5 gs4 d4 g5) (g4 fs5) (gs5 g4 f4)     (e5 gs5 f4 fs5 g5 gs4 c5 d5)) => ((gs5 c5) (c4 e4) (c5 eb5) (c5 c5 g5) (gs5 c5)     (c4 e4) (g5 gs4 cs4 fs5) (gs4 fs5) (gs5 fs4 e4)     (eb5 gs5 eb4 fs5 gs5 fs4 cs5 c5)) => . . .  
Best wishes to all,
JP

;;; ----------------------------------------------------------------------------------------------- ;;; A QUASI-UNISONO by proportional length-differences ;;; SAME PITCHES IN ALL VOICES INCLUDING START/END-PITCH ;;; ----------------------------------------------------------------------------------------------- ;;; a random-pitch-seq (rnd-walk) ;;; ;;; immediate-pitch-repetitions are building the rhythm ;;; ;;; with MODIFY-PROPORTIONS i'm generating "proportional variants" of this rhythm, in this example ;;; by 16 generations -> then i take the generations 1, 8, and 15 for each voice ;;; ;;; by "(filter-repeat 1 sequence)" i swallow the immediate-pitch-repetitions for correct ;;; of PITCH- and RHYTHM-phases ;;; ;;; ----------------------------------------------------------------------------------------------- ;;; FUNCTION (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))))) ;;; ----------------------------------------------------------------------------------------------- ;;; GENERATING SCORE (setf sequence (gen-walk 100 :step '(0 0 0 0 0 0 0 1 2) :start 'c5)) (setf rhy 1/32) ;;; ----------------------------------------------------------------------------------------------- (def-score quasi-unisono (:title "quasi-unisono" :key-signature 'atonal :time-signature '(4 4) :tempo 90) (instr1 :omn (make-omn :length (gen-length (nth 1 (modify-proportions 16 (count-repeat sequence) :style 'sharpen)) rhy) :pitch (filter-repeat 1 sequence)) :channel 1 :port 0 :sound 'gm) (instr2 :omn (make-omn :length (gen-length (nth 8 (modify-proportions 16 (count-repeat sequence) :style 'sharpen)) rhy) :pitch (filter-repeat 1 sequence)) :channel 2 :port 0 :sound 'gm) (instr3 :omn (make-omn :length (gen-length (nth 15 (modify-proportions 16 (count-repeat sequence) :style 'sharpen)) rhy) :pitch (filter-repeat 1 sequence)) :channel 3 :port 0 :sound 'gm)) there is no BUG when i work without "omn-to-time-signature", but is also not necessary!

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