Nettoyer les polylignes

(gile) · le 12 novembre 2007

J'avais fait un LISP, Clean_poly, qui supprimait tout les sommets superposés dans tout type de polyligne.

Celui-ci ne traite que les polyligne 'optimisées' (lwpolyline) mais supprime aussi tous les sommets alignés (ou sur le même arc) à condition qu'ils ne marquent pas une rupture de largeur (voir image).

C'est un peu une application concrète du Challenge 12

http://img50.imageshack.us/img50/4734/clean2ir7.png

Nouvelle version : 2 commandes Cpl et Ppl (voir plus bas)

;; CPL Fonction d'appel

(defun c:cpl (/ ss n)
 (vl-load-com)
 (princ
   "\nSélectionnez les polylignes à traiter ou [b]: "
 )
 (or (setq ss (ssget '((0 . "LWPOLYLINE"))))
     (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
 )
 (if ss
   (progn
     (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
     (setq n -1)
     (while (setq pl (ssname ss (setq n (1+ n))))
(CleanPline pl nil)
     )
     (princ (strcat "\n\t" (itoa n) " polylignes traitées."))
     (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
   )
   (princ "\nAucune polyligne sélectionnée.")
 )
 (princ)
)

;; PPL Fonction d'appel

(defun c:ppl (/ ss n)
 (vl-load-com)
 (princ
   "\nSélectionnez les polylignes à traiter ou [b]: "
 )
 (or (setq ss (ssget '((0 . "LWPOLYLINE"))))
     (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
 )
 (if ss
   (progn
     (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
     (setq n -1)
     (while (setq pl (ssname ss (setq n (1+ n))))
(CleanPline pl T)
     )
     (princ (strcat "\n\t" (itoa n) " polylignes traitées."))
     (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
   )
   (princ "\nAucune polyligne sélectionnée.")
 )
 (princ)
)

;; CleanPline (gile) 13/11/2007
;; Supprime tous les sommets superflus (alignés ou superposés) d'une polyligne
;; Conserve les arcs et largeurs.
;;
;; Arguments
;; pl : la polyligne à traiter (ename)
;; tt : T ou nil
;;    - T supprime tous les points alignés ou sur le même arc
;;    - nil conserve les sommets qui reviennent sur le trajet de la polyligne

(defun CleanPline (pl	    tt	     /	      regular-width	elst
	   closed   old-p    old-b    old-sw   old-ew	new-p
	   new-b    new-sw   new-ew   b1       b2
	  )

 (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta norm)
   (setq delta	(- we2 ws1)
   )
   (and (= we1 ws2)
 (equal	(/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
	      (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
	   )
	   (- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
	      (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
	   )
	)
	(/ (- we1 (- we2 delta)) delta)
	0.01
 )
   )
 )

 (setq elst (entget pl))
 (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
 (setq	old-p  (vl-remove-if-not
	 (function (lambda (x) (= (car x) 10)))
	 elst
       )
old-sw (vl-remove-if-not
	 (function (lambda (x) (= (car x) 40)))
	 elst
       )
old-ew (vl-remove-if-not
	 (function (lambda (x) (= (car x) 41)))
	 elst
       )
old-b  (vl-remove-if-not
	 (function (lambda (x) (= (car x) 42)))
	 elst
       )
elst   (vl-remove-if
	 (function (lambda (x) (member (car x) '(10 40 41 42))))
	 elst
       )
 )
 (and closed (setq old-p (append old-p (list (car old-p)))))
 (while (cddr old-p)
   (if	(or (= (cdar old-sw)
       (cdar old-ew)
       (cdadr old-sw)
       (cdadr old-sw)
    )
    (regular-width
      (cdar old-p)
      (cdadr old-p)
      (cdaddr old-p)
      (cdar old-sw)
      (cdar old-ew)
      (cdadr old-sw)
      (cdadr old-ew)
    )
)
     (if (and (zerop (cdar old-b))
       (zerop (cdadr old-b))
  )
(if
  (if tt
    (null (inters (cdar old-p)
		  (cdaddr old-p)
		  (cdar old-p)
		  (cdadr old-p)
	  )
    )
    (betweenp (cdar old-p) (cdaddr old-p) (cdadr old-p))
  )
   (setq old-p	(cons (car old-p) (cddr old-p))
	 old-b	(cons (car old-b) (cddr old-b))
	 old-sw	(cons (car old-sw) (cddr old-sw))
	 old-ew	(cons (cadr old-ew) (cddr old-ew))
   )
   (setq new-p	(cons (car old-p) new-p)
	 new-b	(cons (car old-b) new-b)
	 new-sw	(cons (car old-sw) new-sw)
	 new-ew	(cons (car old-ew) new-ew)
	 old-p	(cdr old-p)
	 old-b	(cdr old-b)
	 old-sw	(cdr old-sw)
	 old-ew	(cdr old-ew)
   )
)
(if
  (and
    (/= 0.0 (cdar old-b))
    (/= 0.0 (cdadr old-b))
    (equal (caddr
	     (setq
	       b1 (BulgeData (cdar old-b) (cdar old-p) (cdadr old-p))
	     )
	   )
	   (caddr
	     (setq b2
		    (BulgeData (cdadr old-b) (cdadr old-p) (cdaddr old-p))
	     )
	   )
	   1e-4
    )
    (or	tt
	(or (and (		    (and (		)
    )
  )
   (setq old-p	(cons (car old-p) (cddr old-p))
	 old-b	(cons (cons 42 (tan (/ (+ (car b1) (car b2)) 4.0)))
		      (cddr old-b)
		)
	 old-sw	(cons (car old-sw) (cddr old-sw))
	 old-ew	(cons (cadr old-ew) (cddr old-ew))
   )
   (setq new-p	(cons (car old-p) new-p)
	 new-b	(cons (car old-b) new-b)
	 new-sw	(cons (car old-sw) new-sw)
	 new-ew	(cons (car old-ew) new-ew)
	 old-p	(cdr old-p)
	 old-b	(cdr old-b)
	 old-sw	(cdr old-sw)
	 old-ew	(cdr old-ew)
   )
)
     )
     (setq new-p  (cons (car old-p) new-p)
    new-b  (cons (car old-b) new-b)
    new-sw (cons (car old-sw) new-sw)
    new-ew (cons (car old-ew) new-ew)
    old-p  (cdr old-p)
    old-b  (cdr old-b)
    old-sw (cdr old-sw)
    old-ew (cdr old-ew)
     )
   )
 )
 (if closed
   (setq new-p (reverse (append (cdr (reverse old-p)) new-p)))
   (setq new-p (append (reverse new-p) old-p))
 )
 (setq	new-b  (append (reverse new-b) old-b)
new-sw (append (reverse new-sw) old-sw)
new-ew (append (reverse new-ew) old-ew)
 )
 (entmod
   (append elst
    (apply 'append
	   (apply 'mapcar
		  (cons 'list (list new-p new-sw new-ew new-b))
	   )
    )
   )
 )
)

;;; VEC1 Retourne le vecteur normé (une unité) de direction p1 p2

(defun vec1 (p1 p2 / d)
 (if (not (zerop (setq d (distance p1 p2))))
   (mapcar '(lambda (x1 x2) (/ (- x2 x1) d)) p1 p2)
 )
)

;; BETWEENP Evalue si pt est entre p1 et p2

(defun betweenp	(p1 p2 pt)
 (or (equal p1 pt 1e-9)
     (equal p2 pt 1e-9)
     (equal (vec1 p1 pt) (vec1 pt p2) 1e-9)
 )
)

;; BulgeData Retourne les données d'un polyarc (angle rayon centre)
(defun BulgeData (bu p1 p2 / ang rad)
 (setq	ang (* 2 (atan bu))
rad (/ (distance p1 p2)
       (* 2 (sin ang))
    )
cen (polar p1
	   (+ (angle p1 p2) (- (/ pi 2) ang))
	   rad
    )
 )
 (list (* ang 2.0) rad cen)
)

;; TAN Retourne la tangente de l'angle

(defun tan (ang)
 (/ (sin ang) (cos ang))
)

[Edité le 12/11/2007 par (gile)]

[Edité le 13/11/2007 par (gile)]

Matt666 · le 12 novembre 2007

J'avais fait un peu la même chose en autolisp... Il doit être beaucoup moins performant, mais il fonctionne à peu près ! C'est pas dut tout la même logique...

Faut juste que je le retrouve et je te le montre... Pour me dire ce que tu en penses !

(defun c:OPL (/ )
    (princ "\nSélectionner les polylignes à optimiser : ")
    (setq cmdecho (getvar "cmdecho"))
    (setvar "cmdecho" 0)
    (if (setq sel (ssget))
         (progn
              (command "_UNDO" "D")
              (repeat (setq cn (sslength sel))
                   (setq 
                        ent  (ssname sel (setq cn (1- cn)))
                        dent (entget ent)
                        lst  (remove-doubles (remove-align (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))))
                        
                   )
                   (foreach pt (remove-all lst (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))
                        (setq n (vl-position pt dent))
                        (setq nlst 
                             (append 
                                  (sublist dent 0 n)
                                  (sublist dent (+ n 4) nil)
                             )
                        )
                        (setq dent nlst)
                   )
                   (entmod nlst)
                   (entupd ent)
                   (princ "\nPolyligne optimisée.")
              )
         )
    )
    (command "_UNDO" "F")
    (setvar "cmdecho" cmdecho)
    (princ)
)

;;; SUBLIST De GILE
(defun sublist (lst start leng / n r)
    (if (or   (not leng) 
              (< (- (length lst) start) leng)
         )
         (setq leng (- (length lst) start))
    )
    (setq n (+ start leng))
    (repeat leng
         (setq r (cons (nth (setq n (1- n)) lst) r))
    )
)

;;; REMOVE-ALIGN De GILE
(defun remove-align (lst / rslt)
    (while (caddr lst)
         (if (betweenp (car lst) (caddr lst) (cadr lst))
              (setq lst (cons (car lst) (cddr lst)))
              (setq rslt (cons (car lst) rslt)
                   lst (cdr lst)
              )
         )
    )
    (append (reverse rslt) lst)
)

;;; REMOVE-DOUBLES De GILE
(defun remove-doubles (lst)
    (if lst
         (cons (car lst) (remove-doubles (vl-remove (car lst) lst)))
    )
)

;;; REMOVE-ALL
;;; Supprime tous les éléments d'une liste à partir d'une autre
;;; (REMOVE-ALL '(1 3 5) '(1 2 3 4 5 6 7)) -> (2 4 6 7)
(defun REMOVE-ALL (lise lisc)
    (foreach pt lise (setq lisc (vl-remove pt lisc)))
)

;;; BETWEENP Evalue si pt est entre p1 et p2 (ou égal à)
;;;Lisp de GILE
(defun betweenp (p1 p2 pt)
    (or 
         (equal p1 pt 1e-9)
         (equal p2 pt 1e-9)
         (equal (vec1 p1 pt) (vec1 pt p2) 1e-9)
    )
)

;;; VEC1 Retourne le vecteur normé (1 unité) de p1 à p2 (nil si p1 = p2)
;;;Lisp de GILE
(defun vec1 (p1 p2)
    (if (not (equal p1 p2 1e-009))
         (mapcar '(lambda (x1 x2)
                   (/ (- x2 x1) (distance p1 p2))
              )
              p1
              p2
         )
    )
)

Merci encore pour ce lisp !

A bientot !

Matt.

Edit : Voilà ! Trouvé !

[Edité le 13/11/2007 par Matt666]

lecrabe · le 13 novembre 2007

Hello Gilles

Superbe ! :) :D

Et voici encore Le Decapode "critiqueur", il manque un petit qq chose à cette routine : :o

Dessine une polyligne (en ortho c plus simple) avec un grand segment et revient n'importe ou plusieurs fois sur ce meme segment cliquer de nouveaux points à gauche et à droite avant de repartir à la fin du segment et d'aller ailleurs ...

Tu verras que ta routine n'élimine pas tous les sommets inutiles (redondants) sur le même segment ! :casstet:

Qu'en penses tu !?

Le Decapode "chiant"

[Edité le 13/11/2007 par lecrabe]

(gile) · le 13 novembre 2007

Salut lecrabe,

Tu verras que ta routine n'élimine pas tous les sommets inutiles (redondants) sur le même segment !

C'est voulu, la question s'était posée dans le challenge 12.

Supprimer des sommets alignés mais non interposés peut changer l'allure de la polyligne :

http://img141.imageshack.us/img141/9606/clean3fw1.png

Salut Matt666,

Je pense que c'est la même logique, tu utilises aussi betweenp (dans remove-align), mais ta routine ne tient pas compte des épaisseurs et ne traite pas les points situés sur un même arc (cas certainement extrèmement rare).

lecrabe · le 13 novembre 2007

Hello Gilles

Tu es trop fort, je n'avais pas pensé au cas que tu as dessiné !

Cependant je pense qu'il serait intéressant si tu détectes "ce genre de problème" de poser la question : Nettoyage quand même Oui/Non (A vos risques et périls) et ainsi tout le monde est content :P

En fait c surtout pour des problème en cartographie et les contours de parcelles / bâtiments / ilôts / sections / etc où le cas présenté (par toi) ne DOIT pas exister !

Le Decapode

Matt666 · le 13 novembre 2007

Salut Gile ! Ah oui l'épaisseur ! Pour les arcs à la limite, c'est pas très grave pour moi :) Je comprends parfaitement ton coté perfectionniste :D , tu dois te dire que des cas come ceux ci existent, et qu'il est normal de les prendre en compte... Chapeau bas !

T'es quand même balaise, je n'avais même pas pensé à ce cas là... Ni à l'épaisseur d'ailleurs !!

Bravo pour cette vision d'ensemble d'une routine... Pi pour tout le reste aussi !!

J'essaierai si j'ai le temps d'apporter ces modif au prog..

A bientot !

Matt.

(gile) · le 13 novembre 2007

Alors, plutôt que d'avoir à entrer (ou valider) une option à chaque lancement, j'ai préféré faire une deuxième commande : Ppl.

J'ai aussi :

- changé le mode de sélection, on peut sélectionner plusieurs polylignes

- ajouté un groupe d'annulation

Le code du premier message est mis à jour

http://img207.imageshack.us/img207/2801/cplbi5.png

http://img411.imageshack.us/img411/3931/cpl2mc1.png

lecrabe · le 13 novembre 2007

Hello Gilles

c TIP-TOP MEGA-SUPER !!! :) :D :cool:

Ainsi tout le monde est content y compris ce "foutu Decapode raleur" :P

Encore Merci, Le Decapode

(gile) · le 13 novembre 2007

Ainsi tout le monde est content y compris ce "foutu Decapode raleur"

Je pense que l'immense majorité des utilisateurs (moi compris) préfèreront Ppl, je m'étais laissé obnubilé par les problèmes soulevés dans ce challenge...

Matt666 · le 13 novembre 2007

Je pense que l'immense majorité des utilisateurs (moi compris) préfèreront Ppl

Et bah chu pas forcément d'accord avec toi...

La routine Ppl supprime des bouts d'entités, et ça c'est pas dément je trouve...

Je pense que cette routine sert à nettoyer les polylignes, pas à les modifier..

Mais bon ce n'est que qu'un avis comme un autre !

Et puis comme dis le decapode (enorme ce nom !) :

Ainsi tout le monde est content

A bientot !

Matt.

lecrabe · le 14 novembre 2007

Bon Matin

Non Non, Le Decapode il n'est pas ENORME ni par son nom ni par son poids :)

Je proteste ! :P :casstet:

Humoristiquement, Le Decapode (de 74 kg)

Matt666 · le 14 novembre 2007

Oui, bah t'es plus lourd que moi !!

:)

A bientot, le décapode jovial.. ;)

Matt.

BIM G CO · le 14 novembre 2007

74 kilos, Oh les poids coq

je suis au-delà du quintal

(gile) · le 18 novembre 2007

Juste pour la beauté du geste, avec la même méthode que celle employée ici, les deux fonctions d'appel c:cpl et c:ppl définies en une seule expression.

(mapcar
 (function
   (lambda (fun opt)
     (eval
(list
  'defun-q
  fun
  '(/ ss n)
  '(vl-load-com)
  '(princ
    "\nSélectionnez les polylignes à traiter ou : "
   )
  '(or
    (setq ss (ssget '((0 . "LWPOLYLINE"))))
    (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
   )
  (list	'if
	'ss
	(list 'progn
	      '(vla-StartUndoMark
		(vla-get-ActiveDocument (vlax-get-acad-object))
	       )
	      '(setq n -1)
	      (list 'while
		    '(setq pl (ssname ss (setq n (1+ n))))
		    (list 'CleanPline 'pl opt)
	      )
	      '(princ (strcat "\n\t" (itoa n) " polylignes traitées."))
	      '(vla-EndUndoMark
		(vla-get-ActiveDocument (vlax-get-acad-object))
	       )
	)
	'(princ "\nAucune polyligne sélectionnée.")
  )
  '(princ)
)
     )
   )
 )
 '(c:cpl c:ppl)
 '(nil T)
)

Connexion

Nettoyer les polylignes

Messages recommandés

(gile)

Matt666

lecrabe

(gile)

lecrabe

Matt666

(gile)

lecrabe

(gile)

Matt666

lecrabe

Matt666

BIM G CO

(gile)

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante