AM Posted August 8, 2016 Share Posted August 8, 2016 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; a little function to compensate special-rhy-changes ;;; to 1/4-note structure... (or all :compensating-to -values) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; best format-solution was 1/32 => '(1 32) etc... otherwise ;;; i get in trouble with 1/8 = 4/32 - what is mathematicclay ;;; correct - but bringing BUGS to the output ;;; if anybody could transform things '(2/32) to '(2 32) or ;;; '(3/12) to '(3 12) would be nice, i coudn't code it. this ;;; things are necessary because the function makes decicions ;;; bewtween the denominators, so there sould be constant!!!! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun length-compensate2 (liste &key (compensating-to '(1 4))) (butlast (loop for event in (loop for i in (append liste (list (list (* -1 (first compensating-to)) (/ 1 (second compensating-to))))) collect (list (first i) (/ 1 (second i)))) with nenner with modulo with event_stack with add_duration = 0 with corr_event when (or (null event_stack) (= (second event_stack) (second event))) do (setq add_duration (+ add_duration (abs (first event))) event_stack event corr_event nil) else do (progn (setq nenner (/ (/ 1 (second event_stack)) (second compensating-to)) modulo (mod add_duration nenner)) (if (/= modulo 0) (setq corr_event (* (* -1 (- nenner modulo)) (second event_stack)))) (setq add_duration (abs (first event)))) when (not (equal corr_event 'nil)) collect corr_event and do (setq corr_event nil) collect (* (first event) (second event)) do (setq event_stack event)))) ;example-1 (length-compensate2 (loop repeat 5 collect (rnd-pick '((1 16) (-1 16) (2 32) (5 7) (13 9) (4 20) (6 20) (3 20) (5 16))))) ;exampl-2 (length-compensate2 (loop repeat 5 collect (rnd-pick '((1 16) (-1 16) (2 32) (5 7) (13 9) (4 20) (6 20) (3 20) (5 16)))) :compensating-to '(1 8)) Quote Link to comment Share on other sites More sharing options...
opmo Posted August 9, 2016 Share Posted August 9, 2016 Here is my solution: ;; ----------------------------------------------------------------------- ;; length-round ;; ----------------------------------------------------------------------- (defun find-length-base (length base) (prog (out i) (setf out nil) (setf i base) loop (cond ((not (null out)) (return out))) (setf out (if (<= length base) base)) (setf base (+ i base)) (go loop))) (defun length-round (sequence &key (round 1/4) section exclude) (do-verbose ("length-round") (labels ((length-round-1 (length round) (let ((out (- (find-length-base length round) length))) (list length (if (minusp length) (abs out) (neg! out))))) (length-round-l (list round) (flatten (loop for i in list collect (length-round-1 i round)))) (length-round-ls (list round) (let* ((len (length list)) (round (gen-trim* len (list! round)))) (loop for i in list for x in round collect (length-round-l i x)))) (length-round* (list round) (if (listsp list) (length-round-ls list round) (length-round-l list round)))) (let ((len (length sequence))) (if exclude (maybe-section (lambda (x) (length-round* x round)) sequence (num-exclude len exclude)) (maybe-section (lambda (x) (length-round* x round)) sequence section)))))) (length-round '(1/16 -1/16 2/32 5/7 4/20 6/20 3/20 5/16)) => (1/16 -3/16 -1/16 5/16 1/16 -3/16 5/7 -1/28 1/5 -1/20 3/10 -1/5 3/20 -1/10 5/16 -3/16) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round 1/8) => ((1/16 -1/16 -1/16 3/16 1/16 -1/16 5/7 -1/28) (1/5 -1/20 3/10 -3/40 3/20 -1/10 5/16 -1/16)) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8 1/4)) => ((1/16 -1/16 -1/16 3/16 1/16 -1/16 5/7 -1/28) (1/5 -1/20 3/10 -1/5 3/20 -1/10 5/16 -3/16)) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8) :section 0) => ((1/16 -1/16 -1/16 3/16 1/16 -1/16 5/7 -1/28) (1/5 3/10 3/20 5/16)) (length-round '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8) :exclude 0) => ((1/16 -1/16 1/16 5/7) (1/5 -1/20 3/10 -3/40 3/20 -1/10 5/16 -1/16)) AM and Stephane Boussuge 2 Quote Link to comment Share on other sites More sharing options...
AM Posted August 9, 2016 Author Share Posted August 9, 2016 VERY NICE CODE... but your function does not do the same as mine ...perhaps a misunderstanding / a different idea! ...you compensate EVERY value, my code only compensates when "rhy" is changing (length-round '(1/16 3/16 2/32 5/7 4/20 6/20 3/20 5/16)) => (1/16 -3/16 3/16 -1/16 1/16 -3/16 5/7 -1/28 1/5 -1/20 3/10 -1/5 3/20 -1/10 5/16 -3/16) ..after the 1/16 it's not necessary to "round" with -3/16, because -> also with teh other values here with my code -> i only want to compensate when "denominators" are changing => have a look at markings (bold) (length-compensate2 '((1 16) (3 16) (2 32) (5 7) (4 20) (6 20) (3 20) (5 16))) => (1/16 3/16 1/16 -3/16 5/7 -1/28 1/5 3/10 3/20 -1/10 5/16 -3/16) Quote Link to comment Share on other sites More sharing options...
opmo Posted August 10, 2016 Share Posted August 10, 2016 Final name and function: (length-rational-quantize '(1/4 -1/16 2/32 5/7 4/20 6/20 3/20 5/16)) => (1/4 -1/16 1/16 -1/8 5/7 -1/28 1/5 3/10 3/20 -1/10 5/16 -3/16) (length-rational-quantize '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round 1/8) => ((1/16 -1/16 1/16 -1/16 5/7 -1/28) (1/5 3/10 3/20 -1/10 5/16 -1/16)) (length-rational-quantize '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8 1/4)) => ((1/16 -1/16 1/16 -1/16 5/7 -1/28) (1/5 3/10 3/20 -1/10 5/16 -3/16)) (length-rational-quantize '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8) :section 0) => ((1/16 -1/16 1/16 -1/16 5/7 -1/28) (1/5 3/10 3/20 5/16)) (length-rational-quantize '((1/16 -1/16 2/32 5/7) (4/20 6/20 3/20 5/16)) :round '(1/8) :exclude 0) => ((1/16 -1/16 1/16 5/7) (1/5 3/10 3/20 -1/10 5/16 -1/16)) I see the difference of your output naturally. Quote Link to comment Share on other sites More sharing options...
AM Posted August 10, 2016 Author Share Posted August 10, 2016 it's allready in my USER LIBRARY... just say when you are not interested in such things - i know you have a lot of work without these extra-stuff... :-) i'm very happy with OPUSMODUS! Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.