Advertisement
Guest User

Composing with Chaos

a guest
Jun 14th, 2016
260
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Lisp 3.12 KB | None | 0 0
  1. (defun logistic-map (x r map n &key (exp 1.0) (offset 0.0) (round t))
  2.   (unless (and (<= x 1.0) (>= x 0.0) (<= r 4.0) (>= r 0.0))
  3.     (error "chaos: First argument should be in the [0;1] range; second ~
  4.            argument should be in the [3;4] range."))
  5.   (loop for i from 1 to n
  6.      for result = (+ offset
  7.                      (* map
  8.             (expt
  9.              (setf x (* r (* x (- 1.0 x)))) exp)))
  10.      collect (if round (round result)
  11.          result)))
  12.  
  13. (defun gen-set-palette (lower upper elements x r &key (exponent 1.0))
  14.   (let* ((range
  15.       (- (note-to-midi upper)
  16.          (note-to-midi lower))))
  17.     (cons
  18.      (loop for i from 0 to (- elements 1)
  19.     for init in (logistic-map x 4 1 elements :round nil)
  20.     for leap in (logistic-map x 4 range elements)
  21.     for offset = (+ (note-to-midi lower)
  22.             (first (logistic-map init 4 (- range leap) 1)))
  23.     collect (list i
  24.               (list
  25.                (remove-duplicates
  26.             (mapcar 'midi-to-note
  27.                 (sort
  28.                  (loop for midi in
  29.                       (logistic-map init r leap 20
  30.                             :exp exponent)
  31.                     collect (note-to-midi (+ midi offset)))
  32.                  #'<))))))
  33.      '(:recurse-simple-data nil))))
  34.  
  35. (defun gen-rsp (timesig smallest elements x r &key (exponent 1.0))
  36.   (loop for i from 0 to (- elements 1)
  37.      for init in (logistic-map x 4 1 elements :round nil)
  38.      collect (list i
  39.            (let* ((rsp '())
  40.               (sum 0)
  41.               (notes 0))
  42.              (loop for x in
  43.               (remove 0
  44.                   (logistic-map init r (* 2 smallest) 1000
  45.                     ;double it to have a bipolar output
  46.                      :exp exponent
  47.                      :offset (* -1 smallest)))
  48.             summing (/ 1.0 (abs x)) into tot
  49.                     ; accumulate
  50.             while (< tot (/ (first timesig)
  51.                     (second timesig)))
  52.                     ; check if the accumulated values do
  53.                     ; exceed bar length
  54.             do (setf sum tot)
  55.             if (< x 0) ; attack if positive, rest if negative
  56.             do (setf rsp
  57.                  (cons
  58.                   (list (abs x)) rsp))
  59.             else
  60.             do (setf rsp
  61.                  (cons x rsp)))
  62.              (setf rsp (cons    ; when notes exceed bar length,
  63.                 (/ 1    ; fill the remaining part
  64.                    (rationalize
  65.                     (- (/ (first timesig)
  66.                       (second timesig)) sum))) rsp))
  67.              (setf rsp
  68.                (list
  69.                 (cons timesig (reverse rsp)))) ; correct order
  70.              (loop for i in (first rsp)
  71.             when (numberp i)
  72.             do (incf notes)) ; accumulate number of attacks
  73.              (setf rsp
  74.                (list rsp ':pitch-seq-palette
  75.                  (list ; generate pitch curve
  76.                   (logistic-map init r 10 notes))))))))
  77.  
  78. (let* ((seed .7342)
  79.        (r 4)
  80.        (bars 20)
  81.        (sets 20)
  82.        (seqs 20)
  83.        (logistic-map-test
  84.     (make-slippery-chicken
  85.      '+logistic-map-test+
  86.      :ensemble '(((hand0 (piano :midi-channel 1))
  87.               (hand1 (piano :midi-channel 1))))
  88.      :tempo-map '((1 (q 60)))
  89.      :set-palette (gen-set-palette 'c2 'c4 sets seed r)
  90.      :set-map `((1 ,(logistic-map seed 4 (1- sets) bars)))
  91.      :rthm-seq-palette (gen-rsp '(2 4) 32 seqs seed r)
  92.      :rthm-seq-map `((1
  93.               ((hand0 ,(logistic-map .24324 r (1- seqs) bars))
  94.                (hand1 ,(logistic-map .34312 r (1- seqs) bars))))))))
  95.   (re-bar logistic-map-test
  96.       :min-time-sig '(4 4)
  97.       :auto-beam 'q)
  98.   (midi-play logistic-map-test)
  99.   (cmn-display logistic-map-test))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement