purge lignes

Matt666 · le 12 septembre 2007

Monopolisation du forum là... Ca va plus !!!

Encore un truc...

Suite à une discussion ici, j'ai eu une petite idée d'un lisp :

Purger les lignes superposées en fonction d'une sélection.

J'ai commencé, ça donne ça :

 ;;; LINEARP Retourne T si tous les points de la liste sont alignés
;;; Lisp de GILE
(defun linearp (lst)
    (cond
         ((= 2 (length lst)) T)
         ((or (equal (vec1 (car lst) (cadr lst))
                        (vec1 (car lst) (caddr lst))
                        1e-009
                   )
                   (equal (vec1 (car lst) (cadr lst))
                        (vec1 (caddr lst) (car lst))
                        1e-009
                   )
              )
              (linearp (cdr lst))
         )
    )
)

;;; 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
         )
    )
)
;;;Efface les lignes superflues

(defun c:SURFLU ()
    (cond ((setq sel (ssget '((0 . "LINE"))))
              (setq cn 0)
              (while (setq entity (ssname sel (setq cn (1+ cn))))
                   (setq
                        lst1 nil
                        lst1 (cons (cdr (assoc 10 (entget entity))) lst1)
                        lst1 (cons (cdr (assoc 11 (entget entity))) lst1)
                        lst3 nil
                   )
                   (repeat (setq cn2 (sslength sel))
                        (setq 
                             entity2 (ssname sel (setq cn2 (1- cn2)))
                             lst2 nil
                             lst2 (cons (cdr (assoc 10 (entget entity2))) lst2)
                             lst2 (cons (cdr (assoc 11 (entget entity2))) lst2)
                        )
                        (if (linearp (append lst1 lst2))
                             (progn
                                  (if lst3 (setq lst3 (append lst2 lst3))(setq lst3 (append lst1 lst2)))
                                  (entdel entity2)
                                  (ssdel entity2 sel)
                             )
                        )
                   )
                   (if lst3 (progn
                             (setq 
                                  addit (mapcar '(lambda (x) (+ (car x) (cadr x) (caddr x))) lst3)
                                  pt1 (nth (position (car (sort addit '<)) addit) lst3)
                                  pt2 (nth (position (car (sort addit '>)) addit) lst3)
                             )
                             (entdel entity)
                             (entmake (list
                                       (cons 0 "LINE")
                                       (cons 10 pt1)
                                       (cons 11 pt2)
                             ))
                             (entupd (entlast))
                             (princ "\nlignes jointes.")
                   ))
              )
         )
    )
    (redraw)
    (princ)
)

En fin de compte le ssget retourne une liste de points qui, à la condition d'être co-linéaires sont jointes pour ne former qu'une seule ligne.

Le code est loin d'être concis, notamment cette chose là

(setq 
                                  addit (mapcar '(lambda (x) (+ (car x) (cadr x) (caddr x))) lst3)
                                  pt1 (nth (position (car (sort addit '<)) addit) lst3)
                                  pt2 (nth (position (car (sort addit '>)) addit) lst3)
                             )

qui retourne la coordonnée la plus grande et la plus petite...

Bon ça fonctionne pour les lignes superposées. Par contre si deux lignes séparées d'un vide sont colinéaires, il va les joindre aussi !!

Voilà je cherche un moyen de lui faire comprendre de ne pas joindre les lignes non superposées et colinéaires...

Merci !

A bientot.

Matt.

[Edité le 14/9/2007 par Matt666]

LUDWIG · le 12 septembre 2007

et la commande overkill ne t'irait pas ?

Matt666 · le 12 septembre 2007

La commande Overkil... :o Mais qu'est-ce que c'est que ça !!!!

Bah écoute je sais pas !! Je regarde ça demain ! Même si je n'ai pas autocad, je vais regarder...

Merci Ludwig !

A bientôt.

Matt.

Patrick_35 · le 13 septembre 2007

Salut

La commande Overkil... :o Mais qu'est-ce que c'est que ça !!!!

C'est une commande des express tools

@+

(gile) · le 13 septembre 2007

Si tu continues avec ton LISP, 2 petites routines qui peuvent t'être utile.

BETWEENP qui value si le point pt est entre les points p1 et p2 (retourne T ou nil)

;;; Evalue si pt est entre p1 et p2 (ou égal à)

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

EXTRM qui retourne la liste des deux points les plus extrèmes d'une liste de points alignés

;;; Ne conserve que les points aux extrémités d'une liste de points
;;; NOTA : ne fonctionne qu'avec des points alignés.

(defun extrm (plst)
 (if (= 2 (length plst))
   plst
   (cond
     ((betweenp (car plst) (cadr plst) (caddr plst))
      (extrm (cons (car plst) (cons (cadr plst) (cdddr plst))))
     )
     ((betweenp (car plst) (caddr plst) (cadr plst))
      (extrm (cons (car plst) (cons (caddr plst) (cdddr plst))))
     )
     ((betweenp (cadr plst) (caddr plst) (car plst))
      (extrm (cdr plst))
     )
   )
 )
)

Matt666 · le 14 septembre 2007

Merci à vous pour ces réponses !

Je vais quand même essayer de voir avec OVERKILL....

Ai-je le droit de modifier un lisp des express tools et de l'intégrer dans un autre logiciel CAO DAO ? En l'occurence OVERKILL ?

Et puis si je n'y arrive pas je continuerai mon lisp...

Gile, tu as donné une routine permettant de trouver les extrémités d'une liste de points. Crois-tu que ce petit bout de routine fonctionne comme ça aussi ?

 
(setq
addit (mapcar '(lambda (x) (+ (car x) (cadr x) (caddr x))) lst3)
pt1 (nth (position (car (sort addit '<)) addit) lst3)
pt2 (nth (position (car (sort addit '>)) addit) lst3)
)

Il fait l'addition des coordonnées de chaque point, et retourne le plus petit et le plus grand...

Je suis pas sur, quand même ! Ca parait trop simple ;)

A bientot !!

Matt.

[Edité le 14/9/2007 par Matt666]

(gile) · le 14 septembre 2007

Salut,

Il fait l'addition des coordonnées de chaque point, et retourne le plus petit et le plus grand...

L'idée semble intéressante, mais sans y regarder plus en profondeur, il semble bien que ça ne fonctionne pas avec les lignes orientées à 135° : ((1 3) (3 1) (5 -1) (2 2))

(gile) · le 14 septembre 2007

Petites correction améliorations de l'expression ;

(setq
	 addit (mapcar '(lambda (x) (+ (car x) (cadr x) (caddr x)))
		       lst3
	       )
	 pt1   (nth (position (car (sort addit '		 pt2   (nth (position (car (sort addit '>)) addit) lst3)
       )

plutôt que :

(mapcar '(lambda (x) (+ (car x) (cadr x) (caddr x))) lst3)

tu peux faire :

(mapcar '(lambda (x) (apply '+ x)) lst 3)

et plutôt que de trier addit une fois dans un sens, une fois dans l'autre ne la trier q'une fois :

(setq s-addit (sort addit '

et faire :

(setq pt1 (nth (position (car s_addit) addit lst3) pt2 (nth (position (last s_addit) addit lst3))

Mais comme il faut étudier le cas cité plus haut (lignes à 135°), il vaut mieux, je pense, trier directement la liste avec une fonction lambda :

(setq s_lst (vl-sort lst3
	      '(lambda (x1 x2)
		 (or (			   (			 )
	       )
     )
      pt1   (car s_lst)
      pt2   (last s_lst)
)

Matt666 · le 26 septembre 2007

La vache il est drôlement dur ce lisp :D !!!

Je tatonne, mais j'y arriverai !

A bientôt !

Matt.

Matt666 · le 27 septembre 2007

Bon j'ai presque fini, mais là je bute... J'ai une erreur, et je ne vois pas du tout ce que c'est !!!

Si qqn voit, ou sait se servir de la gestion des erreurs de Visual Lisp...

;;; Routine principale
(defun c:kill ( / CMDECHO CN CN2 CN3 ENT ENT2 LST LST2 SEL SSET)
    (setq cmdecho (getvar "cmdecho"))
    (setvar "cmdecho" 0)
    (command "_undo" "d")
    (if (setq sel (ssget '((0 . "LINE"))))
         (progn
              (setq cn 0)
              (setq tot (sslength sel))
              (while (< cn tot)
                   (setq 
                        ent  (ssname sel cn)
                        cn   (1+ cn)
                        lst  nil
                        lst  (cons 
                             (cdr (assoc 10 (entget ent))) 
                             (list (cdr (assoc 11 (entget ent))))
                        )
                        sset sel
                        cn2 0
                        cn3 0
                   )
                   (ssdel ent sset)
                   (while (< cn2 (sslength sset))
                        (setq 
                             ent2 (ssname sset cn2)
                             cn2 (1+ cn2)
                        )
                        (if (linearp (setq lst2 
                                       (append lst (cons 
                                                 (cdr (assoc 10 (entget ent2))) 
                                                 (list (cdr (assoc 11 (entget ent2))))
                                       ))
                             ))
                             (progn
                                  (setq cn3 (1+ cn3))
                                  (if 
                                       (or  (betweenp (car lst) (cadr lst) (caddr lst2))
                                            (betweenp (car lst) (cadr lst) (cadddr lst2))
                                            (member (caddr lst2) lst)
                                            (member (cadddr lst2) lst)
                                       )
                                       (progn 
                                            ;;; départ de la ligne
                                            (entmod (subst 
                                                      (cons 10 (car (extrm lst2)))
                                                      (assoc 10 (entget ent))
                                                      (entget ent)        
                                            ))
                                            ;;; fin de la ligne
                                            (entmod (subst 
                                                      (cons 11 (cadr (extrm lst2)))
                                                      (assoc 11 (entget ent))
                                                      (entget ent)        
                                            ))
                                            (setq 
                                                 cn3 (1+ cn3)
                                                 cn (1- cn) ;;;Repasse la ligne après modif
                                            )
                                            (entdel ent2) ;;; Efface la deuxième ligne
                                       )
                                       ;;;Si une ligne est dans une autre ligne, ou si elles sont exactement superposées
                                       (if (or 
                                                 (and (betweenp (car lst2) (cadr lst2) (caddr lst2))
                                                      (betweenp (car lst2) (cadr lst2) (cadddr lst2))
                                                 )
                                                 (and (member (caddr lst2) lst)
                                                      (member (cadddr lst2) lst)
                                                 )
                                                 
                                            )
                                            (progn
                                                 (entdel ent2)
                                                 (setq cn3 (1+ cn3))
                                            )
                                       )
                                  )
                                  
                             )
                        )
                   )
                   (if (eq cn3 0) (ssdel ent sel)) 
              )
              (princ "\nDessin nettoyé.")
              (redraw)
         )
    )
    (command "_undo" "f")
    (setvar "cmdecho" cmdecho)
    (princ)
)

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

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

;;; Ne conserve que les points aux extrémités d'une liste de points
;;; NOTA : ne fonctionne qu'avec des points alignés.
;;;Lisp de GILE
(defun extrm (plst)
    (if (= 2 (length plst))
         plst
         (cond
              ((betweenp (car plst) (cadr plst) (caddr plst))
                   (extrm (cons (car plst) (cons (cadr plst) (cdddr plst))))
              )
              ((betweenp (car plst) (caddr plst) (cadr plst))
                   (extrm (cons (car plst) (cons (caddr plst) (cdddr plst))))
              )
              ((betweenp (cadr plst) (caddr plst) (car plst))
                   (extrm (cdr plst))
              )
         )
    )
)

;;; LINEARP Retourne T si tous les points de la liste sont alignés
;;; Lisp de GILE
(defun linearp (lst)
    (cond
         ((= 2 (length lst)) T)
         ((or 
                   (equal 
                        (vec1 (car lst) (cadr lst))
                        (vec1 (car lst) (caddr lst))
                        1e-009
                   )
                   (equal 
                        (vec1 (car lst) (cadr lst))
                        (vec1 (caddr lst) (car lst))
                        1e-009
                   )
              )
              (linearp (cdr lst))
         )
    )
)

Merci !

[Edité le 27/9/2007 par Matt666]

Connexion

purge lignes

Messages recommandés

Matt666

LUDWIG

Matt666

Patrick_35

(gile)

Matt666

(gile)

(gile)

Matt666

Matt666

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante