Dessiner un trapèze

gile · le 21 avril 2005

Autodidacte et débutant en AutoLISP je soumets cette routine à la critique.

Tous les commentaires sont évidemmment les bienvenus.

;;; 20/04/05  Fonction TRAPEZE  - Gilles Chanteau -
;;;
;;; c:trapeze Crée une polyligne fermée décrivant un quadrilatère trapézoïdal.
;;; Permet à l'utilisateur de spécifier la largeur entre les deux côtés parallèles (hauteur du trapèze).
;;; Demande respectivement pour chacun des autres côtés, un point à un des sommets (indifféremment
;;; sur l'une ou l'autre base) et, à ce sommet, l'angle formé par ce côté avec l'axe des X.
;;; Cette fonction a été créée pour tracer les pièces rectilignes dont les coupes en bout ne sont
;;; pas d'équerre (écharpes, jambes de force, goussets et autres "diagos") utilisées en menuiserie,
;;; charpente, serrurerie...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; TRAPEZE_ERR Redéfinition de *error*

;;; ferme le groupe "UNDO" et restaure la valeur initiale des variables.

(defun TRAPEZE_ERR (msg)
 (if (or
(= msg "Fonction annulée")
(= msg "quitter / sortir abandon")
     )
   (princ)
   (princ (strcat "\nErreur: " msg))
 )
 (command "_undo" "_end")
 (rest_var)
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

;;; TRPZ_ERR - Envoie un message explicatif et quitte l'application.

(defun TRPZ_ERR	(msg)
 (princ (strcat "\nErreur: " msg))
 (exit)
)

;;; EQUALKPI - Évalue si un angle est égal à k pi radians à 0.000000001 près.

(defun EQUALKPI	(ang)
 (or
   (equal (rem ang pi) 0 1e-009)
   (equal (abs (rem ang pi)) pi 1e-009)
 )
)

;;; ACOS Retourne l'arc cosinus du nombre, en radians

(defun ACOS (num)
 (if (<= -1 num 1)
   (atan (sqrt (- 1 (expt num 2))) num)
   (princ
     "\nErreur: L'argument pour ACOS doit être compris entre -1 et 1"
   )
 )
)

;;; REST_VAR & SAVE_VAR
;;;
;;; SAVE_VAR Enregistre la valeur initiale des variables système dans une liste associative
(defun save_var (lst)
 (setq varlist (mapcar '(lambda (x) (cons x (getvar x))) lst))
)
;;; REST_VAR Restaure leurs valeurs initiales aux variables système de la liste SAVE_VAR
(defun rest_var ()
 (foreach pair	varlist
   (if	(/= (getvar (car pair)) (eval (cdr pair)))
     (setvar (car pair) (eval (cdr pair)))
   )
 )
 (setq varlist nil)
)

;;; C:TRAPEZE - Fonction principale

(defun c:trapeze (/ pt1 pt2 pt3 pt4 a0 a1 a2 a3 a4 alpha)
 (setq	m:err	*error*
*error*	TRAPEZE_ERR
 )
 (save_var '("orthomode" "cmdecho" "osmode"))
 (command "_undo" "_begin")
 (setvar "orthomode" 0)
 (setvar "cmdecho" 0)
 (princ "trapeze")

 ;; Saisie des données
 (if (not (numberp *larg*))
   (setq *larg* 10)
 )
 (while (not
   (setq pt1 (getpoint
	       (strcat "\nLa largeur courante est de "
		       (rtos *larg*)
		       "\nSpécifiez le premier sommet ou <Largeur>: "
	       )
	     )
   )
 )
   (initget 6)
   (setq *larg* (getdist "\nSpécifiez la largeur: "))
 )
 (setq a1 (getangle pt1 "\nSpécifiez l'angle décrit par ce côté: "))
 (initget 1)
 (setq pt2 (getpoint pt1 "\nSpécifiez le second sommet: "))
 (if (not (equal (caddr pt1) (caddr pt2) 1e-009))
   (TRPZ_ERR
     "les sommets ne sont pas dans un plan parallèle au SCU courant."
   )
 )
 (setq a2 (getangle pt2 "\nSpécifiez l'angle décrit par ce côté: "))

 ;; Conversion des données
 (setq	a0  (angle pt1 pt2)
pt3 (polar pt1 a1 *larg*)
pt4 (polar pt2 a2 *larg*)
 )
 (foreach n '(a1 a2)
   (set n (- (eval n) a0))
   (if	(minusp (eval n))
     (set n (+ (eval n) (* 2 pi)))
   )
   (if	(EQUALKPI (eval n))
     (TRPZ_ERR "un des côtés est aligné avec les sommets.")
   )
 )
 (setvar "osmode" 0)

 ;; Évaluation de la position des côtés par rapport aux deux sommets spécifiés
 (if (or
(and (< 0 a1 pi) (< 0 a2 pi))
(and (< pi a1 (* 2 pi)) (< pi a2 (* 2 pi)))
     )

   ;; Calcul des autres sommets si les premiers sont situés sur une base du trapèze
   (setq pt3 (polar pt1 (+ a0 a1) (/ *larg* (abs (sin a1))))
  pt4 pt2
  pt2 (polar pt2 (+ a0 a2) (/ *larg* (abs (sin a2))))
   )

   ;; Calcul des autres sommets si les premiers sont situés sur une diagonale du trapèze
   (if	(> *larg* (distance pt1 pt2))
     (TRPZ_ERR "la largeur est plus grande que la diagonale.")
     (progn
(setq alpha (ACOS (/ *larg* (distance pt1 pt2))))
(if (< a1 pi)
  (setq	a3 (- alpha a1)
	a4 (- alpha a2 pi)
  )
  (setq	a3 (+ alpha a1)
	a4 (+ alpha a2 pi)
  )
)
(foreach n (list a3 a4)
  (if (equal (cos n) 0 1e-009)
    (TRPZ_ERR "un des côtés est aligné avec une des bases.")
  )
)
(setq pt3 (polar pt1 (+ a0 a1) (/ *larg* (cos a3)))
      pt4 (polar pt2 (+ a0 a2) (/ *larg* (cos a4)))
)
     )
   )
 )

 ;; Création de la polyligne, si les données le permettent
 (if (inters pt1 pt3 pt2 pt4 T)
   (TRPZ_ERR "intersection des côtés (polygone croisé).")
   (command "_pline" pt1 pt3 pt2 pt4 "_c")
 )
 (command "_undo" "_end")
 (rest_var)
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

Tramber · le 21 avril 2005

Marche pas chez moi.

Déjà, dans le premier while, y a une erreur.

L'option Largeur n'est pas accessible.

Manque un initget

,....

sinon, sans vouloir activer cette option, je n'obtiens qu'une poly écrasée.

Manque de protection dans le choix des angles ?

faut que je lise les commentaires mais il manque des protections.

En tous cas, c'est bien écrit pour un débutant (sauvegardes variables, erreurs,...applause)

gile · le 21 avril 2005

L'option largeur est accessible en tapant "enter" au lieu de spécifier le premier point.

Pour les angles, il faut les specifier en degrés ou directement avec le pointeur.

Tramber · le 21 avril 2005

A y est !

Bien sur L pour Largeur ne marchait pas .

Et, sous condition d'angle, ca marche.

Cool.

Jettes un coup d'oeil sur grread

gile · le 21 avril 2005

Merci Tramber

Mon anglais est vraiment trop pauvre, je ne comprend pas l'utilté de la fonction grread ni comment elle fonctionne.

Est-ce que tu suggère de l'utiliser à la place de getangle ?

Tramber · le 21 avril 2005

Regarde le code de Zebulon_

Sinon, fais "Rechercher dans les forums" GRREAD, y a eu des messages sympas sur cette fonction ;)

[Edité le 21/4/2005 par Tramber]

gile · le 21 avril 2005

Super, je vais apprendre un nouvelle fonction.

Là comme çà, je ne vois pas immédiatement l'intérêt pour le code ci-dessus, mais je vais creuser la question.

En tous cas, merci encore !

Tramber · le 21 avril 2005

Me suis trompé pour le lien vers le code, je confonds, je ne le retrouve plus.

autre lien

gile · le 26 avril 2005

Manque de protection dans le choix des angles ?

Effectivement il faut rajouter un (initget 1) avant chaque (getangle).

Sinon pour comprendre comment çà marche un petit dessin vaut mieux qu'un long discours

bonuscad · le 28 avril 2005

Voici une ébauche de ce qu'on pourrait faire avec (ggread)

La routine permettra de dessiner un trapeze en forme de "tronc de triangle" , c'est à dire quel les angles seront déterminés par la position du curseur.

Enfin le mieux c'est d'essayer!

C'est le corps principal, tout ceci peut être amélioré, gestions d'erreurs , accrobjet avec (grread)....

(defun c:trapeze ( / )
(setq ptx (getpoint "\nSpécifiez le point de base du trapèze: "))
(setq pt_ext (getpoint ptx "\nSpécifiez l'extrémité de la grande base: "))
(grvecs (list ptx pt_ext))
(setq h (getdist (list (/ (+ (car ptx) (car pt_ext)) 2) (/ (+ (cadr ptx) (cadr pt_ext)) 2) (/ (+ (caddr ptx) (caddr pt_ext)) 2)) "\nSpécifiez la hauteur du trapèze: "))
(princ "\nSpécifiez le point déterminant les angles du trapèze.")
(while (and (setq key (grread T 4 0)) (/= (car key) 3))
	(cond
		((eq (car key) 5)
			(redraw)
			(setq
				v1 (mapcar '- ptx pt_ext)
				v2 (mapcar '- (cadr key) ptx)
				det_or (apply '(lambda (x1 y1 z1 x2 y2 z2) (- (* x1 y2) (* y1 x2))) (append v1 v2))
			)
			(cond
				((< det_or 0.0) (setq ang_sp (/ pi 2)))
				((> det_or 0.0) (setq ang_sp (- (/ pi 2))))
				(T (setq ang_sp nil))
			)
			(cond
				(ang_sp
					(setq
						p1b (polar ptx (+ (angle ptx pt_ext) ang_sp) h)
						p2b (polar pt_ext (+ (angle ptx pt_ext) ang_sp) h)
						p1 (inters p1b p2b ptx (cadr key) nil)
						p2 (inters p1b p2b pt_ext (cadr key) nil)
					)
					(grvecs
						(list
							ptx pt_ext
							pt_ext p2
							p2 p1
							p1 ptx
						)
					)
				)
			)
		)
	)
)
(prin1)
)

gile · le 28 avril 2005

Merci bonuscad,

çà marche ton truc, mais l'intérêt de ma fonction est de pouvoir choisir les sommets indifféremment sur la même base ou chacun sur une base différente (sur la diagonale).

C'est utile pour dessiner une pièce de triangulation dont on connait la position des deux sommets opposés. Encore une fois, un dessin vaut mieux qu'un long discours.

Tramber · le 28 avril 2005

Eh Gile,

fais pas le timide :

http://img244.echo.cx/img244/7372/trapeze5yv.jpg

Faut mettre l'adresse de l'image entre les 2 balises image(img) mais en supprimant tout ESPACE.

gile · le 30 avril 2005

Ouf, çà y est !

Ce fut laborieux, mais j'ai réussi à intégrer (grread) dans la fonction trapèze.

Juste un truc, pour que çà fonctionne dans un plan en élévation par rapport au plan XY du SCU je jongle avec le SCU et je ne trouve pas çà très élégant. Y a peut être moyen avec (trans) mais je n'y suis pas arrivé, si quelqu'un a une idée...

En tous cas un gros merci à Bonuscad, Patrick_35, Tramber et les autres...

;;; GR-OSMODE Piqué à Bonuscad

(defun gr-osmode (pt-i str-md /	n pt md	rap pt1	pt2 pt3	pt4 pt5	pt6 pt7	pt8 pt56 pt67 pt78 pt85
	  one_o)
 (setq n (/ (cadr (getvar "screensize")) 5.0))
 (setq pt (osnap pt-i str-md))
 (while (and (eq (strlen (setq md (substr str-md 1 4))) 4)
      (not one_o)
 )
   (repeat 3
     (setq
rap  (/ (getvar "viewsize") n)
pt1  (list (- (car pt) rap) (- (cadr pt) rap) (caddr pt))
pt2  (list (+ (car pt) rap) (- (cadr pt) rap) (caddr pt))
pt3  (list (+ (car pt) rap) (+ (cadr pt) rap) (caddr pt))
pt4  (list (- (car pt) rap) (+ (cadr pt) rap) (caddr pt))
pt5  (list (car pt) (- (cadr pt) rap) (caddr pt))
pt6  (list (+ (car pt) rap) (cadr pt) (caddr pt))
pt7  (list (car pt) (+ (cadr pt) rap) (caddr pt))
pt8  (list (- (car pt) rap) (cadr pt) (caddr pt))
pt56 (polar pt (- (/ pi 4.0)) rap)
pt67 (polar pt (/ pi 4.0) rap)
pt78 (polar pt (- pi (/ pi 4.0)) rap)
pt85 (polar pt (+ pi (/ pi 4.0)) rap)
n    (- n 16)
     )
     (if (equal (osnap pt-i md) pt)
(setq one_o T)
     )
     (cond
((and (eq "_end" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt2 pt3 1)
 (grdraw pt3 pt4 1)
 (grdraw pt4 pt1 1)
)
((and (eq "_mid" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt2 pt7 1)
 (grdraw pt7 pt1 1)
)
((and (eq "_cen" md) one_o)
 (grdraw pt5 pt56 1)
 (grdraw pt56 pt6 1)
 (grdraw pt6 pt67 1)
 (grdraw pt67 pt7 1)
 (grdraw pt7 pt78 1)
 (grdraw pt78 pt8 1)
 (grdraw pt8 pt85 1)
 (grdraw pt85 pt5 1)
 (grdraw pt5 pt7 7)
 (grdraw pt6 pt8 7)
)
((and (eq "_nod" md) one_o)
 (grdraw pt5 pt56 1)
 (grdraw pt56 pt6 1)
 (grdraw pt6 pt67 1)
 (grdraw pt67 pt7 1)
 (grdraw pt7 pt78 1)
 (grdraw pt78 pt8 1)
 (grdraw pt8 pt85 1)
 (grdraw pt85 pt5 1)
 (grdraw pt1 pt3 1)
 (grdraw pt2 pt4 1)
)
((and (eq "_qua" md) one_o)
 (grdraw pt5 pt6 1)
 (grdraw pt6 pt7 1)
 (grdraw pt7 pt8 1)
 (grdraw pt8 pt5 1)
)
((and (eq "_int" md) one_o)
 (grdraw pt1 pt3 1)
 (grdraw pt2 pt4 1)
)
((and (eq "_ins" md) one_o)
 (grdraw pt5 pt2 1)
 (grdraw pt2 pt6 1)
 (grdraw pt6 pt8 1)
 (grdraw pt8 pt4 1)
 (grdraw pt4 pt7 1)
 (grdraw pt7 pt5 1)
)
((and (eq "_per" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt1 pt4 1)
 (grdraw pt8 pt 1)
 (grdraw pt pt5 1)
)
((and (eq "_tan" md) one_o)
 (grdraw pt5 pt56 1)
 (grdraw pt56 pt6 1)
 (grdraw pt6 pt67 1)
 (grdraw pt67 pt7 1)
 (grdraw pt7 pt78 1)
 (grdraw pt78 pt8 1)
 (grdraw pt8 pt85 1)
 (grdraw pt85 pt5 1)
 (grdraw pt3 pt4 1)
)
((and (eq "_nea" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt2 pt4 1)
 (grdraw pt4 pt3 1)
 (grdraw pt3 pt1 1)
)
     )
   )
   (setq str-md (substr str-md 6)
  n	 (/ (cadr (getvar "screensize")) 5.0)
   )
 )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GR_TRAPEZE Fonction principale avec GRREAD et ENTMAKE
(defun c:gr_trapeze (/ o mode pt1 pt2 pt3 pt4 pta2	a0 a1 a01 a2 a02 a3 a4 alpha key lst)
 (vl-load-com)
 (vla-startundomark
   (vla-get-activedocument (vlax-get-acad-object))
 )
 (setq	m:err	*error*
*error*	gr_trpz_err
 )
 (setq o (getvar "osmode"))
 (if (or (zerop o) (= (logand o 16384) 16384))
   (setq mod "_none")
   (progn
     (setq mod "")
     (mapcar
'(lambda (xi xs)
   (if (not (zerop (logand o xi)))
     (if (zerop (strlen mod))
       (setq mod (strcat mod xs))
       (setq mod (strcat mod "," xs))
     )
   )
 )
'(1 2 4 8 16 32 64 128 256 512)
'("_end" "_mid"	"_cen" "_nod" "_qua" "_int" "_ins" "_per" "_tan" "_nea")
     )
   )
 )
 (if (not (numberp *larg*))
   (setq *larg* 10)
 )
 (while (not
   (setq pt1 (getpoint
	       (strcat "\nLa largeur courante est de "
		       (rtos *larg*)
		       "\nSpécifiez le premier sommet ou <Largeur>: "
	       )
	     )
   )
 )
   (initget 6)
   (setq *larg* (getdist "\nSpécifiez la largeur: "))
 )
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (if (not (equal (caddr pt1) 0 1e-009))
   (progn
     (setq scu_init T
    old_echo (getvar "cmdecho")
    h        (caddr pt1)
     )
     (setvar "cmdecho" 0)
     (command "_ucs" "_move" "z" (caddr pt1))
     (setq pt1 (list (car pt1) (cadr pt1) 0.0))
   )
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (initget 1)
 (setq a1 (getangle pt1 "\nSpécifiez l'angle décrit par ce côté: "))
 (prompt "\nSpécifiez le second sommet: ")
 (while
   (and (setq key (grread T 4 0)) (/= (car key) 3))
    (cond
      ((eq (car key) 5)
(redraw)
(setq pt2   (cadr key)
      a0    (angle pt1 pt2)
      a01   (- a1 a0)
      alpha (acos (/ *larg* (distance pt1 pt2)))
)
(if (and (/= mod "_none") (osnap pt2 mod))
  (gr-osmode pt2 mod)
)
(if (minusp a01)
  (setq a01 (+ a01 (* 2 pi)))
)
(cond
  ((< a01 pi) (setq a3 (- alpha a01)))
  ((> a01 pi) (setq a3 (+ alpha a01)))
  (T (setq a3 nil))
)
(cond
  (a3
   (setq pt3 (polar pt1 a1 (/ *larg* (cos a3))))
   (grvecs (list pt1 pt2 pt2 pt3 pt3 pt1))
  )
)
      )
    )
 )
 (if (osnap pt2 mod)
   (setq pt2 (osnap pt2 mod))
 )
 (setq	a0    (angle pt1 pt2)
alpha (acos (/ *larg* (distance pt1 pt2)))
 )
 (prompt "\nSpécifiez l'angle décrit par ce côté: ")
 (while
   (and (setq key (grread T 4 0)) (/= (car key) 3))
    (cond
      ((eq (car key) 5)
(redraw)
(setq pta2 (cadr key))
(if (and (/= mod "_none") (osnap pta2 mod))
  (gr-osmode pta2 mod)
)
(setq a2  (angle pt2 pta2)
      a01 (- a1 a0)
      a02 (- a2 a0)
)
(foreach n '(a01 a02)
  (if (minusp (eval n))
    (set n (+ (eval n) (* 2 pi)))
  )
)
(cond
  ((or (and (< 0 a01 pi) (< 0 a02 pi))
       (and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi)))
   )
   (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01))))
	 pt4 (polar pt2 a2 (/ *larg* (abs (sin a02))))
	 lst (list pt1 pt2 pt2 pt4 pt4 pt3 pt3 pt1)
   )
  )
  ((or (and (< 0 a01 pi) (< pi a02 (* 2 pi)))
       (and (< pi a01 (* 2 pi)) (< 0 a02 pi))
   )
   (cond
     ((< a01 pi) (setq a4 (- alpha a02 pi)))
     ((> a01 pi) (setq a4 (+ alpha a02 pi)))
     (T (setq a4 nil))
   )
   (setq pt4 (polar pt2 a2 (/ *larg* (cos a4)))
	 lst (list pt1 pt3 pt3 pt2 pt2 pt4 pt4 pt1)
   )
  )
)
(grvecs lst)
      )
    )
 )
 (if (osnap pta2 mod)
   (setq pta2 (osnap pta2 mod))
 )
 (setq	a2  (angle pt2 pta2)
a02 (- a2 a0)
 )
 (if (minusp a02)
   (setq a02 (+ a02 (* 2 pi)))
 )
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (if scu_init
   (progn
     (foreach n '(pt1 pt2 pt3 pt4)
(set n (trans (eval n) 1 0))
     )
     (command "_ucs" "_prev")
     (setvar "cmdecho" old_echo)
     (foreach n '(pt1 pt2 pt3 pt4)
(set n (trans (eval n) 0 1))
     )
     (setq old_echo nil
    scu_init nil
     )
   )
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (if
   (or	(and (< 0 a01 pi) (< 0 a02 pi))
(and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi)))
   )
    (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01))))
   pt4 (polar pt2 a2 (/ *larg* (abs (sin a02))))
   lst (list pt1 pt2 pt4 pt3)
    )
    (progn
      (if (< a01 pi)
 (setq a3 (- alpha a01)
       a4 (- alpha a02 pi)
 )
 (setq a3 (+ alpha a01)
       a4 (+ alpha a02 pi)
 )
      )
      (setq pt3 (polar pt1 a1 (/ *larg* (cos a3)))
     pt4 (polar pt2 a2 (/ *larg* (cos a4)))
     lst (list pt1 pt3 pt2 pt4)
      )
    )
 )
 (entmake
   (list '(0 . "LWPOLYLINE")
  '(100 . "AcDbEntity")
  '(100 . "AcDbPolyline")
  '(90 . 4)
  '(70 . 1)
  (cons 38 (- (caddr pt1) (caddr (trans '(0 0) 0 1))))
  (cons 10 (trans (nth 0 lst) 1 (extr_dir)))
  (cons 10 (trans (nth 1 lst) 1 (extr_dir)))
  (cons 10 (trans (nth 2 lst) 1 (extr_dir)))
  (cons 10 (trans (nth 3 lst) 1 (extr_dir)))
  (cons 210 (extr_dir))
   )
 )
 (redraw)
 (vla-endundomark
   (vla-get-activedocument (vlax-get-acad-object))
 )
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EXTR_DIR Retourne la direction d'extrusion du SCU courant

(defun EXTR_DIR	(/ vec org)
 (mapcar '- (trans '(0 0 1) 1 0) (trans '(0 0 0) 1 0))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ACOS Retourne l'arc cosinus du nombre, en radians

(defun ACOS (num)
 (if (<= -1 num 1)
   (atan (sqrt (- 1 (expt num 2))) num)
   (princ
     "\nErreur: L'argument pour ACOS doit être compris entre -1 et 1"
   )
 )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GR_TRPZ_ERR

(defun gr_trpz_err (msg)
 (if (or
(= msg "Fonction annulée")
(= msg "quitter / sortir abandon")
     )
   (princ)
   (princ (strcat "\nErreur: " msg))
 )
 (if scu_init
   (progn
     (command "_ucs" "_prev")
     (setvar "cmdecho" old_echo)
     (setq old_echo nil
    scu_init nil
     )
   )
 )
 (vla-endundomark
   (vla-get-activedocument (vlax-get-acad-object))
 )
 (setq	*error*	m:err
m:err nil
 )
)

Tramber · le 1 mai 2005

C'est très intéressant.

Applaudissements au "débutant" qui n'en est plus un.

bonuscad · le 2 mai 2005

J'applause aussi,

Si tu débute, on peut dire que tu assimiles très vite, car ton lisp à l'air de bien tenir la route pour les souhaits que tu avais formulé. Sans l'avoir testé à fond, j'ai quand même remarqué que tu es passé par les fonctions trigo que tu as controler (divizion par zéro) pour l'orientation , mais oublié d'appliqué pour (grvecs) ce qui fait planter la routine si le curseur se retrouve à un endroit innaproprié pendant ses déplacements. (J'ai préféré utiliser (inters) pour ne pas avoir à faire de test sur les fonctions trigos)

Mis à part ce petit souci que tout pourra certainement corriger, tu peut dire que tu 'as fait un bon outil.

Sans vouloir te faire de l'ombre, je me permet de monter une solution plus aboutie que la précédente. Elle fonctionne à l'instard de la commande rectangle (options d'elevation, hauteur (2D-1/2), raccord ou chanfrein et largeur de "trait" et la possibilté de rentrer les dimensions (longueur des 2 bases et hauteur, dans ce cas un "tronc" de triangle isocèle est mis en place)

En dynamique si l'accrobj est actif possibilité de taper la longueur pour mettre en place par rapport à l'orientation accrochée ou simplement valider la dernière longueur utilisée)

Je penses qu'on aura droit bientot d'autre réalisations, encore BRAVO ;)

NB:Je ne suis aussi qu'un programmeur qui laisse certainement la possibilité de bugs dans mon code

(defun gr-osmode (pt-i str-md / n pt md rap pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt56 pt67 pt78 pt85 one_o)
(setq n (/ (cadr (getvar "screensize")) 5.0))
(setq pt (osnap pt-i str-md))
(while (and (eq (strlen (setq md (substr str-md 1 4))) 4) (not one_o))
	(repeat 2
		(setq
			rap (/ (getvar "viewsize") n)
			pt1 (list (- (car pt) rap) (- (cadr pt) rap) (caddr pt))
			pt2 (list (+ (car pt) rap) (- (cadr pt) rap) (caddr pt))
			pt3 (list (+ (car pt) rap) (+ (cadr pt) rap) (caddr pt))
			pt4 (list (- (car pt) rap) (+ (cadr pt) rap) (caddr pt))
			pt5 (list (car pt) (- (cadr pt) rap) (caddr pt))
			pt6 (list (+ (car pt) rap) (cadr pt) (caddr pt))
			pt7 (list (car pt) (+ (cadr pt) rap) (caddr pt))
			pt8 (list (- (car pt) rap) (cadr pt) (caddr pt))
			pt56 (polar pt (- (/ pi 4.0)) rap)
			pt67 (polar pt (/ pi 4.0) rap)
			pt78 (polar pt (- pi (/ pi 4.0)) rap)
			pt85 (polar pt (+ pi (/ pi 4.0)) rap)
			n (- n 16)
		)
		(if (equal (osnap pt-i md) pt) (setq one_o T))
		(cond
			((and (eq "_end" md) one_o)
				(grdraw pt1 pt2 1) (grdraw pt2 pt3 1) (grdraw pt3 pt4 1) (grdraw pt4 pt1 1)
			)
			((and (eq "_mid" md) one_o)
				(grdraw pt1 pt2 1) (grdraw pt2 pt7 1) (grdraw pt7 pt1 1)
			)
			((and (eq "_cen" md) one_o)
				(grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1)
				(grdraw pt5 pt7 7) (grdraw pt6 pt8 7)
			)
			((and (eq "_nod" md) one_o)
				(grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1)
				(grdraw pt1 pt3 1) (grdraw pt2 pt4 1)
			)
			((and (eq "_qua" md) one_o)
				(grdraw pt5 pt6 1) (grdraw pt6 pt7 1) (grdraw pt7 pt8 1) (grdraw pt8 pt5 1)
			)
			((and (eq "_int" md) one_o)
				(grdraw pt1 pt3 1) (grdraw pt2 pt4 1)
			)
			((and (eq "_ins" md) one_o)
				(grdraw pt5 pt2 1) (grdraw pt2 pt6 1) (grdraw pt6 pt8 1) (grdraw pt8 pt4 1) (grdraw pt4 pt7 1) (grdraw pt7 pt5 1)
			)
			((and (eq "_per" md) one_o)
				(grdraw pt1 pt2 1) (grdraw pt1 pt4 1) (grdraw pt8 pt 1) (grdraw pt pt5 1)
			)
			((and (eq "_tan" md) one_o)
				(grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1)
				(grdraw pt3 pt4 1)
			)
			((and (eq "_nea" md) one_o)
				(grdraw pt1 pt2 1) (grdraw pt2 pt4 1) (grdraw pt4 pt3 1) (grdraw pt3 pt1 1)
			)
		)
	)
	(setq str-md (substr str-md 6) n (/ (cadr (getvar "screensize")) 5.0))
)
)
(defun c:trapeze_dyn ( / o mod ptx key p1 p2 pt_ext a_dir l1 l2 h f f2 e th w v1 v2 det_or ang_sp p1b p2b)
(setq o (getvar "osmode"))
(if (or (zerop o) (eq (boole 1 o 16384) 16384))
	(setq mod "_none")
	(progn
		(setq mod "")
		(mapcar
			'(lambda (xi xs)
				(if (not (zerop (boole 1 o xi)))
					(if (zerop (strlen mod))
						(setq mod (strcat mod xs))
						(setq mod (strcat mod "," xs))
					)
				)
			)
			'(1 2 4 8 16 32 64 128 256 512)
			'("_end" "_mid" "_cen" "_nod" "_qua" "_int" "_ins" "_per" "_tan" "_nea")
		)
	)
)
(initget 1 "COtes CHanfrein Elévation Raccord Hauteur Largeur _Dimensions Chamfer Elevation Fillet Thickness Width")
(while (not (listp (setq ptx (getpoint "\nSpécifiez le point de base du trapèze ou [COtes/CHanfrein/Elévation/Raccord/Hauteur/Largeur]: "))))
	(cond
		((eq ptx "Dimensions")
			(setq l1 (getdist (strcat "\nLongueur de la 1ère base du trapèze <" (rtos (getvar "USERR1")) ">:")))
			(if l1 (setvar "USERR1" l1) (setq l1 (getvar "USERR1")))
			(setq l2 (getdist (strcat "\nLongueur de la 2ème base du trapèze <" (rtos (getvar "USERR2")) ">:")))
			(if l2 (setvar "USERR2" l2) (setq l2 (getvar "USERR2")))
			(setq h (getdist (strcat "\nHauteur du trapèze <" (rtos (getvar "USERR3")) ">:")))
			(if h (setvar "USERR3" h) (setq h (getvar "USERR3")))
		)
		((eq ptx "Chamfer")
			(setq f (getdist (strcat "\nSpécifiez l'écart du premier chanfrein des trapèzes <" (rtos (getvar "CHAMFERA")) ">: ")))
			(if f (setvar "CHAMFERA" f))
			(setq f2 (getdist (strcat "\nSpécifiez l'écart du deuxième chanfrein des trapèzes <" (rtos (getvar "CHAMFERB")) ">: ")))
			(if f2 (setvar "CHAMFERB" f2))
			(setvar "USERS1" "#CHAMFER")
		)
		((eq ptx "Elevation")
			(setq e (getdist (strcat "\nSpécifiez l'élévation des trapèzes <" (rtos (getvar "ELEVATION")) ">: ")))
			(if e (setvar "ELEVATION" e))
		)
		((eq ptx "Fillet")
			(setq f (getdist (strcat "\nSpécifiez le rayon du raccord des trapèzes <" (rtos (getvar "FILLETRAD")) ">: ")) f2 nil)
			(if f (setvar "FILLETRAD" f))
			(setvar "USERS1" "")
		)
		((eq ptx "Thickness")
			(setq th (getdist (strcat "\nSpécifiez la hauteur des trapèzes <" (rtos (getvar "THICKNESS")) ">: ")))
			(if th (setvar "THICKNESS" th))
		)
		((eq ptx "Width")
			(setq w (getdist (strcat "\nSpécifiez la largeur de ligne des trapèzes <" (rtos (getvar "PLINEWID")) ">: ")))
			(if w (setvar "PLINEWID" w))
		)
	)
	(initget 1 "COtes CHanfrein Elévation Raccord Hauteur Largeur _Dimensions Chamfer Elevation Fillet Thickness Width")
)
(if (and (not l1) (not l2) (not h))
	(progn
		(setq pt_ext (getpoint ptx (strcat "\nSpécifiez l'extrémité de la 1ère base <" (rtos (getvar "USERR1")) ">:")))
		(if (null pt_ext)
			(progn
				(setq pt_ext (osnap (cadr (grread T)) mod))
				(if pt_ext
					(setq
						pt_ext (list (car pt_ext) (cadr pt_ext) (caddr ptx))
						pt_ext (polar ptx (angle ptx pt_ext) (getvar "USERR1"))
						l1 (distance ptx pt_ext)
						a_dir (angle ptx pt_ext)
					)
					(setq
						a_dir (angle ptx (cadr (grread T)))
						pt_ext (polar ptx a_dir (getvar "USERR1"))
					)
				)
			)
			(setq
				pt_ext (list (car pt_ext) (cadr pt_ext) (caddr ptx))
				l1 (distance ptx pt_ext)
				a_dir (angle ptx pt_ext)
			)
		)
		(if l1 (setvar "USERR1" l1) (setq l1 (getvar "USERR1")))
		(grvecs (list ptx pt_ext))
		(setq h (getdist (list (/ (+ (car ptx) (car pt_ext)) 2) (/ (+ (cadr ptx) (cadr pt_ext)) 2) (caddr ptx)) (strcat "\nSpécifiez la hauteur du trapèze <" (rtos (getvar "USERR3")) ">:")) loop T value "")
		(if h (setvar "USERR3" h) (setq h (getvar "USERR3")))
		(princ (strcat "\nSpécifiez le point déterminant le 1er angle du trapèze <" (angtos (getvar "USERR4")) ">: "))
		(while (and (setq key (grread T 4 0)) (/= (car key) 3) loop)
			(cond
				((eq (car key) 5)
					(redraw)
					(if (and (/= mod "_none") (osnap (cadr key) mod))
						(progn
							(gr-osmode (cadr key) mod)
							(setq key (list (car key) (list (car (osnap (cadr key) mod)) (cadr (osnap (cadr key) mod)) (caddr ptx))))
						)
						(setq key (list (car key) (list (caadr key) (cadadr key) (caddr ptx))))
					)
					(setq
						v1 (mapcar '- ptx pt_ext)
						v2 (mapcar '- (cadr key) ptx)
						det_or (apply '(lambda (x1 y1 z1 x2 y2 z2) (- (* x1 y2) (* y1 x2))) (append v1 v2))
					)
					(cond
						((< det_or 0.0) (setq ang_sp (/ pi 2)))
						((> det_or 0.0) (setq ang_sp (- (/ pi 2))))
						(T (setq ang_sp nil))
					)
					(cond
						(ang_sp
							(setq
								p1b (polar ptx (+ (angle ptx pt_ext) ang_sp) h)
								p2b (polar pt_ext (+ (angle ptx pt_ext) ang_sp) h)
								p1 (inters p1b p2b ptx (cadr key) nil)
							)
							(if p1 (grvecs
								(list
									ptx pt_ext
									pt_ext p2b
									p2b p1
									p1 ptx
									1 ptx (cadr key)
								)
							))
						)
					)
				)
				((or (member key '((2 13) (2 32))) (eq (car key) 25))
					(if (and (not (zerop (strlen value))) (or (eq (type (read value)) 'INT) (eq (type (read value)) 'REAL)))
						(setvar "USERR4" (angtof value))
					)
					(setq
						p1 (polar ptx (+ a_dir (getvar "USERR4")) (/ h (sin (getvar "USERR4"))))
						p2b (polar pt_ext (- (+ a_dir pi) (getvar "USERR4")) (/ h (sin (getvar "USERR4"))))
						loop nil
					)
					(grvecs
						(list
							ptx pt_ext
							pt_ext p2b
							p2b p1
							p1 ptx
						)
					)
					(princ "\n")
				)
				(T
					(if (eq (cadr key) 8)
						(progn
							(setq value (substr value 1 (1- (strlen value))))
							(princ (chr 8)) (princ (chr 32))
						)
						(setq value (strcat value (chr (cadr key))))
					)
					(princ (chr (cadr key)))
				)
			)
		)
		(setq  loop T value "")
		(princ (strcat "\nSpécifiez le point déterminant le 2ème angle du trapèze <" (angtos (getvar "USERR5")) ">: "))
		(while (and (setq key (grread T 4 0)) (/= (car key) 3) loop)
			(cond
				((eq (car key) 5)
					(redraw)
					(if (and (/= mod "_none") (osnap (cadr key) mod))
						(progn
								(gr-osmode (cadr key) mod)
								(setq key (list (car key) (list (car (osnap (cadr key) mod)) (cadr (osnap (cadr key) mod)) (caddr ptx))))
						)
						(setq key (list (car key) (list (caadr key) (cadadr key) (caddr ptx))))
					)
					(setq
						p2b (polar pt_ext (+ (angle ptx pt_ext) ang_sp) h)
						p2 (inters p1b p2b pt_ext (cadr key) nil)
					)
					(if p2 (grvecs
						(list
							ptx pt_ext
							pt_ext p2
							p2 p1
							p1 ptx
							1 pt_ext (cadr key)
						)
					))
				)
				((or (member key '((2 13) (2 32))) (eq (car key) 25))
					(if (and (not (zerop (strlen value))) (or (eq (type (read value)) 'INT) (eq (type (read value)) 'REAL)))
						(setvar "USERR5" (angtof value))
					)
					(setq
						p2 (polar pt_ext (- (+ a_dir pi) (getvar "USERR5")) (/ h (sin (getvar "USERR5"))))
						loop nil
					)
					(grvecs
						(list
							ptx pt_ext
							pt_ext p2
							p2 p1
							p1 ptx
						)
					)
					(princ "\n")
				)
				(T
					(if (eq (cadr key) 8)
						(progn
							(setq value (substr value 1 (1- (strlen value))))
							(princ (chr 8)) (princ (chr 32))
						)
						(setq value (strcat value (chr (cadr key))))
					)
					(princ (chr (cadr key)))
				)
			)
		)
		(redraw)
	)
	(progn
		(setq
			pt_ext (list (+ (car ptx) l1) (cadr ptx) (caddr ptx))
			p1 (list (+ (car ptx) (/ (- l1 l2) 2.0)) (+ (cadr ptx) h) (caddr ptx))
			p2 (list (+ (car ptx) l2 (/ (- l1 l2) 2.0)) (+ (cadr ptx) h) (caddr ptx))
		)
	)
)
(if (not (zerop (getvar "ELEVATION"))) (setq e (getvar "ELEVATION")))
(setq th (getvar "THICKNESS")  w (getvar "PLINEWID"))
(if (eq (getvar "USERS1") "#CHAMFER") (setq f (getvar "CHAMFERA") f2 (getvar "CHAMFERB")) (setq f (getvar "FILLETRAD") f2 nil))
(cond
	((and ptx pt_ext p1 p2)
		(setvar "USERR1" (distance ptx pt_ext))
		(setvar "USERR2" (distance p1 p2))
		(setvar "USERR3" h)
		(setvar "USERR4" (- (angle ptx p1) (angle ptx pt_ext)))
		(setvar "USERR5" (- (angle pt_ext ptx) (angle pt_ext p2)))
		(setvar "cmdecho" 0)
		(command "_.undo" "_group")
		(setvar "osmode" 0)
		(command "_.pline" ptx "_width" w w (list (car ptx) (cadr ptx)) (list (car pt_ext) (cadr pt_ext)) (list (car p2) (cadr p2)) (list (car p1) (cadr p1)) "_close")
		(cond
			((and f f2)
				(setvar "trimmode" 1)
				(command "_.chamfer" "_polyline" (entlast))
			)
			((and f (not f2))
				(setvar "trimmode" 1)
				(command "_.fillet" "_polyline" (entlast))
			)
		)
		(if e (command "_.change" (entlast) "" "_properties" "_elevation" e ""))
		(if th (command "_.change" (entlast) "" "_properties" "_thickness" th ""))
		(setvar "osmode" o)
		(command "_.undo" "_end")
		(setvar "cmdecho" 1)
		(if (not a_dir) (command "_.rotate" (entlast) "" "_none" ptx))
	)
)
(prin1)
)

Code modifié à l'édition: Les angles peuvent être introduits au clavier ou graphiquement et leur valeur peuvent reservir à la prochaine utilisation.

<font class=edite>[Edité le 13/5/2005 par bonuscad]</font>

gile · le 2 mai 2005

Merci encore, Bonuscad

Sans vouloir te faire de l'ombre

T'inquiètes pas, à Marseille , on la craint pas, l'ombre...

...Souvent même, on la cherche !

C'est vrai que j'ai livré une routine un peu brute de décoffrage, je n'y avais même pas intégré les protections existantes dans la première version (pas dynamique, voir tout en haut).

Je vérifie bien tout et retravaille un peu le style avant de rendre une copie définitive.

gile · le 4 mai 2005

Voilà le code "définitif" (enfin, j'espère)

Il me semble tenir la route : protections, gestion des erreurs, saisie possible au clavier ou à l'écran...

C'est une version "passe-partout" sans fonctions vlisp ni (ai_setCmdEcho)

;;; Fonction TRAPEZE avec affichage dynamique 04/05/05

;;; GR-OSMODE Piqué à Bonuscad, affichage des modes d'accrochage aux objets

(defun gr-osmode (pt-i str-md /	n pt md	rap pt1	pt2 pt3	pt4 pt5	pt6 pt7	pt8 pt56 pt67 pt78 pt85
	  one_o)
 (setq n (/ (cadr (getvar "screensize")) 5.0))
 (setq pt (osnap pt-i str-md))
 (while (and (eq (strlen (setq md (substr str-md 1 4))) 4)
      (not one_o)
 )
   (repeat 3
     (setq
rap  (/ (getvar "viewsize") n)
pt1  (list (- (car pt) rap) (- (cadr pt) rap) (caddr pt))
pt2  (list (+ (car pt) rap) (- (cadr pt) rap) (caddr pt))
pt3  (list (+ (car pt) rap) (+ (cadr pt) rap) (caddr pt))
pt4  (list (- (car pt) rap) (+ (cadr pt) rap) (caddr pt))
pt5  (list (car pt) (- (cadr pt) rap) (caddr pt))
pt6  (list (+ (car pt) rap) (cadr pt) (caddr pt))
pt7  (list (car pt) (+ (cadr pt) rap) (caddr pt))
pt8  (list (- (car pt) rap) (cadr pt) (caddr pt))
pt56 (polar pt (- (/ pi 4.0)) rap)
pt67 (polar pt (/ pi 4.0) rap)
pt78 (polar pt (- pi (/ pi 4.0)) rap)
pt85 (polar pt (+ pi (/ pi 4.0)) rap)
n    (- n 16)
     )
     (if (equal (osnap pt-i md) pt)
(setq one_o T)
     )
     (cond
((and (eq "_end" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt2 pt3 1)
 (grdraw pt3 pt4 1)
 (grdraw pt4 pt1 1)
)
((and (eq "_mid" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt2 pt7 1)
 (grdraw pt7 pt1 1)
)
((and (eq "_cen" md) one_o)
 (grdraw pt5 pt56 1)
 (grdraw pt56 pt6 1)
 (grdraw pt6 pt67 1)
 (grdraw pt67 pt7 1)
 (grdraw pt7 pt78 1)
 (grdraw pt78 pt8 1)
 (grdraw pt8 pt85 1)
 (grdraw pt85 pt5 1)
 (grdraw pt5 pt7 7)
 (grdraw pt6 pt8 7)
)
((and (eq "_nod" md) one_o)
 (grdraw pt5 pt56 1)
 (grdraw pt56 pt6 1)
 (grdraw pt6 pt67 1)
 (grdraw pt67 pt7 1)
 (grdraw pt7 pt78 1)
 (grdraw pt78 pt8 1)
 (grdraw pt8 pt85 1)
 (grdraw pt85 pt5 1)
 (grdraw pt1 pt3 1)
 (grdraw pt2 pt4 1)
)
((and (eq "_qua" md) one_o)
 (grdraw pt5 pt6 1)
 (grdraw pt6 pt7 1)
 (grdraw pt7 pt8 1)
 (grdraw pt8 pt5 1)
)
((and (eq "_int" md) one_o)
 (grdraw pt1 pt3 1)
 (grdraw pt2 pt4 1)
)
((and (eq "_ins" md) one_o)
 (grdraw pt5 pt2 1)
 (grdraw pt2 pt6 1)
 (grdraw pt6 pt8 1)
 (grdraw pt8 pt4 1)
 (grdraw pt4 pt7 1)
 (grdraw pt7 pt5 1)
)
((and (eq "_per" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt1 pt4 1)
 (grdraw pt8 pt 1)
 (grdraw pt pt5 1)
)
((and (eq "_tan" md) one_o)
 (grdraw pt5 pt56 1)
 (grdraw pt56 pt6 1)
 (grdraw pt6 pt67 1)
 (grdraw pt67 pt7 1)
 (grdraw pt7 pt78 1)
 (grdraw pt78 pt8 1)
 (grdraw pt8 pt85 1)
 (grdraw pt85 pt5 1)
 (grdraw pt3 pt4 1)
)
((and (eq "_nea" md) one_o)
 (grdraw pt1 pt2 1)
 (grdraw pt2 pt4 1)
 (grdraw pt4 pt3 1)
 (grdraw pt3 pt1 1)
)
     )
   )
   (setq str-md (substr str-md 6)
  n	 (/ (cadr (getvar "screensize")) 5.0)
   )
 )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; C:TRAPEZE Fonction Trapèze avc grread et entmake 

(defun c:trapeze (/ old_echo o mode pt1	pt2 pt3	pt4 pta2 a0 a1 a01 a2 a02 a3 a4	alpha key value	lst)
 (setq	m:err	*error*
*error*	GR_TRPZ_ERR
 )
 (command "_undo" "_begin")
 (setq old_echo (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 (princ "Trapeze")
 ;; Accrochage aux objets
 (setq o (getvar "osmode"))
 (if (or (zerop o) (= (logand o 16384) 16384))
   (setq mod "_none")
   (progn
     (setq mod "")
     (mapcar
'(lambda (xi xs)
   (if (not (zerop (logand o xi)))
     (if (zerop (strlen mod))
       (setq mod (strcat mod xs))
       (setq mod (strcat mod "," xs))
     )
   )
 )
'(1 2 4 8 16 32 64 128 256 512)
'("_end" "_mid"	"_cen" "_nod" "_qua" "_int" "_ins" "_per" "_tan" "_nea")
     )
   )
 )
 ;; Saisie classique
 (if (not (numberp *larg*))
   (setq *larg* 10)
 )
 (while (not
   (setq pt1 (getpoint
	       (strcat "\nLa largeur courante est de "
		       (rtos *larg*)
		       "\nSpécifiez le premier sommet ou <Largeur>: "
	       )
	     )
   )
 )
   (initget 6)
   (setq *larg* (getdist "\nSpécifiez la largeur: "))
 )
;;; Si pt1 n'est pas danx le plan XY du SCU courant ;;;;;;;;;
 (if (not (equal (caddr pt1) 0 1e-009))		    ;
   (progn						    ;
     (setq scu_init T					    ;
    h (caddr pt1)				    ;
     )							    ;
     (command "_ucs" "_move" "z" (caddr pt1))		    ;
     (setq pt1 (list (car pt1) (cadr pt1) 0.0))	    ;
   )							    ;
 )							    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (initget 1)
 (setq a1 (getangle pt1 "\nSpécifiez l'angle décrit par ce côté: "))
 (prompt "\nSpécifiez le second sommet: ")
 ;; Affichage dynamique pour la saisie de pt2
 (setq	loop T
value ""
 )
 (while
   (and (setq key (grread T 4 0)) (/= (car key) 3) loop)
    (cond
      ((eq (car key) 5)
(redraw)
(setq pt2 (cadr key))
(if (and (/= mod "_none") (osnap pt2 mod))
  (gr-osmode pt2 mod)
)
(setq pt3 (polar pt1 a1 *larg*))
(grvecs (list pt1 pt2 pt2 pt3 pt3 pt1))
      )
      ((or (member key '((2 13) (2 32))) (eq (car key) 25))
(if (and (not (zerop (strlen value)))
	 (POINTP (STR->PT value))
    )
  (setq pt2 (STR->PT value))
)
(setq loop nil)
      )
      (T
(if (eq (cadr key) 8)
  (progn
    (setq value (substr value 1 (1- (strlen value))))
    (princ (chr 8))
    (princ (chr 32))
  )
  (setq value (strcat value (chr (cadr key))))
)
(princ (chr (cadr key)))
      )
    )
 )
 ;; Redétermination des points après accrochage aux objets ou saisie au clavier
 (if (osnap pt2 mod)
   (setq pt2 (osnap pt2 mod))
 )
 (setq	a0  (angle pt1 pt2)
a01 (- a1 a0)
 )
 (if (minusp a01)
   (setq a01 (+ a01 (* 2 pi)))
 )
 (if (EQUALKPI a01)
   (TRPZ_ERR "un des côtés est aligné avec les sommets.")
 )
 (if (not (equal (caddr pt1) (caddr pt2) 1e-009))
   (TRPZ_ERR
     "les sommets ne sont pas dans un plan parallèle au SCU courant."
   )
 )
 (prompt "\nSpécifiez l'angle décrit par ce côté: ")
 ;; Affichage dynamique pour la saisie de a2
 (setq	loop T
value ""
 )
 (while
   (and (setq key (grread T 4 0)) (/= (car key) 3) loop)
    (cond
      ((eq (car key) 5)
(redraw)
(setq pta2 (cadr key))
(if (and (/= mod "_none") (osnap pta2 mod))
  (gr-osmode pta2 mod)
)
(setq a2  (angle pt2 pta2)
      a02 (- a2 a0)
)
(if (minusp a02)
  (setq a02 (+ a02 (* 2 pi)))
)
(cond
  ((or
     (and (< 0 a01 pi) (< 0 a02 pi))
     (and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi)))
   )
   (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01))))
	 pt4 (polar pt2 a2 (/ *larg* (abs (sin a02))))
   )
   (grvecs (list pt1 pt2 pt2 pt4 pt4 pt3 pt3 pt1))
  )
  ((or
     (and (< 0 a01 pi) (< pi a02 (* 2 pi)))
     (and (< pi a01 (* 2 pi)) (< 0 a02 pi))
   )
   (cond
     ((<= *larg* (distance pt1 pt2))
      (setq alpha (acos (/ *larg* (distance pt1 pt2))))
      (if (< a01 pi)
	(setq a3 (- alpha a01)
	      a4 (- alpha a02 pi)
	)
	(setq a3 (+ alpha a01)
	      a4 (+ alpha a02 pi)
	)
      )
      (cond
	((and (not (EQUALKPI (+ a3 (/ pi 2))))
	      (not (EQUALKPI (+ a4 (/ pi 2))))
	 )
	 (setq pt3 (polar pt1 a1 (/ *larg* (cos a3)))
	       pt4 (polar pt2 a2 (/ *larg* (cos a4)))
	 )
	 (grvecs (list pt1 pt3 pt3 pt2 pt2 pt4 pt4 pt1))
	)
      )
     )
   )
  )
)
      )
      ((or (member key '((2 13) (2 32))) (eq (car key) 25))
(if (and (not (zerop (strlen value)))
	 (or (eq (type (read value)) 'INT)
	     (eq (type (read value)) 'REAL)
	 )
    )
  (setq	a2   (/ (* pi (read value)) 180)
	loop nil
	pta2 nil
  )
)
      )
      (T
(if (eq (cadr key) 8)
  (progn
    (setq value (substr value 1 (1- (strlen value))))
    (princ (chr 8))
    (princ (chr 32))
  )
  (setq value (strcat value (chr (cadr key))))
)
(princ (chr (cadr key)))
      )
    )
 )
 ;; Calcul définitif après accrochage aux objets ou saisie au clavier
 (if (and pta2 (osnap pta2 mod))
   (setq pta2 (osnap pta2 mod)
  a2   (angle pt2 pta2)
   )
 )
 (setq a02 (- a2 a0))
 (if (minusp a02)
   (setq a02 (+ a02 (* 2 pi)))
 )
 (if (EQUALKPI a02)
   (TRPZ_ERR "un des côtés est aligné avec les sommets.")
 )
;;; Si pt1 n'est pas danx le plan XY du SCU courant ;;;;;;;;;
 (if scu_init						    ;
   (progn						    ;
     (foreach n '(pt1 pt2 pt3 pt4)			    ;
(set n (trans (eval n) 1 0))			    ;
     )							    ;
     (command "_ucs" "_prev")				    ;
     (foreach n '(pt1 pt2 pt3 pt4)			    ;
(set n (trans (eval n) 0 1))			    ;
     )							    ;
     (setq scu_init nil)				    ;
   )							    ;
 )							    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (if
   (or
     (and (< 0 a01 pi) (< 0 a02 pi))
     (and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi)))
   )
    (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01))))
   pt4 (polar pt2 a2 (/ *larg* (abs (sin a02))))
   lst (list pt1 pt2 pt4 pt3)
    )
    (if (< (distance pt1 pt2) *larg*)
      (TRPZ_ERR "la largeur est plus grande que la diagonale.")
      (progn
 (setq alpha (acos (/ *larg* (distance pt1 pt2))))
 (if (< a01 pi)
   (setq a3 (- alpha a01)
	 a4 (- alpha a02 pi)
   )
   (setq a3 (+ alpha a01)
	 a4 (+ alpha a02 pi)
   )
 )
 (if (or
       (equal (cos a3) 0 1e-009)
       (equal (cos a4) 0 1e-009)
     )
   (TRPZ_ERR "un des côtés est aligné avec une des bases.")
   (setq pt3 (polar pt1 a1 (/ *larg* (cos a3)))
	 pt4 (polar pt2 a2 (/ *larg* (cos a4)))
	 lst (list pt1 pt3 pt2 pt4)
   )
 )
      )
    )
 )
 (entmake
   (list '(0 . "LWPOLYLINE")
  '(100 . "AcDbEntity")
  '(100 . "AcDbPolyline")
  '(90 . 4)
  '(70 . 1)
  (cons 38 (- (caddr pt1) (caddr (trans '(0 0) 0 1))))
  (cons 10 (trans (nth 0 lst) 1 (extr_dir)))
  (cons 10 (trans (nth 1 lst) 1 (extr_dir)))
  (cons 10 (trans (nth 2 lst) 1 (extr_dir)))
  (cons 10 (trans (nth 3 lst) 1 (extr_dir)))
  (cons 210 (extr_dir))
   )
 )
 (redraw)
 (command "_undo" "_end")
 (setvar "cmdecho" old_echo)
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

;;; Sous-routines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; EXTR_DIR Retourne la direction d'extrusion du SCU courant

(defun EXTR_DIR	(/ vec org)
 (mapcar '- (trans '(0 0 1) 1 0) (trans '(0 0 0) 1 0))
)

;;; ACOS Retourne l'arc cosinus du nombre, en radians

(defun ACOS (num)
 (if (<= -1 num 1)
   (atan (sqrt (- 1 (expt num 2))) num)
   (princ
     "\nErreur: L'argument pour ACOS doit être compris entre -1 et 1"
   )
 )
)

;;; EQUALKPI - Évalue si un angle est égal à k pi radians à 0.000000001 près.

(defun EQUALKPI	(ang)
 (or
   (equal (rem ang pi) 0 1e-009)
   (equal (abs (rem ang pi)) pi 1e-009)
 )
)

;;; POINTP - Évalue si l'élément est un point

(defun POINTP (ele)
 (and
   (EVERY 'numberp ele)
   (<= 2 (length ele) 3)
 )
)

;;; Vérifie si tous les membres d'une liste retournent T comme résultat à l'exécution d'une fonction
;;; (EVERY 'numberp '(10 5.5 0)) -> T  (fonction vlisp -> vl-every)

(defun EVERY (fun lst)
 (and
   (vl-consp lst)
   (apply '= (cons T (mapcar fun lst)))
 )
)

;;; Chaine non vide ?

(defun stringp (s)
 (and (= 'STR (type s))
      (/= s "")
 )
)

;;; STR->PT Transforme une chaine en point
;;; ex : (str->pt "20,15") -> (20.0 15.0 0.0)

(defun str->pt (str / n s l c)
 (setq	n (1+ (strlen str))
s ""
 )
 (while (< 0 (setq n (1- n)))
   (setq c (substr str n 1))
   (if	(= c ",")
     (if (stringp s)
(setq l	(cons s l)
      s	""
)
     )
     (setq s (strcat c s))
   )
 )
 (if (stringp s)
   (setq l (cons s l))
 )
 (trans (mapcar 'read l) 0 0)
)

;;; TRPZ_ERR - Envoie un message explicatif et quitte l'application.

(defun TRPZ_ERR	(msg)
 (princ (strcat "\nErreur: " msg))
 (exit)
)

;;; GR_TRPZ_ERR

(defun gr_trpz_err (msg)
 (if (or
(= msg "Fonction annulée")
(= msg "quitter / sortir abandon")
     )
   (princ)
   (princ (strcat "\nErreur: " msg))
 )
 (redraw)
 (if scu_init
   (progn
     (command "_ucs" "_prev")
     (setq scu_init nil
     )
   )
 )
 (command "_undo" "_end")
 (setvar "cmdecho" old_echo)
 (setq	*error*	m:err
m:err nil
 )
)

gile · le 4 mai 2005

Oups...

J'ai laissé passer un appel à une fonction vlisp.

;;; Vérifie si tous les membres d'une liste retournent T comme résultat à l'exécution d'une fonction
;;; (EVERY 'numberp '(10 5.5 0)) -> T (fonction vlisp -> vl-every)

(defun EVERY (fun lst)
(and
(vl-consp lst)
(apply '= (cons T (mapcar fun lst)))
)
)

Il suffit de remplacer par :

;;; Vérifie si tous les membres d'une liste retournent T comme résultat à l'exécution d'une fonction
;;; (EVERY 'numberp '(10 5.5 0)) -> T  (fonction vlisp -> vl-every)

(defun EVERY (fun lst)
 (and
   (consp lst)
   (apply '= (cons T (mapcar fun lst)))
 )
)

;;; une liste non vide ?
;;; (fonction vlisp -> vl-consp)

(defun consp (l)
 (and l (listp l))
)

gile · le 6 mai 2005

Une autre amélioration possible, après j'arrête !

Pour pouvoir saisir le second sommet en coordonnées relatives (avec @), l'origine étant le premier sommet, il suffit de remplacer cette partie du code précédent :

((or (member key '((2 13) (2 32))) (eq (car key) 25))
(if (and (not (zerop (strlen value)))
(POINTP (STR->PT value))
)
(setq pt2 (STR->PT value))
)
(setq loop nil)
)

par :

((or (member key '((2 13) (2 32))) (eq (car key) 25))
(if (not (zerop (strlen value)))
  (cond
    ((and (= 64 (ascii (substr value 1 1)))
	  (STR->PT (substr value 2))
     )
     (setq pt2 (mapcar '+ pt1 (STR->PT (substr value 2))))
    )
    ((STR->PT value)
     (setq pt2 (STR->PT value))
    )
    (T
     (princ "\nNécessite un point 2D ou entrée au clavier.")
     (setq pt2 nil
	   value ""
     )
    )
  )
)
(if pt2
  (progn
    (redraw)
    (grvecs (list pt1 pt2 pt2 pt3 pt3 pt1))
    (setq loop nil)
  )
)
      )

et modifier la définition de STR->PT pour éviter un message d'erreur en cas de faute de frappe.

;;; STR->PT Transforme une chaine en point
;;; ex : (str->pt "20,15") -> (20.0 15.0 0.0)

(defun STR->PT (str / n s l c)
 (setq	n (1+ (strlen str))
s ""
 )
 (while (< 0 (setq n (1- n)))
   (setq c (substr str n 1))
   (if	(= c ",")
     (if (STRINGP s)
(setq l	(cons s l)
      s	""
)
     )
     (setq s (strcat c s))
   )
 )
 (if (STRINGP s)
   (setq l (cons s l))
 )
 (if (POINTP (mapcar 'read l))
   (trans (mapcar 'read l) 0 0)
 )
)

Dans la même optique, pour la saisie du dernier angle, remplacer :

((or (member key '((2 13) (2 32))) (eq (car key) 25))
(if (and (not (zerop (strlen value)))
(or (eq (type (read value)) 'INT)
(eq (type (read value)) 'REAL)
)
)
(setq a2 (/ (* pi (read value)) 180)
loop nil
pta2 nil
)
)
)

par :

((or (member key '((2 13) (2 32))) (eq (car key) 25))
(if (and (not (zerop (strlen value)))
	 (numberp (read value))
    )
  (setq	a2   (/ (* pi (read value)) 180)
	loop nil
	pta2 nil
  )
  (progn
    (princ
      "\nNécessite un angle numérique correct, 2ème point, ou une entrée au clavier."
    )
    (setq value "")
  )
)
      )

Encore une fois, un gros merci à tous !!!!

bonuscad · le 8 mai 2005

HiHi, Que tu dis :P

Une autre amélioration possible, après j'arrête !

Un prog n'est jamais parfait, ni achevé. Je suis sûr que tu apporteras encore des modifs, surtout si tu as été piqué par le "vice".

En tout cas tu te débrouille bien! Des remarques seraient possibles, mais bon si t'arrête.... :o

gile · le 8 mai 2005

Allez Bonuscad, envoie les remarques !

...

Des remarques seraient possibles, mais bon si t'arrête....

Je voulais juste dire : j'arrête d'envoyer des "patchs". Bien sûr que je n'arrête pas d'essayer d'améliorer l'histoire, même si je continue d'utiliser la version "classique" (elle me semble plus fiable et permet d'utiliser le repère objet). Grace à toi en particulier, j'ai appris à me servir de fonctions LISP que je n'utilisait pas encore : grread, ascii, chr...

bonuscad · le 9 mai 2005

En fait, ce sont plutôt des suggestions que des remarques.

J'ai essayé ta routine en m'accrochant a des points 3D, et tu as bien géré ta routine car tu retourne les messages d'explications ne non achévement de ta commande trapeze.

Je pense qu'une construction en s'appuyant sur des point 3D devrait être possible.

Pour faire ceci il s'agirait par exemple de s'appuyer sur le 1er point saisi avec son Z et de contruire les autres en filtrant le XY des point saisis et en y attribuant le Z du 1er point et ceci par rapport au SCU courant.

Voilà pour le + que tu pourrais apporté ;)

PS: Je vais regardé de plus près l'introduction des angles au clavier que tu as faite car cela m'interesse et je vais peut être m'en inspirer.

gile · le 13 mai 2005

Merci Bonuscad et toutes mes excuses pour cette réponse tardive, j'ai été privé de connexion pendant la semaine.

J'avais tout d'abord procédé comme tu le suggère pour la 3D, mais le déplacement du SCU permet à l'affichage des "grvecs" de rester cohérent visuellement.

Sinon, je suis très flatté que la manière dont j'ai récupéré les entrées au clavier puisse t'intéresser parceque c'est pour moi une découverte !

A bientôt...

bonuscad · le 13 mai 2005

Salut,

J'ai édité mon dernier code publié pour le modifier (cela évite d'avoir un fil inondé de ligne de code)

J'ai introduit la possibilité d'introduction des angles internes du trapèze au clavier.

Voilà, si ca t'interesse d'y jeter un oeil retourne au post plus haut.

Et continu comme ça, tu a l'âme d'un lispeur ;)

Dessiner un trapèze

Messages recommandés

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Information importante