Quantitatif sur Polylignes optimisées

[VDH-Bruno]

Bonsoir,

 

Voici, ma première "vrai" routine Lisp, tout d’abord je tiens à remercier les membres de ce forum qui par leurs interventions ici et là ont grandement contribué à sa réalisation.

 

Le principe est simple le programme demande de sélectionner une polylignes (optimisées), et renvoi deux traitement différent suivant le type de polylignes sélectionnées (traitement correspondant à mes besoins et à l’organisation de mes dessins).

 

Après chargement

Taper qlwp

 

Si vous sélectionné une polyligne ouverte (c.a.d. code DXF 70 à 0)

Il vous sera retourné en résultat l’ensemble de tous les segments des polylignes de même calque, couleur et de même espace que l’entité sélectionné. Les longueurs identiques seront comptabilisées et classées par ordre croissant.

 

Si vous sélectionné une polyligne fermée (c.a.d. code DXF 70 à 1)

Il vous sera retourné en résultat la longueur du plus grand segment composant chaque polyligne de même calque, couleur et de même espace que l’entité sélectionné. Les longueurs identiques seront comptabilisées et classées par ordre croissant.

 

Voilà j’ai bien conscience que les résultats, ainsi que le code est perfectible, mais je m’en tiendrai là pour le moment. Car les résultats retournés semblent tenir la route pour mon organisation de dessin et pour l’utilité que j’en ai (Au vu d’un nombre très restreint de teste).

 

En espérant que cela puisse profiter à d’autres.

Amicalement

VDH

 

Le code

 ;; ====================================================================
