Regroupement de listes

[alexbrabo]

Bonsoir à tous,

 

Je travaille actuellement sur une application permettant d'automatiser l'impression d'extraits de plans de bâtiment, simplement en donnant les numéros des locaux comme arguments. Ça se présente plutôt bien mais je bloque sur une problématique, à savoir le regroupement de locaux. L'objectif est que, si des locaux désignés sont à proximités entre eux, alors on ne fait qu'une seule impression à l'échelle adaptée plutôt que d'imprimer chaque local indépendamment.

 

J'ai donc travaillé ça graphiquement pour identifier les locaux qui sont proches, et j'arrive donc à une liste lstlocauxvoisins qui ressemble à ça:

(setq lstlocauxvoisins '(("J/02/110" "J/02/111") ("J/02/109" "J/02/110") ("J/02/108" "J/02/109") ("B/02/107" "J/02/108") ("A/02/003" "A/02/002")))

Les paires correspondent à des locaux proches entre eux.

Je cherche à trouver une solution pour obtenir une liste de locaux sous la forme ((liste 1) (liste 2))... ou chaque liste contient les locaux groupés de proches en proches (attention les lettres et chiffres des codes locaux ne permettent pas de les regrouper géographiquement)

 

J'ai tenté plusieurs approches dont une en utilisant la fonction common de gile, mais je sèche ... et je pense que m'égare un peu et qu'il y a peut-être plus simple à faire.

Ci-dessous le bout de code esquissé ... tourné déjà dans tous les sens :blink:

 

Avez-vous une idée sur la façon de traiter ça ?

Merci d'avance pour votre aide !

 

(defun common (l1 l2)
 (if l1
   (if	(member (car l1) l2)
     (cons (car l1) (common (cdr l1) l2))
     (common (cdr l1) l2)
   )
 )
)

(setq ind -1)
(foreach paire lstlocauxvoisins
	(setq ind (+ ind 1))
	(mapcar 
		(lambda (x)
			(if (common paire x)
				(...)
			);if
		);lambda
		(vl-remove paire lstlocauxvoisins)	
	)
);foreach

[zebulon_]

Bonjour,

à partir de cet liste

(setq lstlocauxvoisins '(("J/02/110" "J/02/111") ("J/02/109" "J/02/110") ("J/02/108" "J/02/109") ("B/02/107" "J/02/108") ("A/02/003" "A/02/002")))

quelle est la liste souhaitée en résultat ?

 

Cela serait peut être plus simple à comprendre à partir d'un exemple.

 

Amicalement

Vincent

[didier]

Coucou

 

Premier message , donc ...

• Bienvenue
• Attention à la façon de poser les questions, c'est le seul moyen qu'on a pour communiquer
  

Je n'ai pas compris de quoi on peut partir pour regrouper les locaux

Une idée peut-être si les "codes" des locaux ne permettent pas un regroupement les positions géographiques le peuvent-elles ?

À ce moment on va travailler avec les noms de locaux mais aussi les coordonnées des points d'insertion du bloc nom de local dans le dessin, car je pense qu'il s'agit d'un bloc.

 

Amicalement

[alexbrabo]

Bonjour _zebumlon et didier

 

Oui avec le recul je comprends que mon message est plutôt complexe. Simplifions :

 

J'ai une liste en entrée de type :

((A B ) (B C) (B D) (D E) (F G))

 

La première paire veut dire que A et B sont voisins ... etc

Je veux pouvoir avoir des listes d'objets voisins entre eux. Pour cet exemple ca donnerai :

((A B C D E)(F G))

 

Didier, j'ai déjà créé la requête graphique pour obtenir cette liste avec détection de collision. Ma question concerne la manipulation de cette liste de paires que j'obtiens par la manip précédente.

 

Merci pour votre aide !

[(gile)]

Salut,

 

Si le critère de tri/groupement correspond bien aux trois derniers caractères des chaînes ("109" dans "J/02/109" ou "002" dans "A/02/002"), le code ci-dessous devrait fonctionner.

Il utilise une fonction pour extraire le critère de tri/groupement des chaînes*, et nécessite de trier en ordre croissant à la fois les membres de chaque paire et les paires dans la liste pour faciliter le groupement.

 

(defun grouperlocaux (lst / critere grouper)
 
 ;; extrait le critère de tri/groupement de la chaîne
 (defun critere (str) (atoi (substr str 6)))

 ;; groupe les paires dans des listes
 (defun grouper (lst tmp acc)
   (cond
     ((null lst) (cons (reverse tmp) acc))
     ((null tmp) (grouper (cdr lst) (list (car lst)) acc))
     ((= (critere (caar lst)) (critere (cadar tmp)))
      (grouper (cdr lst) (cons (car lst) tmp) acc)
     )
     (T (grouper lst nil (cons (reverse tmp) acc)))
   )
 )

 ;; groupe les paires de la liste après les avoir triées en ordre croissant
 (grouper
   (setq lst (vl-sort
               (mapcar
                 '(lambda (p)
                    (vl-sort p '(lambda (a B) (< (critere a) (critere B))))
                  )
                 lst
               )
               '(lambda (a B)
                  (< (critere (car a)) (critere (car B)))
                )
             )
   )
   nil
   nil
 )
)

[alexbrabo]

Salut Gile,

 

Merci pour ta proposition mais cela ne correspond pas à ce ce que je cherche à faire car les numéros ne se suivent pas forcément sur les plans.

 

Chaque paire de la liste ci-dessous désigne des locaux qui sont proches entre eux (pour chaque paire).

 

((A B) (B C) (B D) (D E) (F G))

A proche de B

B proche de C

B proche de D

D proche de E

F proche de G

 

Donc A, B, C, D et E sont "proches" entre eux.

F et G sont proches entre eux mais pas de A, B, C, D et E

 

Donc je cherche à avoir dans ce cas d’exemple deux listes qui regroupent les locaux proches de cette façon :

((A B C D E)(F G))

[zebulon_]

j'ai tenté quelque chose...

;;; REMOVE_DOUBLES - Suprime tous les doublons d'une liste
(defun REMOVE_DOUBLES (lst)
 (cond
   ((null lst) nil)
   (T
    (cons (car lst) (REMOVE_DOUBLES (vl-remove (car lst) lst)))
   )
 )
)

(defun famille (nlst / suite)
 (setq n (length nlst))
 (setq I 0)
 (repeat (- n 1)
   (setq J (+ I 1))
   (repeat (- n I 1)
     (if (not (zerop (logand (nth I nlst) (nth J nlst))))
       (setq suite T)
     )
     (setq J (+ J 1))
   )
   (setq I (+ I 1))
 )
 suite
)  


(defun voisinproc (lst)
 (setq idx (remove_doubles (apply 'append lst)))
 (setq nlst
   (mapcar 
     '(lambda (x)
        (logior
          (expt 2 (vl-position (car x) idx))
          (expt 2 (vl-position (cadr x) idx))
        )
     )
     lst
   )
 )

 (while (famille nlst)
   (setq lstfam nil)
   (setq fam (car nlst))
   (setq nlst (cdr nlst))
   (setq lstand (mapcar '(lambda (x) (logand fam x)) nlst))
   (setq lstor (mapcar '(lambda (x) (logior fam x)) nlst))
   (setq I 0)
   (repeat (length lstand)
     (setq valand (nth I lstand))
     (setq valor (nth I lstor))
     (setq e (nth I nlst))
     (if (zerop valand)
       (setq lstfam (cons e lstfam))
       (setq fam (logior fam valor))
     )
     (setq I (+ I 1))
   )
   (setq nlst (cons fam lstfam))
 )

 (setq nnlst nil)
 (while nlst
   (setq lstfam nil)
   (setq e (car nlst))
   (setq nlst (cdr nlst))
   (setq I 0)
   (repeat (length idx)
     (setq x (nth I idx))
     (if (not (zerop (logand (expt 2 I) e))) (setq lstfam (cons x lstfam)))
     (setq I (+ I 1))
   )
   (setq nnlst (cons lstfam nnlst))
 )
 (setq nnlst (mapcar '(lambda (x) (vl-sort x '<)) nnlst))
)

(defun c:voisin ()
 (setq lst '(("A" "B") ("B" "C") ("B" "D") ("D" "E") ("F" "G") ("A" "E") ("X" "Y")))
 (print (voisinproc lst))
 (setq lstlocauxvoisins '(("J/02/110" "J/02/111") ("J/02/109" "J/02/110") ("J/02/108" "J/02/109") ("B/02/107" "J/02/108") ("A/02/003" "A/02/002")))
 (print (voisinproc lstlocauxvoisins))
 (princ)
)

 

Amicalement

Vincent

[(gile)]

Celle-ci semble fonctionner.

 

(defun grouperpaires (lst / group)
 (defun group (lst sub tmp acc flag)
   (if lst
     (cond
       ((null sub) (group (cdr lst) (car lst) tmp acc T))
       ((member (caar lst) sub)
        (if (member (cadar lst) sub)
          (group (cdr lst) sub tmp acc flag)
          (group (cdr lst) (cons (cadar lst) sub) tmp acc T)
        )
       )
       ((member (cadar lst) sub)
        (if (member (caar lst) sub)
          (group (cdr lst) sub tmp acc flag)
          (group (cdr lst) (cons (caar lst) sub) tmp acc T)
        )
       )
       (T (group (cdr lst) sub (cons (car lst) tmp) acc flag))
     )
     (cond
       ((null tmp) (cons sub acc))
       (flag (group tmp sub nil acc nil))
       (T (group tmp nil nil (cons sub acc) nil))
     )
   )
 )

 (group lst nil nil nil nil)
)

 

(grouperpaires '(("A" "B") ("B" "C") ("D" "E") ("F" "G") ("B" "D"))) 

retourne : (("F" "G") ("E" "D" "C" "A" "B"))

 

(grouperpaires '(("J/02/110" "J/02/111") ("J/02/109" "J/02/110") ("J/02/108" "J/02/109") ("B/02/107" "J/02/108") ("A/02/003" "A/02/002")))

retourne : (("A/02/003" "A/02/002") ("B/02/107" "J/02/108" "J/02/109" "J/02/110" "J/02/111"))

[(gile)]

Quelques commentaires pour expliquer le fonctionnement de la fonction récursive 'group'.

 

;; fonction récursive de groupement de paires
;; Arguments
;; lst  : liste de paires à traiter
;; sub  : liste courante d'éléments groupés
;; tmp  : liste de paires temporairement rejetées
;; acc  : liste des listes d'élements groupés (résultat)
;; flag : drapeau indiquant si sub a été modifiée
(defun group (lst sub tmp acc flag)
 
 ;; si lst n'est pas vide
 (if lst
   (cond
     ;; si sub est vide, on relance avec lst sans la première paire, sub = la première paire et flag = T
     ((null sub) (group (cdr lst) (car lst) tmp acc T))
     ;; si le premier élément de la première paire de lst est présent dans sub
     ((member (caar lst) sub)
      ;; si le second élément de la première paire est présent dans lst,
      (if (member (cadar lst) sub)
        ;; alors, on relance avec la liste privée de la première paire
        (group (cdr lst) sub tmp acc flag)
        ;; sinon, on l'ajoute dans sub, on passe flag à T
        (group (cdr lst) (cons (cadar lst) sub) tmp acc T)
      )
     )
     ;; si le second élément de la première paire de lst est présent dans sub
     ((member (cadar lst) sub)
      ;; si le premier élément de la première paire est présent dans lst,
      (if (member (caar lst) sub)
        ;; alors, on relance avec la liste privée de la première paire
        (group (cdr lst) sub tmp acc flag)
        ;; sinon, on l'ajoute dans sub, on passe flag à T
        (group (cdr lst) (cons (caar lst) sub) tmp acc T)
      )
     )
     ;; sinon, on ajoute la première paire à tmp
     ;; et on relance avec la liste privé de la première paire
     (T (group (cdr lst) sub (cons (car lst) tmp) acc flag))
   )

   ;; si lst est vide
   (cond
     ;; si temp est vide (condition d'arrêt), on ajoute sub à acc et on renvoie acc
     ((null tmp) (cons sub acc))
     ;; si flag = T (sub a été modifiée), on relance en passant tmp à la place lst avec flag = nil
     (flag (group tmp sub nil acc nil))
     ;; sinon, on ajoute sub à acc et on relance en passant tmp à la place lst avec flag = nil
     (T (group tmp nil nil (cons sub acc) nil))
   )
 )
)

 

Rappel : pour suivre la pile des appels d'une fonction récursive, dans la console de l'éditeur Visual LISP, on appelle la fonction 'trace' avec le nom de la fonction :

(trace group)

on lance la fonction 'group' :

(group '(("A" "B") ("B" "C") ("D" "E") ("F" "G") ("B" "D")) nil nil nil nil)

et on peut voir la pile des appels dans la fenêtre 'Suivi'.

[(gile)]

Ou, dans un style impératif :

(defun grouper (lst / sub tmp acc flag)
 (while (or lst tmp)
   (if lst
     (cond
       ((null sub)
        (setq sub  (car lst)
              lst  (cdr lst)
              flag T
        )
       )
       ((member (caar lst) sub)
        (if (member (cadar lst) sub)
          (setq lst (cdr lst))
          (setq sub  (cons (cadar lst) sub)
                lst  (cdr lst)
                flag T
          )
        )
       )
       ((member (cadar lst) sub)
        (if (member (caar lst) sub)
          (setq lst (cdr lst))
          (setq sub  (cons (caar lst) sub)
                lst  (cdr lst)
                flag T
          )
        )
       )
       (T
        (setq tmp (cons (car lst) tmp)
              lst (cdr lst)
        )
       )
     )
     (cond
       (flag
        (setq lst  tmp
              tmp  nil
              flag nil
        )
       )
       (T
        (setq acc  (cons sub acc)
              lst  tmp
              tmp  nil
              sub  nil
              flag nil
        )
       )
     )
   )
 )
 (cons sub acc)
)

[(gile)]

Pour revenir sur ma première idée, une autre méthode qui reformate la liste pour obtenir une liste de paires pointées triée par 'car' croissant : (("A" . "B") ("B" . "C") ("B" . "D") ("D" . "E") ("F" . "G"))

 

(defun grouper_locaux (lst / massoc merge group)
 
 ;; (massoc "B" '(("A" . "B") ("B" . "C") ("B" . "D") ("D" . "E") ("F" . "G"))) => ("C" "D")
 (defun massoc (key alst)
   (if (setq alst (member (assoc key alst) alst))
     (cons (cdar alst) (massoc key (cdr alst)))
   )
 )

 ;; (group "A" '(("A" . "B") ("B" . "C") ("B" . "D") ("D" . "E") ("F" . "G"))) => ("A" "B" "C" "D" "E")
 (defun group (a l)
   (apply 'append (cons (list a) (mapcar '(lambda (x) (group x l)) (massoc a l))))
 )

 ;; (merge '(("A" . "B") ("B" . "C") ("B" . "D") ("D" . "E") ("F" . "G"))) => (("A" "B" "C" "D" "E") ("F" "G"))
 (defun merge (lst)
   (if lst
     ((lambda (l)
        (cons l (merge (vl-remove-if '(lambda (x) (member (car x) l)) lst)))
      )
       (group (caar lst) lst)
     )
   )
 )

 (merge (vl-sort
          (mapcar '(lambda (p)
                     (if (< (car p) (cadr p))
                       (cons (car p) (cadr p))
                       (cons (cadr p) (car p))
                     )
                   )
                  lst
          )
          '(lambda (x1 x2) (< (car x1) (car x2)))
        )
 )
)

[alexbrabo]

Chapeau Gile et zebulon !

Gile, ta fonction récursive est particulièrement bluffante ... je ne suis pas encore rôdé à ce type de fonction ...

J'avais aussi travaillé un peu et j'arrivais à quelque chose comme ça, non récursif :

 

(setq l '((A B) (D E) (F G) (B C) (G H) (B D)))	
(setq lsortie '())
(foreach paire l
	(setq ltemp paire)
	(mapcar 
		(lambda (x)
			(cond
					((member (car x) paire) (setq ltemp (append (list (cadr x)) ltemp)))
					((member (cadr x) paire) (setq ltemp (append (list (car x)) ltemp)))
			 		(T nil)
			);cond
		);lambda
		(vl-remove paire l)	
	)
	(setq ltemp
		(vl-sort ltemp
  				'(lambda (s1 s2)
 				(< (vl-symbol-name s1) (vl-symbol-name s2)))))
	(setq lsortie (cons ltemp lsortie))
);foreach

 

Cela me donnait une fois les doublons supprimés :

'((A B C D E) (F G H) (B D E) (A B C D)))

 

Il ne restait plus qu'à prendre pour chaque liste la plus longue des listes qui ont des atom communs et le tour était joué

Mais bon c'est moins clean ...

 

Merci pour votre aide ! Je retourne à la suite de l'appli :)

[zebulon_]

Bonsoir,

 

j'ai essayé de faire un truc basé sur une sorte d'indexation binaire qui permet de jouer avec des logand et des logior. Mais cela comporte de ce fait une faiblesse intrinsèque, compte tenu que le codage se fait sur des entiers sous la forme 2^n. Forcément, si n (qui est la "population" qui compose la liste) est grand, un moment ou un autre 2^n va dépasser ce qui est autorisé pour un entier.

 

Les fonctions proposées par (gile) sont donc nettement plus robustes et efficaces (et courtes !)

 

Amicalement

Vincent

[(gile)]

@ zebulon_,

ce n'est pas la première fois que tu m’impressionnes en choisissant des algorithmes auxquels je n'aurais jamais pensé.

Merci de me (nous) ouvrir l'esprit.

[zebulon_]

@ zebulon_,

ce n'est pas la première fois que tu m’impressionnes en choisissant des algorithmes auxquels je n'aurais jamais pensé.

Merci de me (nous) ouvrir l'esprit.

Bonjour,

on essaie tous de gravir la même montagne ! Le problème avec les voies un peu "exotiques", c'est qu'elles peuvent très bien ne mener nulle part !

C'est un peu ma façon d'être en général : quand j'ai quelque chose à bricoler, je me mets d'abord devant mon établi (qui tient plus du bordel, car je ne jette rien...) et je regarde ce que j'ai en magasin qui pourrait convenir. Ensuite, je fais avec ce que j'ai. En algorithmique, c'est pareil. En l’occurrence, j'ai toujours trouvé que le codage binaire des variables Autocad était quelque chose de malin pour spécifier plusieurs combinaisons avec un seul nombre. Et là je me suis dit que je pouvais réutiliser ce principe que j'avais en magasin.

 

Et en matière d'ouverture d'esprit, on est au moins deux ! Et j'en vois encore quelques autres !

 

Merci à toi !

Amicalement

Vincent

[VDH-Bruno]

Bonjour,

 

Petit passage rapide pour proposer un principe de résolution simple sur ce type de traitement qui doit fonctionner, sans tenir compte de la sructure des listes (c.a.d sans un traitement un spécifique limité aux seuls listes constituées de paires).

 

(defun mgrouper	(l / grp)

 (defun grp (l1 l2 acc flag)
   (cond
     ((null l1)(if flag (append l2 acc) l2))
     ((member (car l1) l2) (grp (cdr l1) l2 acc T))
     (T (grp (cdr l1) l2 (cons (car l1) acc) flag))
   )
 )

 ((lambda (l m)
    (cond
      ((null (cdr l)) l)
      ((equal (cdr l) m) (cons (car l) (mgrouper m)))
      (T (mgrouper m))
    )
  )
   l
   (mapcar '(lambda (x) (grp (car l) x nil nil)) (cdr l))
 )
)

 

_$ (mgrouper '(("A" "B") ("B" "C") ("D" "E") ("F" "G") ("B" "D")))

(("F" "G") ("B" "D" "A" "C" "E"))

 

 

Je pense que le tracage de la fonction mgrouper suffit pour comprendre l'algorithme, sinon je développerai le raisonnement en cas de demande.

(trace mgrouper)
(mgrouper '(("X" "Y") ("A" "B") ("M" "Y" "K") ("B" "Z" "C") ("D" "E") ("B" "D")("F" "G")))

Saisie (MGROUPER (("X" "Y") ("A" "B") ("M" "Y" "K") ("B" "Z" "C") ("D" "E") ("B" "D") ("F" "G")))
 Saisie (MGROUPER (("A" "B") ("M" "Y" "K" "X") ("B" "Z" "C") ("D" "E") ("B" "D") ("F" "G")))
   Saisie (MGROUPER (("M" "Y" "K" "X") ("B" "Z" "C" "A") ("D" "E") ("B" "D" "A") ("F" "G")))
     Saisie (MGROUPER (("B" "Z" "C" "A") ("D" "E") ("B" "D" "A") ("F" "G")))
       Saisie (MGROUPER (("D" "E") ("B" "D" "A" "C" "Z") ("F" "G")))
         Saisie (MGROUPER (("B" "D" "A" "C" "Z" "E") ("F" "G")))
           Saisie (MGROUPER (("F" "G")))
           Résultat:  (("F" "G"))
         Résultat:  (("B" "D" "A" "C" "Z" "E") ("F" "G"))
       Résultat:  (("B" "D" "A" "C" "Z" "E") ("F" "G"))
     Résultat:  (("B" "D" "A" "C" "Z" "E") ("F" "G"))
   Résultat:  (("M" "Y" "K" "X") ("B" "D" "A" "C" "Z" "E") ("F" "G"))
 Résultat:  (("M" "Y" "K" "X") ("B" "D" "A" "C" "Z" "E") ("F" "G"))
Résultat:  (("M" "Y" "K" "X") ("B" "D" "A" "C" "Z" "E") ("F" "G"))

 

A+ Bruno

[(gile)]

Brillant, comme d'habitude. ;)