# Composing with Chaos

a guest
Jun 14th, 2016
314
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
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))