;; qlwp-v2.lsp by Vandenheede Bruno
;; le 12/10/2010
;; Réalise un quantitatif sur les lwp sélectionnées
;; --------------------------------------------------------------------
;; Variables
;;   Ent     -> Liste (codes dxf de l'entité LWP sélectionné)
;;   Sel     -> Jeu de sélection (des éléments à traiter)
;;   N       -> Entier (Compteur)
;;   LstLong -> Liste (Liste de toutes les Longueurs)
;;   LongEnt -> Liste (Liste de Longueur pour un élément)
;;   Routine -> USUBR (Mémorise la routine de traitement à lancer)

(defun c:qlwp (/	Ent	 Sel	  N	   LongEnt  LstLong
       Coul	Aff	 Element  Descr	   File	    listseg
       longseg	tri	 Tri&Comp
      )
 (vl-load-com)

 ;; ==============Déclaration des Sous Programmes ====================
 ;; ==================================================================
 ;; Routine Liste la longueur de tous les segments de LWP
 ;; Argument -> Un Non d'entité
 ;; Retourne -> Une Liste (tous les segments de la LWP)
 ;; ------------------------------------------------------------------
 ;; Observation:
 ;;   Je ne juge pas nécessaire l'ajout du 1er sommet à la fin de la liste
 ;;   dans le cas d'une LWP close, le faire pour une fonction plus général.
 ;;   De même je n'ai pas exclus du traitement les polylignes avec arc alors
 ;;   que la fonction ne gère pas ce cas (à traiter dans le cas d'une fonction
 ;;   plus général).

 (defun listseg (NomEnt / LstPt x Long LstLong)
   ;; Liste les sommets de la LWPOLYLIGNE (code cadxp)
   (setq LstPt
   (mapcar 'cdr
	   (vl-remove-if-not
	     '(lambda (x) (= (car x) 10))
	     (entget NomEnt)
	   ) ;_ Fin de vl-remove-if-not
   ) ;_ Fin de mapcar
   ) ;_ Fin de setq
   ;; Tant qu'un sommet suit mesurer la distance entre le 1er et 2nd sommet
   (while (cdr LstPt)
     (setq Long (distance (car LstPt) (cadr LstPt)))
     ;; Si la Liste de long existe
     (if LstLong
;; Alors ajouté la longueur du nième segment
(setq LstLong (append LstLong (list Long)))
;; Sinon crée une list avec le 1er élément calculer
(setq LstLong (list Long))
     ) ;_ Fin de if
     (setq LstPt (cdr LstPt))
   ) ;_ Fin de while
   LstLong				; Valeur de retour
 ) ;_ Fin de defun

 ;; ==================================================================
 ;; Routine d'extration du segment de lwp le plus long
 ;; Argument -> Un Non d'entité
 ;; Retourne -> Une liste (longueur de plus grand segment)
 ;; -----------------------------------------------------------------
 ;; Observation:
 ;;   Je n'ai pas exclus pas du traitement les polylignes avec arc
 ;;   alors que la fonctionne gère pas ce cas (à traiter dans le
 ;;   cadre d'une fonction plus général).
 ;;   Rq (> 10 nil) retourne T alors que (> 10 T) erreur

 (defun longseg (NomEnt / ListPt x Long)
   ;; Liste les sommets de la LWPOLYLIGNE
   (setq ListPt
   (mapcar 'cdr
	   (vl-remove-if-not
	     '(lambda (x) (= (car x) 10))
	     (entget NomEnt)
	   ) ;_ Fin de vl-remove-if-not
   ) ;_ Fin de mapcar
   ) ;_ Fin de setq
   ;; Ajout du 1er sommet en fin de liste de point 
   (setq ListPt (append ListPt (list (car ListPt))))
   ;; Tant qu'un sommet suit mesurer la distance entre le 1er et 2nd sommet
   (while (cdr ListPt)
     (if (> (distance (car ListPt) (cadr ListPt)) Long)
(setq Long (distance (car ListPt) (cadr ListPt)))
     ) ;_ Fin de if
     (setq ListPt (cdr ListPt))
   ) ;_ Fin de while
   (setq Long (list long))		; Valeur de retour
 ) ;_ Fin de defun

 ;; ==================================================================
 ;; Trie dans l'ordre croissant et compte les identiques
 ;; Argument -> Liste de réel
 ;; Retourne -> Liste croissante de réel ((N1 . L1) (N2 . L2) etc..)
 ;; ------------------------------------------------------------------

 ;; tri (Evgeniy Elpanov)
 ;; comme vl-sort mais sans supprimer les doublons
 (defun tri (lst fun)
   (mapcar (function (lambda (x) (nth x lst)))
    (vl-sort-i lst fun)
   ) ;_ Fin de mapcar
 ) ;_ Fin de defun

 ;; Tri&Comp modifié by (gile)
 ;; http://www.cadxp.com//modules.php?op=modload&name=XForum&file=viewthread&fid=100&tid=29749
 (defun Tri&Comp (lst / sub)
   (defun sub (lst n)
     (if (cadr lst)
(if (equal (car lst) (cadr lst))
  (sub (cdr lst) (1+ n))
  (cons (cons n (car lst)) (sub (cdr lst) 1))
) ;_ Fin de if
(list (cons n (car lst)))
     ) ;_ Fin de if
   ) ;_ Fin de defun
   (sub (tri lst '<) 1)
 ) ;_ Fin de defun

;;; ==================== Fin Sous Programmes ======================

;;; =============== Début du Progamme Principal ===================

 ;; Sélection du type d'élément à métrer
 (setq	Ent (entget
      (car (entsel "Pointer une des polylignes à métrer: "))
    ) ;_ Fin de entget
 ) ;_ Fin de setq

 ;; Vérification du type d'entité sélectionné
 (if (= (cdr (assoc 0 Ent)) "LWPOLYLINE")

   ;; Si c'est une LWPOLYLINE continuer l'execution du programme
   (progn
     (setq
Sel (ssget "X"			; Crée le jeu de sélection
	   (list '(0 . "LWPOLYLINE")
		 (assoc 8 Ent)
		 (if (cdr (assoc 62 Ent))
		   (setq Coul (assoc 62 Ent))
		   (setq Coul '(62 . 256))
		 ) ;_ Fin de if
		 (assoc 410 Ent)
	   ) ;_ Fin de list
    ) ;_ Fin de ssget
N   0				; Initialise un compteur
     ) ;_ Fin de setq

     ;; Visualise la sélection par "grip"
     (sssetfirst nil Sel)

     ;; Si la lwp (Ent) de référence et fermé (70 . 1)
     (if (= (cdr (assoc 70 Ent)) 1)
;; Appliquer USUBR: longseg (liste le + grd seg de chaque lwp)
(setq Routine longseg)
;; Sinon USUBR: listseg (liste tous les segments de lwp)
(setq Routine listseg)
     ) ;_ Fin de if

     ;; Parcours la sélection élémt par élémt (tant qu'il y en a)
     (while (ssname Sel N)
(setq LongEnt (Routine (ssname Sel N)))

;; Si la Liste de long existe
(if LstLong
  ;; Alors ajouté la liste du nième élément
  (setq LstLong (append LstLong LongEnt))
  ;; Sinon créé une liste avec la 1ère liste calculer
  (setq LstLong LongEnt)
) ;_ Fin de if
(setq n (1+ n))			; passe à l'élément suivant
     ) ;_ Fin de while

     ;; Affichage provisoire avant traitement des résultats
     (princ "\n")
     (princ "\n Liste de toutes les longueurs mesuré :")
     (princ "\n")
     (princ LstLong)
     (princ "\n")

     ;; Affichage des résultats
     ;; Code inspiré et adapté du lisp long_line by (gile)
     (setq Aff "")
     (setq Descr (strcat
	    "\nCalque.................\t"
	    (cdr (assoc 8 Ent))
	    "\nCouleur................\t"
	    (itoa (cdr Coul))
	    "\nNombre de segments.....\t"
	    (itoa (length LstLong))
	    "\nLongueur total.........\t"
	    (rtos (apply '+ LstLong))
	    "\nLongueur moyenne.......\t"
	    (rtos (/ (apply '+ LstLong) (length LstLong)))
	    "\n"
	    "\nDétail des résultats...\t"
	    (foreach Element (Tri&Comp LstLong)
	      (setq Aff	(strcat	Aff
				"\n\t"
				(itoa (car Element))
				"\t"
				(rtos (cdr Element))
			) ;_ Fin de strcat
	      ) ;_ Fin de setq
	    ) ;_ Fin de foreach
	  ) ;_ Fin de strcat
     ) ;_ Fin de setq
     (textscr)
     (princ Descr)
     (initget "Oui Non")
     (if (= (getkword
       "\nEnregistrer dans un fichier ? [Oui/Non] < Non >: "
     ) ;_ Fin de getkword
     "Oui"
  ) ;_ Fin de =
(progn
  (setq
    File
     (open
       (getfiled "Créez ou sélectionnez un fichier" "" "xls" 33)
       "a"
     ) ;_ Fin de open
  ) ;_ Fin de setq
  (princ Descr File)
  (close File)
) ;_ Fin de progn
     ) ;_ Fin de if
     (graphscr)
   ) ;_ Fin de progn

   ;; Sinon quitter en affichant un message d'alert
   (princ
     "\nL'élément sélectionné n'est pas une polyligne optimisée !"
   ) ;_ Fin de princ
 ) ;_ Fin de if
 (princ)				; Termine silencieusement
) ;_ Fin de defun
;; ==================================================================

Précision : Dans le cas de longueurs très sensiblement égal (d’une précision supérieur à celle de l’affichage), les éléments sont comptés séparément même si à l’affichage ils semblent avoir une longueur identique. Je m’en accommode pour le moment, peut être une amélioration futur auquel cas il faudra que je réfléchisse à la précision que je veux atteindre dans l’exploitation des résultats.

 

 

 

[Edité le 12/10/2010 par VDH-Bruno]