;;; 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))