Composing with Chaos

(defun logistic-map (x r map n &key (exp 1.0) (offset 0.0) (round t))
  (unless (and (<= x 1.0) (>= x 0.0) (<= r 4.0) (>= r 0.0))
    (error "chaos: First argument should be in the [0;1] range; second ~
            argument should be in the [3;4] range."))
  (loop for i from 1 to n
     for result = (+ offset
                     (* map
            (expt
             (setf x (* r (* x (- 1.0 x)))) exp)))
     collect (if round (round result)
         result)))

(defun gen-set-palette (lower upper elements x r &key (exponent 1.0))
  (let* ((range
      (- (note-to-midi upper)
         (note-to-midi lower))))
    (cons
     (loop for i from 0 to (- elements 1)
    for init in (logistic-map x 4 1 elements :round nil)
    for leap in (logistic-map x 4 range elements)
    for offset = (+ (note-to-midi lower)
            (first (logistic-map init 4 (- range leap) 1)))
    collect (list i
              (list
               (remove-duplicates
            (mapcar 'midi-to-note
                (sort
                 (loop for midi in
                      (logistic-map init r leap 20
                            :exp exponent)
                    collect (note-to-midi (+ midi offset)))
                 #'<))))))
     '(:recurse-simple-data nil))))

(defun gen-rsp (timesig smallest elements x r &key (exponent 1.0))
  (loop for i from 0 to (- elements 1)
     for init in (logistic-map x 4 1 elements :round nil)
     collect (list i
           (let* ((rsp '())
              (sum 0)
              (notes 0))
             (loop for x in
              (remove 0
                  (logistic-map init r (* 2 smallest) 1000
                    ;double it to have a bipolar output
                     :exp exponent
                     :offset (* -1 smallest)))
            summing (/ 1.0 (abs x)) into tot
                    ; accumulate
            while (< tot (/ (first timesig)
                    (second timesig)))
                    ; check if the accumulated values do
                    ; exceed bar length
            do (setf sum tot)
            if (< x 0) ; attack if positive, rest if negative
            do (setf rsp
                 (cons
                  (list (abs x)) rsp))
            else
            do (setf rsp
                 (cons x rsp)))
             (setf rsp (cons    ; when notes exceed bar length,
                (/ 1    ; fill the remaining part
                   (rationalize
                    (- (/ (first timesig)
                      (second timesig)) sum))) rsp))
             (setf rsp
               (list
                (cons timesig (reverse rsp)))) ; correct order
             (loop for i in (first rsp)
            when (numberp i)
            do (incf notes)) ; accumulate number of attacks
             (setf rsp
               (list rsp ':pitch-seq-palette
                 (list ; generate pitch curve
                  (logistic-map init r 10 notes))))))))

(let* ((seed .7342)
       (r 4)
       (bars 20)
       (sets 20)
       (seqs 20)
       (logistic-map-test
    (make-slippery-chicken
     '+logistic-map-test+
     :ensemble '(((hand0 (piano :midi-channel 1))
              (hand1 (piano :midi-channel 1))))
     :tempo-map '((1 (q 60)))
     :set-palette (gen-set-palette 'c2 'c4 sets seed r)
     :set-map `((1 ,(logistic-map seed 4 (1- sets) bars)))
     :rthm-seq-palette (gen-rsp '(2 4) 32 seqs seed r)
     :rthm-seq-map `((1
              ((hand0 ,(logistic-map .24324 r (1- seqs) bars))
               (hand1 ,(logistic-map .34312 r (1- seqs) bars))))))))
  (re-bar logistic-map-test
      :min-time-sig '(4 4)
      :auto-beam 'q)
  (midi-play logistic-map-test)
  (cmn-display logistic-map-test))