Jump to content
  1. opmo

    opmo

  • Similar Topics

    • By AM
      shift-length-proportions 
       
      a bit like gen-morph for LENGTHS. every item of a length-list will change linear till the endpattern is reached.
       
       
      ;;; subfunction (defun compare (start end &key (step 1/32)) (list (loop for i in start for j in end when (/= i j) collect (if (> i 0) (if (< i j) (+ i step) (- i step)) (if (> i j) (- i step) (+ i step))) else collect i) end)) ;;; mainfunction (defun shift-length-proportions (start end &key (step 1/32) (rnd-pick nil)) (let ((seq)) (progn (setf seq (progn (setf start (omn :length start) end (omn :length end)) (append (list start) (loop until (equal start end) collect (setf start (car (compare start end :step step))))))) (if (or (null rnd-pick) (equal rnd-pick 'all)) seq (rnd-sample rnd-pick seq))))) ;;; EXAMPLES (shift-length-proportions '(1/32 7/32 1/16 3/16 1/4 -1/2) '(1/16 1/16 1/16 1/16 1/16 -1/2) :step 1/32) (shift-length-proportions '(1/16 1/16 1/16 1/16 1/16 -1/2) '(1/16 7/32 1/16 3/16 1/4 -1/2) :step 1/32) (shift-length-proportions '(1/32 7/32 1/16 3/16 1/4 -1/2) '(1/16 1/16 1/16 1/16 1/16 -1/2) :step 1/32 :rnd-pick 3) (shift-length-proportions '(1/32 7/32 1/16 3/16 1/4 -1/2) '(1/16 1/16 1/16 1/16 1/16 -1/2) :step 1/32 :rnd-pick 4) (shift-length-proportions '(e q h e.. s -h) '(q q q q q -h) :step 1/32 :rnd-pick 3)
       
    • By AM
      ;;; 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)  
    • By AM
      ;;; ---------------------------------------------------------------- ;;; 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...
       
×
×
  • Create New...