;;; Fichier Imparite.lisp / 30 janvier 2012 ;;; (ancien Duval.lisp / 13 avril 2004) (in-package ::om) ;;; =================== ;;; ALGORITHME DE DUVAL ;;; =================== ;;; Jean-Pierre Duval, "Theoretical Computer Science", 60 (1988), pp. 255-283 (defun duval (n &optional parametre-affichage) (affichage-init n) (let ((w (make-array n)) (i 1)) (setf (aref w (1- i)) 'a) (loop while (not (= i 0)) do (loop for j from 1 to (- n i) do (setf (aref w (1- (+ i j))) (aref w (1- j)))) (affichage-duval i w parametre-affichage) (setf i n) (loop while (and (> i 0) (eq (aref w (1- i)) 'b)) do (setf i (1- i))) (if (> i 0) (setf (aref w (1- i)) (succ (aref w (1- i)))))))) (defun succ (x) (if (eq x 'a) 'b)) (defun affichage-duval (i w &optional parametre-affichage) (format *om-stream* "i=~a, w=~a, lyndon=~a~%" i w (subseq w 0 i))) (defun affichage-init (n) (format *om-stream* "================ MOTS DE LYNDON l=~a ================~%" n)) #| Calcul de tous les mots de Lyndon sur a, b de longueur <= 4 (duval 4) ;i=1, w=#(a a a a), lyndon=#(a) ;i=4, w=#(a a a b), lyndon=#(a a a b) ;i=3, w=#(a a b a), lyndon=#(a a b) ;i=4, w=#(a a b b), lyndon=#(a a b b) ;i=2, w=#(a b a b), lyndon=#(a b) ;i=3, w=#(a b b a), lyndon=#(a b b) ;i=4, w=#(a b b b), lyndon=#(a b b b) ;i=1, w=#(b b b b), lyndon=#(b) (duval 16) ; prend quelques secondes... |# ;;; ================== ;;; IMPARITE RYTHMIQUE ;;; ================== ;;; Chemillier & Truchet, "Information Processing Letters" 86 (2003) 255-261 #| ;Evaluer la fonction d'affichage pour les rythmes: ;'parametre-affichage' = nbre minimal de tirets - souhaite dans la partie gauche (defun affichage-duval (i w &optional parametre-affichage) (let* ((lyndon (subseq w 0 i)) (rythme (developpe lyndon)) (couple (separe rythme))) (when (and (oddp (count 'b lyndon)) (if parametre-affichage (>= (count nil (car couple)) parametre-affichage) t)) (format *om-stream* "rythme=~a~%" rythme) (printcompo (separe rythme))))) ;Calcul de tous les rythmes impairs a partir des mots de Lyndon sur a, b de longueur <= 3 ;ATENTION: evaluer d'abord la fonction 'affichage-duval' ci-dessus pour adapter 'duval' (duval 3) rythme=(3 3 3 3 2) composante1 = 3 3 - composante2 = 3 3 2 rythme=(3 3 2) composante1 = 3 - composante2 = 3 2 rythme=(2) composante1 = - composante2 = 2 ;Meme chose a partir des mots de Lyndon sur a, b de longueur <= 10 (duval 10) (duval 15) ; prend quelques secondes ;Meme chose avec au moins 3 tirets dans la 1ere composante du rythme: (duval 15 3) ;REMARQUE: On voit que les tirets alternent entre les 2 moities: ; rythme=(3 3 3 2 3 3 3 2 3 2 3 2 3 3 3 2 3 3 2 3 3 3 2 2 3 3 2) ; composante1 = 3 3 - 3 2 3 - 3 3 2 3 2 - 3 2 3 - ; composante2 = 3 3 2 3 - 3 2 3 3 - 3 2 2 3 - 3 2 ;On divise la sequence en 2 moities commencant par 3, avec autant de 3 de chaque cote ;Les couples obtenus forment une partie rationnelle avec: ; C0 = (3,3)(2,2)* ; C1 = (3,3)(2,2)*(-,2) ; C2 = (3,3)(2,2)*(2,-) ;L'ensemble des couples qui donnent un rythme asymetrique: ; C0* C1 C0* (C2 C0* C1 C0*)* |# ;Fonction transformant un mot sur a, b en rythme sur 2, 3 (defun developpe (m) (loop for i from 0 to (1- (length m)) with l1 = nil and l2 = nil when (eq (aref m i) 'a) do (progn (push 3 l1) (push 3 l2)) when (eq (aref m i) 'b) do (progn (setf l l1 l1 l2 l2 l) (push 2 l2)) finally return (append (reverse l1) (reverse l2)))) ;Fonction séparant un rythme sur 2, 3 en deux pseudo-moities: (defun separe (m) (let* ((partie1 (subseq m 0 (div (length m) 2))) (partie2 (subseq m (div (length m) 2) (length m)))) ;(print (list partie1 partie2)) (loop with l1 = partie1 and l2 = partie2 with c1 = nil and c2 = nil for x = (first l1) and y = (first l2) until (and (null l1) (null l2)) if (eq x y) do (progn (push (pop l1) c1) (push (pop l2) c2)) else do (if (eq x 2) (progn (push (pop l1) c1) (push () c2)) (progn (push () c1) (push (pop l2) c2))) finally return (list (reverse c1) (reverse c2))))) (defun printcompo (couple) (format *om-stream* "composante1 = ") (loop for x in (first couple) do (format *om-stream* "~a " (if (null x) '- x))) (format *om-stream* "~%composante2 = ") (loop for x in (second couple) do (format *om-stream* "~a " (if (null x) '- x))) (format *om-stream* "~%~%")) ;;; ==================== ;;; REPARTITION MAXIMALE ;;; ==================== ;;; John Clough & Jack Douthett #| ;Calcul des "intervalles diatoniques" pour les touches blanches du piano: ;2des maj./min., 3ces maj./min., 4tes justes/aug., 5tes justes/dim., 6tes maj./min., 7emes maj./min. (cumulate '(2 2 1 2 2 2 1)) ;Meme chose avec les touches noires (gamme pentatonique): (cumulate '(3 2 3 2 2)) ;Rythmes africains "maximalement repartis": (cumulate '(3 2 2 3 2 2 2)) ;Certains mots rythmiquement impairs le sont, d'autres ne le sont pas: (cumulate '(3 3 3 2 3 2 3 3 3 2 2 3 2)) (cumulate '(3 3 2 3 3 2 3 2 3 3 2 3 2)) ;Le rythme mokongo n'est pas maximalement reparti: (cumulate '(3 3 3 2 3 3 2 3 2)) ;L'autre rythme impair avec six 6 non plus: (cumulate '(3 3 3 2 3 3 3 2 2)) ;Il n'y a pas de mot maximalement reparti correspondant a six 3 et trois 2 (longueur=9, poids=24) ;car 9 et 24 ne sont pas premiers entre eux: (myE 9 24) |# (defun cumulate (w) (let ((d (length w)) (list-intervals) (res t)) (loop for k from 1 to d ;while res do (progn (setf list-intervals (loop for l = w then (cdr l) while l collect (apply '+ (nthcar k (append l w)))) res (and res (only-2-elts? list-intervals))) (affichage-cumulate k list-intervals) )) ;(when (not res) (format *om-stream* "NOT MAXIMALLY EVEN~%")) res)) (defun only-2-elts? (l) (let ((l1 (remove (car l) l))) (null (remove (car l1) l1)))) (defun affichage-cumulate (k list-intervals) (format *om-stream* "k=~a ~a~a~%" k list-intervals (if (only-2-elts? list-intervals) "" " NOT MAXIMALLY EVEN"))) (defmacro nthcar (n l) `(loop for x in ,l for i from ,n downto 1 collect x)) (defun maximally-even (w) (let ((d (length w)) (list-intervals) (res t)) (loop for k from 1 to (1- d) while res do (progn (setf list-intervals (loop for l = w then (cdr l) while l collect (apply '+ (nthcar k (append l w)))) res (only-2-elts? list-intervals)) ;(format *om-stream* "k=~a ~a~%" k list-intervals) ;(when (not res) (format *om-stream* "NOT MAXIMALLY EVEN~%")) )) res)) ;;; ==================== ;;; CHAINES EUCLIDIENNES ;;; ==================== (defun myI (w) (loop for x in w collect (1+ x))) (defun myX (w) (loop for x in w append (cons 0 (make-list x :initial-element 1)))) (defun myE (n k) (cond ((= n k) (list 1)) ((> n k) (myX (myE (- n k) k))) ((< n k) (myI (myE n (- k n)))))) #| (myE 5 13) ;-> (2 3 2 3 3) (myE 13 5) ;-> (0 0 1 0 0 1 0 1 0 0 1 0 1) (myE 12 5) ;-> (0 0 1 0 1 0 0 1 0 1 0 1) (myE 5 12) ;-> (2 2 3 2 3) (myE 3 8) ;-> (2 3 3) (myE 7 16) ;-> (2 2 2 3 2 2 3) (myE 9 20) ;-> (2 2 2 2 3 2 2 2 3) (myE 11 24) ;-> (2 2 2 2 2 3 2 2 2 2 3) ;mokongo correspond a (myE 9 24) -> (2 3 3) car 9=3x3 et 24=3x8 ne sont pas premiers (defun affichage-duval (i w &optional parametre-affichage) (let* ((lyndon (subseq w 0 i)) (rythme (developpe lyndon)) (n (length rythme)) (p (apply '+ rythme))) (when (= (gcd n p) 1) (format *om-stream* "N=~a P=~a rythme=~a~%" n p rythme)))) ;Calcul de tous les rythmes impairs de longueur n et poids p premiers entre eux ;ATENTION: evaluer d'abord la fonction 'affichage-duval' ci-dessus (duval 5) N=9 P=26 rythme=(3 3 3 3 3 3 3 3 2) N=7 P=20 rythme=(3 3 3 3 3 3 2) N=5 P=14 rythme=(3 3 3 3 2) N=7 P=18 rythme=(3 3 2 3 3 2 2) N=3 P=8 rythme=(3 3 2) N=7 P=18 rythme=(3 3 2 3 2 3 2) N=5 P=12 rythme=(3 2 3 2 2) N=1 P=2 rythme=(2) -> on a 2 solutions N=7 P=18, mais seule la 2eme est une chaine euclidienne: (myE 7 18) ;-> (2 3 2 3 2 3 3) (cumulate '(3 3 2 3 2 3 2)) k=1 (3 3 2 3 2 3 2) k=2 (6 5 5 5 5 5 5) k=3 (8 8 7 8 7 8 8) k=4 (11 10 10 10 10 11 10) k=5 (13 13 12 13 13 13 13) k=6 (16 15 15 16 15 16 15) k=7 (18 18 18 18 18 18 18) ;L'autre n'est pas maximalement reparti: (cumulate '(3 3 2 3 3 2 2)) k=1 (3 3 2 3 3 2 2) k=2 (6 5 5 6 5 4 5) NOT MAXIMALLY EVEN k=3 (8 8 8 8 7 7 8) k=4 (11 11 10 10 10 10 10) k=5 (14 13 12 13 13 12 13) NOT MAXIMALLY EVEN k=6 (16 15 15 16 15 15 16) k=7 (18 18 18 18 18 18 18) ;Calcul des mots cumules pour les rythmes impairs: ;comme on a deux entiers consecutifs au depart (2 et 3) ;=> les mots cumules ont toujours des entiers consecutifs (verifie '(14 14 14 15 14 14 14 14 14 13 14 14)) ATTENTION: evaluer les fonctions d'affichage 'affichage-duval' et 'affichage-cumulate': (duval 15) (defun affichage-duval (i w &optional parametre-affichage) (let* ((lyndon (subseq w 0 i)) (rythme (developpe lyndon)) (n (length rythme)) (p (apply '+ rythme))) (when (not (maximally-even rythme)) (cumulate rythme) (format *om-stream* "~%--------------------~%")))) (defun affichage-cumulate (k list-intervals) (when (and (not (only-2-elts? list-intervals)) (> (length (verifie list-intervals)) 3)) (format *om-stream* "k=~a ~a~a~%" k (verifie list-intervals) " NOT MAXIMALLY EVEN"))) |# (defun verifie (list-intervals) (let ((res (loop for l = list-intervals then (cdr l) until (null l) collect (car l) do (setf l (cons (car l) (remove (car l) l)))))) (sort res '<))) #| ;Affichage des mots maximalement repartis de longueur <= 10 ;On constate que pour une longueur et un poids donnes, ils sont uniques (let ((res (loop for x in (duval23 3) when (maximally-even x) collect x))) (loop for i from 1 to 10 do (loop for x in res when (= (length x) i) do (format *om-stream* "longueur=~a poids=~a ~a~%" (length x) (apply '+ x) x)))) ;Verification que tous les mots maximalement repartis de longueur <= 10 ont impairs rythmiquement: ;ATTENTION: ca inclut les mots avec un nombre impair de 3 (donc pas "impairs rythmiquement" au sens strict) ;Par contre, "maximalement repartis" semble exclure les cas avec un nbre pair a la fois de 2 et de 3 (let ((res (loop for x in (duval 10) when (maximally-even x) collect x))) (loop for x in res do (format *om-stream* "~a ~a~%" x (if (imparite? x) "RYTHMIQUEMENT IMPAIR" "NON")))) Verification Euclidean words TOUJOURS maximally even ??? (repeat 10 (let* ((n (+ 3 (random 20))) (k (+ n 1 (random 20)))) (when (= (gcd n k) 1) (progn (format t "N=~a K=~a~%" n k) (maximally-even (myE n k)) (format t "-------------------~%")))) ) |# ;Verification de l'imparite rythlique pour les mots maximalement repartis (defun imparite? (l) (loop for i from 1 to (length l) with bool = t do (progn (when (or (= (apply '+ (nthcar (div (length l) 2) l)) (apply '+ (nthcdr (div (length l) 2) l))) (= (apply '+ (nthcar (1+ (div (length l) 2)) l)) (apply '+ (nthcdr (1+ (div (length l) 2)) l)))) (setf bool nil)) (setf l (append (cdr l) (list (car l))))) finally return bool)) ;;;; A CORRIGER!!!!!!!!!!!!!!!!!!! (defun duval23 (n) (let ((w (make-array n)) (res)) (i 1)) (setf (aref w (1- i)) 2) (loop while (not (= i 0)) do (loop for j from 1 to (- n i) do (setf (aref w (1- (+ i j))) (aref w (1- j)))) (push (loop with v = (subseq w 0 i) for i from 0 to (1- (array-dimension v 0)) collect (aref v i)) res) (setf i n) (loop while (and (> i 0) (eq (aref w (1- i)) 3)) do (setf i (1- i))) (if (> i 0) (setf (aref w (1- i)) (succ23 (aref w (1- i)))))) res)) (defun succ23 (x) (if (eq x 2) 3))