How to change tonality of a given pattern to a destination tonality without pitch shifting of notes already being part of destination tonality

[DanielJean]

Hi,

;given pattern in c-major

(setf test-pattern-c-major '(c4 d4 e4 f4 g4 a4 b4 c5))

 

; required pattern: modified given pattern with notes only being part of a-major, no other pitch shifting :

->  (cs4 d4 e4 fs4 gs4 a4 b4 cs5) . pattern remains more or less in the same pitch range, only notes are modified not being part of a-major

 

;test:

(tonality-map '(major :root 'a4) test-pattern-c-major) 

; result:  (a4 b4 cs5 d5 e5 fs5 gs5 gs5) :   a-major ok, but pitch shifting of entire pattern

 

This result is not what I am looking for. I tried several tonality-map operation with different parameters without success. I do not seem  to find the correct parameter setting of tonality-map calls, or  there is no such solution with tonality map for my requirement.

Otherwise I will have to program it myself; to be avoided if possible

 

Thanks for any help, Daniel

 

P.S. ChatGPC for opusmodus proposes the following: (tonality-map '(a-major) test-pattern-c-major), which would be a super solution; too bad it does not work for opusmodus:  error: a-major not found

[jesele]

Try this:

(defun scale-from-ambitus (root tonality &optional (offset 0) (ambitus '(c0 c9)))
  (let* ((scl (expand-tonality (list root tonality :rotate offset) :type :integer))
         (len (length scl))
         (trs (gen-integer-step -84 15 12))
         (amb (ambitus-form ambitus))
         (out (remove-if (lambda (x) (or (< x (car amb)) (> x (cadr amb))))
                         (loop for tr in trs nconc (x+b scl tr)))))
    (values out len amb))    
  )
  
(defun change-tonality1 (lst from-root from-tonality to-root to-tonality &key (offset 0) (invert nil))
  (labels ((invert-add (lst n)
             (loop for x in lst collect (if (listp x) (invert-add x n) (+ (- x) n))))) 
    (let* ((equal-from-to (and (equal from-root to-root) (equal from-tonality to-tonality)))
           (ft (scale-from-ambitus from-root from-tonality 0 '(c0 c9)))
           (tt (if equal-from-to ft (scale-from-ambitus to-root to-tonality 0 '(c0 c9))))
           (st1 (car (pitch-to-integer (list (car lst)))))
           (st (if (listp st1) (car st1) st1)) 
           (start-offset (+ offset (- (position-if (lambda (y) (>= y st)) tt)
                                      (position-if (lambda (y) (>= y st)) ft))))
           (mat (if invert (invert-add (pitch-to-integer lst) (* 2 st)) (pitch-to-integer lst)))
           (res (loop for x in mat collect (if (listp x) 
                                               (loop for y in x collect
                                                       (nth (+ start-offset (position-if (lambda (z) (>= z y)) ft)) tt))
                                             (nth (+ start-offset (position-if (lambda (z) (>= z x)) ft)) tt)))))
      (cdr (integer-to-pitch (cons 0 res)))))
  )
  
(defun change-tonality (lst from-root from-tonality to-root to-tonality &key (offset 0) (invert nil))
  (let* ((omnp (omn-formp lst)) 
         (mat (if omnp (omn :pitch lst) lst))
         (res (if (atom (car mat)) (change-tonality1 mat from-root from-tonality to-root to-tonality :offset offset :invert invert)
                (mapcar (lambda (x) (change-tonality1 x from-root from-tonality to-root to-tonality :offset offset :invert invert)) mat))))
    (if omnp (omn-replace :pitch res lst) res))
  )

(setf test-pattern-c-major '(c4 d4 e4 f4 g4 a4 b4 c5))
(change-tonality test-pattern-c-major 'c4 'major 'a4 'major :offset 0 :invert nil)

(setf test-pattern-c-major2 '(f3a3c4 d4 e4 b3d4f4 g4 a4 b4 f4a4c5))
(change-tonality test-pattern-c-major2 'c4 'major 'a4 'major :offset 0 :invert nil)

 

Jesper

[DanielJean]

Hi Jesper,

Wow, thank you so much for your code, which works perfectly!!

You have been faster than me :-). I assume you are a professional?

I programmed C++ for years for the semiconductor industry, but I am not really fit in lisp yet.

May I ask you, what your background is?

Its so nice to help one another.

 

Have a nice day and thanks again.

Greetings to Sweden from Switzerland

Cheers Daniel

[jesele]

Hi Daniel. It was some code I already had. I have a bunch of stuff that hopefully can be included in OM later on when/if I finally

can get started with documentation. No, I'm far from a professional. I did a bunch of Lisp some 25 years ago but I'm

not very good. I was a professional percussion player/drummer for 20 years, switching to composing. Also worked as a studio manager

for 20 years.

 

Jesper

[Stephane Boussuge]

Very interesting,

 

here's another solution in a different style based on pitch class replacement.

 

(defun pitch-class-replace (old new sequence &key section exclude omn)
  (do-verbose ("pitch-class-replace")
    (labels ((pitch-class-replace-1 (old  new sequence)
               (let* ((integers (pitch-to-integer sequence))
                      (mod (modus integers))
                      (sub (replace-map (matrix-transpose (list old new)) mod)))
                 (octave-map sequence (integer-to-pitch sub))))
             
             (pitch-class-replace-ls (old new sequence)
               (loop 
                 for i in sequence
                 for n in (gen-trim (length sequence) (if (listp (car new))
                                                        new
                                                        (list new)))
                 for o in (gen-trim (length sequence) (if (listp (car old))
                                                        old
                                                        (list old)))
                 collect (pitch-class-replace-1 o n i)))
             
             (pitch-class-replace* (old new sequence)
               (if (listsp sequence)
                 (pitch-class-replace-ls old new sequence)
                 (pitch-class-replace-1 old new sequence))))
      
      (disassembling-omn ((sequence plist) sequence :pitch :span :length)
        (let ((len (length sequence)))
          (maybe-omn-decode
           omn
           (if exclude
             (maybe-section (lambda (x) (pitch-class-replace* old new x))
                            sequence (num-exclude len exclude))
             (maybe-section (lambda (x) (pitch-class-replace* old new x))
                            sequence section))))))))


(pitch-class-replace 
  '(0 2 4 7) '(4 5 0 11)
 '(e c3 p d4 e4 f4 q g5 stacc))

(pitch-class-replace 
  '(0 2 4 7) '(4 5 0 11)
 '((e c3 p d4 - - q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc)))

(pitch-class-replace 
  '(0 2 4 7) '(4 5 0 11)
 '((e c3 p d4 e4 f4 q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc))
 :section '(0 2))

(pitch-class-replace 
  '(0 2 4 7) '(4 5 0 11)
 '((e c3 p d4 e4 f4 q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc))
 :exclude '(0 2))

(pitch-class-replace
 '((0 2 7)(0 2 7)) '((2 4 6)(3 5 11))
'((e c3 p d4 e4 f4 q g5 stacc)
   (e c3 p d4 e4 f4 q g5 stacc)))
;; ------------------ Your example:
(setf test-pattern-c-major '(c4 d4 e4 f4 g4 a4 b4 c5))

(pitch-class-replace 
  '(0 5 7) '(1 6 8)
  test-pattern-c-major)

S.

[jesele]

Great Stephane.

The scale-from-ambitus function above can be useful for things like this also.

 

(loop for ton in '(locrian altered-dominant lydian altered-dominant)
        and root in '(d4 g4 c4 a3) collect
        (integer-to-pitch (scale-from-ambitus root ton 0 '(c4 g5))))

 

Jesper

[DanielJean]

Interesting! Thanks too Stephane!

danielwidler.com

[JulioHerrlein]

This is very good, Jesper

Certainly, a function that could be implemented at the core functions of Opusmodus. Janusz ?

Best,

Julio

[jesele]

Thanks, Julio, it's already there but in a slightly different version without offset that's not doing anything anyway.

It's used by infinity-series.

 

Ambitus has to be integers so you can use ambitus-form to convert.

Try like this without evaluating the function above.

 

(integer-to-pitch (scale-from-ambitus 'a4 'major (ambitus-form '(c4 g5))))

(loop for ton in '(locrian altered-dominant lydian altered-dominant)
        and root in '(d4 g4 c4 a3) collect
        (integer-to-pitch (scale-from-ambitus root ton (ambitus-form '(c4 g5)))))

 

Jesper

 

But change-tonality is not there yet. I have contact with Janusz. it's the problem of writing documentation And fixing bugs.

I have some jazz-voicing stuff etc, but they are rather complex and my eyes are not what they used to be, so I can only work short periods at the time. 

 

[JulioHerrlein]

Thanks, but the change-tonality you provided here seems better.

Best !

Julio

[jesele]

Yes, scale-from-ambitus is mostly a sub-function for some other functions.

Use the one above for now, and I will send Janusz all the stuff when I'm done.

It helps with my motivation that someone likes it.

 

Jesper

 

[DanielJean]

I also prefer Jaspers implementation.

However, in the definition of defun change-tonality (lst from-root from-tonality to-root to-tonality &key (offset 0) (invert nil))

,are the input parameters from-root and from-tonality really necessary? The given tonality of the pattern to be modified is not always easy to determine, especially if it is auto-generated.

Daniel

[jesele]

In my updated map-to-tonality function you can write like this.

 

(setf test-pattern-c-major '(c4 d4 e4 f4 g4 a4 b4 c5))
(map-to-tonality test-pattern-c-major 'a4 'major :follow 'm :step nil)
=> (cs4 d4 e4 fs4 gs4 a4 b4 cs5)

Sent it to Janusz now so let's see. 

I still have a lot of unfinished/undocumented stuff for later. 

 

 

Jesper

 

On 8/14/2024 at 3:50 PM, DanielJean said:

are the input parameters from-root and from-tonality really necessary?

 

No, maybe not but you do get another result if you write:

(setf test-pattern-c-major '(c4 d4 e4 f4 g4 a4 b4 c5))
(change-tonality test-pattern-c-major 'c4 'chromatic 'a4 'major :offset 0 :invert nil)

 

Jesper

[DanielJean]

Yes, I already could confirm the different results with different from-root, from-tonality. So lets see, what Janusz can do with this 

(map-to-tonality test-pattern-c-major 'a4 'major). That would be great!!

I would also be interested in the version-nr of opusmodus with this feature implemented.

 

Daniel

[jesele]

I just sent an updated version to Janusz so unless he has objections maybe in the next update.

 

Jesper

 

[Stephane Boussuge]

;;; The good way to process is to not think as tonalities 
;;; but more as pitch collections, more or less kind of pitch class sets.


(setf test-pattern-c-major '(c4 d4 e4 f4 g4 a4 b4 c5))
(setf set1 '((1 2 4 6 8 9 11) :closest 'up :map 'octave))

(tonality-map set1 test-pattern-c-major)