Aller au contenu

Besoin d'aide, Lisp "PLL" à améliorer.


oran

Messages recommandés

Bonjour,

 

J'ai récupéré ce Lisp il y quelques temps maintenant (je remercie son auteur au passage)et je souhaiterai y apporter une petite amélioration mais malheureusement je n'y connais rien en Lisp ...!! ;)

Ce Lisp permet de tracer, par segments, une polyligne de longueur définie. Pour les connaisseurs elle est très utile pour tracer les volumes de sécurité dans les salles de bains.

Seul bémol au moment du tracé aucun "point d'accrochage" n'est validé.

Donc dans un premier temps est-ce possible de rajouter cette option ? Et j'ose abuser en demandant le "repérage polaire" également, dans la mesure du possible bien sûr.

 

Vous en remerciant sincèrement par avance.

 

;; PLL

;; Dessine un polyligne de longueur limitée

(defun c:PLL (/ *error* drawSegment drawPline makePline color

segLen cursor loop points input result maxPt

dist

)

 

;; redéfinition locale de la fonction *error*

(defun *error* (msg)

(and msg

(/= msg "Fonction annulée")

(prompt (strcat "\nErreur: " msg))

)

(grtext)

(redraw)

(princ)

)

 

;; affichage temporaire des segments déjà spécifiés

(defun drawPline (points)

(mapcar

'(lambda (p1 p2) (grdraw p1 p2 color))

points

(cdr points)

)

)

 

;; mise à jour du point extreme et affichage temporaire du dernier segment

(defun drawSegment (basePt dragPt segLen)

(setq maxPt (polar basePt (angle basePt dragPt) segLen))

(if (< (distance basePt dragPt) segLen)

(progn

(grdraw basePt dragPt -1)

(grdraw dragPt maxPt 8 1)

)

(grdraw basePt maxPt -1)

)

)

 

;; création de la polyligne

(defun makePline (points / ucszdir)

(setq ucszdir (trans '(0 0 1) 1 0 T))

(entmakex

(append

(list

(cons 0 "LWPOLYLINE")

(cons 100 "AcDbEntity")

(cons 100 "AcDbPolyline")

(cons 90 (length points))

(cons 70 0)

(cons 38 (caddr (trans '(0 0 0) 1 ucszdir)))

(cons 210 ucszdir)

)

(mapcar

'(lambda (p) (cons 10 (trans p 1 ucszdir)))

points

)

)

)

)

 

;; fonction principale

(sssetfirst nil nil)

(or (numberp *PlineMaxLength*) (setq *PlineMaxLength* 5000.0)) ;_ valeur par défaut initiale

(setq color (cdr (assoc 62 (tblsearch "layer" (getvar 'clayer)))))

(if

(and

(or

(and

(setq

segLen (getdist

(strcat "\nSpécifiez la longueur maximale <" (rtos *PlineMaxLength*) ">: ")

)

)

(setq *PlineMaxLength* segLen)

)

(setq segLen *PlineMaxLength*)

)

(setq basePt (getpoint "\nSpécifiez le premier point: "))

(setq points (cons basePt points)

input ""

loop T

)

)

(progn

(prompt (strcat "\nCliquez le point suivant (longueur restante : " (rtos seglen) "): "))

(while

(and (setq result (grread T 12 0)) loop)

(cond

;; mise à jour en fonction de la position du curseur

((= (car result) 5)

(setq cursor (cadr result))

(redraw)

(drawPline points)

(drawSegment (car points) cursor segLen)

)

;; clic gauche

((= 3 (car result))

(setq dist (distance (car points) cursor))

(if (< dist segLen)

(progn

(setq points (cons cursor points)

segLen (- segLen dist)

)

(prompt (strcat "\nCliquez le point suivant ou validez (longueur restante : " (rtos seglen) "): "))

)

(progn

(makePline (cons maxPt points))

(setq loop nil)

)

)

)

;; validation

((or (equal result '(2 13)) ;_ Entrée

(equal result '(2 32)) ;_ Espace

(= (car result) 25) ;_ clic droit

)

(makePline points)

(setq loop nil)

)

)

)

)

)

(*error* nil)

)

Lien vers le commentaire
Partager sur d’autres sites

Coucou

 

Du fait de l'utilisation de la fonction (grread) il ne va pas être possible d'utiliser l'accrochage aux objets sans alourdir notoirement le code (qui l'est déjà)

Du côté de chez LeeMac tu as quelque chose d'existant mais je laisse la main par manque de temps

Je te donne la piste de recherche...

 

Dans ton cas un cercle ferait l'affaire..., non ?

 

Amicalement

Lien vers le commentaire
Partager sur d’autres sites

Invité
Répondre à ce sujet…

×   Collé en tant que texte enrichi.   Coller en tant que texte brut à la place

  Seulement 75 émoticônes maximum sont autorisées.

×   Votre lien a été automatiquement intégré.   Afficher plutôt comme un lien

×   Votre contenu précédent a été rétabli.   Vider l’éditeur

×   Vous ne pouvez pas directement coller des images. Envoyez-les depuis votre ordinateur ou insérez-les depuis une URL.

×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité