Jump to content
Sign in to follow this  
Stephane Boussuge

make-chord-if-length

Recommended Posts

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

Share this post


Link to post
Share on other sites

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

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Sign in to follow this  

×
×
  • Create New...