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

[oran]

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)

)

[didier]

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

[oran]

Merci de ta réponse,

 

Effectivement le cercle fait bien partie de la solution mais je t'invite à faire une recherche "volumes de sécurité

douche" sur GOOGLE, tu te rendras mieux compte et sûrement plus simple qu'un explication.

Merci encore,

Sylvain

[oran]

Super, trouvé sur LeeMac

TotalLengthPolylineV1-0.lsp

Exactement ce que je recherche,

Merci bcp

Sylvain