Dear All,

Here are a version for a diatonic (or all purpose set-transpose) function that rounds material around a collection used as reference).

Please, Let me know if you find bugs.

Best,

Julio

(defun set-transpose (n omn-sequence sets &key (round 'up))

"Realiza transposição diatônica por N passos em coleções de referência.

Arredonda notas fora do set para cima ou para baixo conforme :round."

(let* ((dis (disassemble-omn omn-sequence))

(pitches (getf dis :pitch))

(num-bars (length pitches))

;; Alinha N e os Sets ao número de sublistas (compassos)

(n-list (gen-trim num-bars (if (listp n) n (list n))))

(set-list (gen-trim num-bars sets)))

(labels ((process-pitch (p val-n collection)

(let* ((p-int (pitch-to-integer p))

;; Normaliza a coleção para pitch-classes (0-11) ordenadas

(coll-pcs (sort (remove-duplicates

(mapcar (lambda (x) (mod x 12))

(flatten (pitch-to-integer collection))))

#'<))

(len-coll (length coll-pcs)))

(flet ((transpose-single (single-p)

(let* ((pc (mod single-p 12))

(oct (floor single-p 12))

;; 1. Arredondamento com info de oitava

(r-info (get-rounded-info pc coll-pcs round))

(rounded-pc (car r-info))

(r-oct-shift (cdr r-info))

;; 2. Localiza índice e aplica N passos diatônicos

(curr-idx (position rounded-pc coll-pcs))

(new-idx (+ curr-idx val-n))

;; 3. Calcula deslocamento de oitava final (wrap-around)

(final-oct-shift (+ r-oct-shift (floor new-idx len-coll)))

(final-pc (nth (mod new-idx len-coll) coll-pcs)))

;; 4. Reconstrói o pitch mantendo o registro original

(+ (* (+ oct final-oct-shift) 12) final-pc))))

;; Suporte para notas individuais ou acordes

(if (listp p-int)

(mapcar #'transpose-single p-int)

(transpose-single p-int)))))

(get-rounded-info (pc coll direction)

;; Retorna (rounded-pc . octave-shift)

(if (member pc coll)

(cons pc 0)

(case direction

(up (let ((higher (find pc coll :test #'<)))

(if higher

(cons higher 0)

(cons (first coll) 1)))) ;; Wrap up: vai p/ próx oitava

(down (let ((lower (find pc coll :from-end t :test #'>)))

(if lower

(cons lower 0)

(cons (car (last coll)) -1)))))))) ;; Wrap down: oitava anterior

;; Mapeamento bar-a-bar

(let ((new-pitches (mapcar (lambda (bar bar-n bar-set)

(mapcar (lambda (p) (process-pitch p bar-n bar-set)) bar))

pitches n-list set-list)))

;; Remontagem OMN final preservando os outros parâmetros

(make-omn :pitch (integer-to-pitch new-pitches)

:length (getf dis :length)

:velocity (getf dis :velocity)

:articulation (getf dis :articulation))))))

EXAMPLE

(setf temav1 '((e. a4 mf s -e c5 e. f4 s g4 - a4) (q c5 mf -e bb4 e. eb5 s ab4 - eb5) (q cs5 mf -e e5 e. as4 s b4 - cs5)))

(setf sets (expand-tonality '((ab4 major) (c4 major))))

(set-transpose -4 temav1 sets :round 'down)

((e. cs4 mf s -e f4 e. bb3 s c4 - cs4) (q f4 mf -e d4 e. g4 s c4 - g4) (q g4 mf -e gs4 e. eb4 s - g4))

(set-transpose -4 temav1 sets :round 'up)

((e. eb4 mf s -e f4 e. bb3 s c4 - eb4) (q f4 mf -e e4 e. a4 s d4 - a4) (q g4 mf -e bb4 e. eb4 s f4 - g4))

(setf sets (expand-tonality '((ab4 messiaen-mode2) (c4 major))))

(set-transpose -4 temav1 sets :round 'up)

Well done, Julio.

Jesper

Thanks Julio. good diatonic transpose function.

Thank you !!

Below is a much better version. In the new version, the function rounds the notes selectively, according to the spelling and there is no need to rewrite-acidentals. If the referential collection have more sharps the function rounds up and vice-versa for the flats. Also, it preserve the spelling of the referential collections (i.e. tonalities).

Best !

Julio

(defun set-transpose (n omn-sequence sets &key (round 'up))

"Transposição diatônica paramétrica com arredondamento seletivo:

'up' para sets com mais sustenidos e 'down' para sets com mais bemóis."

(let* ((dis (disassemble-omn omn-sequence))

(pitches (getf dis :pitch))

(num-bars (length pitches))

(n-list (gen-trim num-bars (if (listp n) n (list n))))

(set-list (gen-trim num-bars sets)))

(labels ((process-pitch (p val-n collection local-round)

(let* ((p-int (pitch-to-integer p))

(coll-ints (pitch-to-integer (flatten collection)))

(coll-pcs (sort (remove-duplicates

(mapcar (lambda (x) (mod x 12)) coll-ints))

#'<))

(len-coll (length coll-pcs)))

(flet ((transpose-single (single-p)

(let* ((pc (mod single-p 12))

(oct (floor single-p 12))

;; 1. Arredondamento seletivo detectado para este bar

(r-info (get-rounded-info pc coll-pcs local-round))

(rounded-pc (car r-info))

(r-oct-shift (cdr r-info))

;; 2. Transposição diatônica por índices

(curr-idx (position rounded-pc coll-pcs))

(new-idx (+ curr-idx val-n))

;; 3. Ajuste de oitava final (modular)

(final-oct-shift (+ r-oct-shift (floor new-idx len-coll)))

(final-pc (nth (mod new-idx len-coll) coll-pcs)))

(+ (* (+ oct final-oct-shift) 12) final-pc))))

(if (listp p-int)

(mapcar #'transpose-single p-int)

(transpose-single p-int)))))

(get-rounded-info (pc coll direction)

(if (member pc coll)

(cons pc 0)

(case direction

(up (let ((higher (find pc coll :test #'<)))

(if higher (cons higher 0) (cons (first coll) 1))))

(down (let ((lower (find pc coll :from-end t :test #'>)))

(if lower (cons lower 0) (cons (car (last coll)) -1)))))))

(spell-note (int-val bar-set)

"Reconstrói o símbolo OMN com oitava correta (c4=0) e spelling do set."

(let* ((pc (mod int-val 12))

(oct-suffix (+ 4 (floor int-val 12)))

(ref-note (find pc (flatten (pitch-to-integer bar-set))

:test (lambda (x y) (= x (mod y 12))))))

(if ref-note

(let* ((all-notes (flatten bar-set))

(orig-sym (nth (position ref-note (pitch-to-integer all-notes)) all-notes))

(pure-name (string-right-trim "0123456789" (symbol-name orig-sym))))

(intern (format nil "~a~d" pure-name oct-suffix)))

(car (integer-to-pitch (list int-val)))))))

;; --- PROCESSAMENTO BAR-A-BAR COM ARREDONDAMENTO SELETIVO ---

(let ((final-pitches

(mapcar (lambda (bar bar-n bar-set)

(let* ((set-syms (flatten (list! bar-set)))

;; A. Conta sustenidos (s) e bemóis (b) no set

(sharps (count-if (lambda (s) (search "s" (symbol-name s) :test #'char-equal)) set-syms))

(flats (count-if (lambda (s) (search "b" (symbol-name s) :test #'char-equal)) set-syms))

;; B. Define a direção de arredondamento local

(local-round (cond ((> sharps flats) 'up)

((> flats sharps) 'down)

(t round))) ;; Mantém o default se empatar

;; C. Processa as notas com o arredondamento calculado

(trans-ints (mapcar (lambda (p) (process-pitch p bar-n bar-set local-round)) bar)))

(mapcar (lambda (item)

(if (listp item)

(intern (format nil "~{~a~}" (mapcar (lambda (sub) (spell-note sub bar-set)) item)))

(spell-note item bar-set)))

trans-ints)))

pitches n-list set-list)))

(make-omn :pitch final-pitches

:length (getf dis :length)

:velocity (getf dis :velocity)

:articulation (getf dis :articulation))))))

EXAMPLE

(setf temav1 (gen-repeat 3 '((e. c4 mf s d4 -e e4 e. f4 s g4 - a4) (q b4 mf -e c4 e. d4 s e4 - f4) (q g4 mf -e a4 e. b4 s c4 - d4))))

(setf sets (expand-tonality '((e4 major) (ab4 major) (c4 major) (c4 diminished1))))

(set-transpose 0 temav1 sets)

((e. cs4 mf s ds4 -e e4 e. fs4 s gs4 - a4) (q bb4 mf -e c4 e. db4 s eb4 - f4) (q g4 mf -e a4 e. b4 s c4 - d4) (e. c4 mf s ds4 -e e4 e. fs4 s g4 - a4) (q b4 mf -e cs4 e. ds4 s e4 - fs4) (q g4 mf -e ab4 e. bb4 s c4 - db4) (e. c4 mf s d4 -e e4 e. f4 s g4 - a4) (q c5 mf -e c4 e. ds4 s e4 - fs4) (q gs4 mf -e a4 e. b4 s cs4 - ds4))

(set-transpose -3 temav1 sets)

((e. gs3 mf s a3 -e b3 e. cs4 s ds4 - e4) (q f4 mf -e g3 e. ab3 s bb3 - c4) (q d4 mf -e e4 e. f4 s g3 - a3) (e. g3 mf s as3 -e c4 e. cs4 s ds4 - e4) (q fs4 mf -e gs3 e. a3 s b3 - cs4) (q db4 mf -e eb4 e. f4 s g3 - ab3) (e. g3 mf s a3 -e b3 e. c4 s d4 - e4) (q g4 mf -e g3 e. as3 s c4 - cs4) (q ds4 mf -e e4 e. fs4 s gs3 - a3))