code make-chord-if-length

[Stephane Boussuge]

Here's a new function a bit similar to my old "add-interval-if-length" function but bit more sophisticated.

It use gen-chord3 to create chord on defined length.

 

;;; ==============================================
;;; UTILITY FUNCTIONS
;;;
(defun make-chord-if-length-aux (omn &key (test #'>) (length-val 1/8) (interval-list '((4 7)(7 12))) (cycle t)(relative nil) seed)
(setf seed (rnd-seed seed))
  (let ((s-events (single-events omn)))
    (loop 
      for e in s-events
      for i in (gen-trim (length s-events) interval-list)
      when (funcall test (omn-encode (first e)) length-val)
      append (omn-replace :pitch (gen-chord3  (list (second e))   i :cycle cycle :relative relative :seed (seed)) e )
      else append e)))

;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4))
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7)(3 10)))
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil)
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil :seed 4)
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil :relative t)
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil :relative t :seed 4)

;;; =============================
;;; MAIN FUNCTION   
(defun make-chord-if-length (omn &key (test #'>) (length-val 1/8) (interval-list '((4 7)(7 12)))(cycle nil)(relative nil) seed)
  (setf seed (rnd-seed seed))
  (do-verbose ("make-chord-if-length :seed ~s :length-val ~s :interval-list ~s :cycle ~s  :relative ~s" seed length-val interval-list cycle relative)
    (let ((test-fn (case test
                     (> #'>)
                     (< #'<)
                     (= #'=)
                     (otherwise test))))
      (if (listp (car omn))
        (mapcar #'(lambda (x) 
                    (make-chord-if-length-aux x :test test-fn :length-val (omn-encode length-val) :interval-list interval-list
                                              :cycle cycle :relative relative :seed (seed))) 
                omn)
        (make-chord-if-length-aux omn :test test-fn :length-val (omn-encode length-val) :interval-list interval-list 
                                  :cycle cycle :relative relative :seed (seed))))))

;;; Tests
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)))
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :seed 8)
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :interval-list '((2 9)(7 11)))
;(make-chord-if-length '((q c4 d4 e4 f4 g4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :cycle t)
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :cycle nil :relative t)
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :cycle nil :relative t :seed 8)

i've also attached the original file to this post.

SB.

make-chord-if-length.lisp

[Stephane Boussuge]

Sorry, there was a mistake in this first version.

 

here's the correct one.

 

Apologize.

 

SB.

 

 

;;; ==============================================
;;; UTILITY FUNCTIONS
;;;
(defun make-chord-if-length-aux (omn &key (test #'>) (length-val 1/8) (interval-list '((4 7)(7 12))) (cycle t)(relative nil) seed)
(setf seed (rnd-seed seed))
  (let ((s-events (single-events omn)))
    (loop 
      for e in s-events
      when (funcall test (omn-encode (first e)) length-val)
      append (omn-replace :pitch (gen-chord3  (list (second e))   interval-list :cycle cycle :relative relative :seed (seed)) e )
      else append e)))



;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4))
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7)(3 10)))
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil)
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((-17 -12 4 7)(-12 -7 5 10)) :cycle t)
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil :seed 4)
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil :relative t)
;(make-chord-if-length-aux '(q c4 d4 e4 f4 e g4 a4) :interval-list '((4 7 11 14)(7 9 16)) :cycle nil :relative t :seed 4)

;;; =============================
;;; MAIN FUNCTION   
(defun make-chord-if-length (omn &key (test #'>) (length-val 1/8) (interval-list '((4 7)(7 12)))(cycle nil)(relative nil) seed)
  (setf seed (rnd-seed seed))
  (do-verbose ("make-chord-if-length :seed ~s :length-val ~s :interval-list ~s :cycle ~s  :relative ~s" seed length-val interval-list cycle relative)
    (let ((test-fn (case test
                     (> #'>)
                     (< #'<)
                     (= #'=)
                     (otherwise test))))
      (if (listp (car omn))
        (mapcar #'(lambda (x) 
                    (make-chord-if-length-aux x :test test-fn :length-val (omn-encode length-val) :interval-list interval-list
                                              :cycle cycle :relative relative :seed (seed))) 
                omn)
        (make-chord-if-length-aux omn :test test-fn :length-val (omn-encode length-val) :interval-list interval-list 
                                  :cycle cycle :relative relative :seed (seed))))))

;;; Tests
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)))
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :seed 8)
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :interval-list '((2 9)(7 11)))
;(make-chord-if-length '((q c4 d4 e4 f4 g4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :cycle t)
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :cycle nil :relative t)
;(make-chord-if-length '((q c4 e d4 e4 f4 h d4)(s a4 b4 a4 g4 h f4)(q c4 d4 h e4)) :cycle nil :relative t :seed 8)

 

make-chord-if-length.lisp