Jump to content

Search the Community

Showing results for tags 'lisp'.

  • Search By Tags

    Type tags separated by commas.
  • Search By Author

Content Type


Forums

  • Welcome to Opusmodus
    • Announcements
    • Pre Sales Questions
  • Support Forum
    • Support & Troubleshooting
    • OMN Lingo
    • Function Examples
    • Score and Notation
    • Live Coding Instrument
    • Library Setup
    • MIDI Setup
    • SuperCollider
  • Question & Answer
    • Suggestions & Ideas
    • Zoom into Opusmodus
  • Sharing
    • Made In Opusmodus
    • User Extensions Source Code
  • Opusmodus Workshops & Schools
    • Composer Workshop

Calendars

  • Community Calendar

Product Groups

  • Opusmodus

Categories

  • Introduction
  • How-to in 100 sec
  • Zoom into Opusmodus
  • SuperCollider
  • How-To
  • Workflow
  • Live Coding
  • Presentation
  • Analysis
  • Composer Workshop

Find results in...

Find results that contain...


Date Created

  • Start

    End


Last Updated

  • Start

    End


Filter by number of...

Joined

  • Start

    End


Group


Website URL


Gender


Location


Interests


About Me

  1. 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
  2. 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)
  3. (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 '=)
  4. 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)
  5. 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)
  6. 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))
  7. 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)
  8. 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)
  9. 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)
  10. ;;; 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
  11. ;;; 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)
  12. 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))
  13. 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)))
  14. ;;; 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)
  15. ;;; ---------------------------------------------------------------- ;;; 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...
  16. ...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)
  17. ;;; 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)
  18. 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
  19. 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)
  20. 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))
  21. 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
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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))
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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)))
  24. 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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
×
×
  • Create New...

Important Information

Terms of Use Privacy Policy