Modification d'un LISP

[yb1971]

Bonjour,

je suis à recherche de quelqu'un qui pourrait me modifier un LISP. Ce LIPS me sert à plusieurs choses, notamment celle d'extraire des coordonnées de blocs et le contenu de certains calques (commande (cible)). Pour l'instant il me fait ça sur la totalité du dessin, et je voudrais pouvoir faire de même mais qu'il me propose de selectionner une zone du dessin avant.

Si quelqu'un sait comment faire, me contacter et je lui transmettrai les fichier, car il y a un .lsp et un .dcl

Merci d'avance

 

;; script Autolisp v8.0 - 
;; 18.02.2010 - NMB
;; utilitaires AutoCAD 
;; pour configuration laser
;;
;; But :
;;           - dessin des trajectoires laser
;;           - exportation des coordonnees des cibles
;; ------------------------------------------------------- 
;; trajectoires :
;; trajectoires disponnibles :
;;   - Virage Traine : (vt)
;;   - virage SurCompense : (sc)
;;   - Changement de Ligne (surcompense) : (cl)
;;
;; ------------------------------------------------------- 
;; cibles
;; exportation dans 2 fichiers :
;;     - mark_1.dat (au format IML) 
;;     - mur.txt    (au format ligne a ligne x1 y1 x2 y2)
;;     - dessin.txt (au format ligne a ligne x1 y1 x2 y2)
;; ces fichiers sont prets a l'emploi pour utilisation les utilitaires windows
;; IML et PsiNav
;;
;;-----------------------------------------------------------------------------
;; Initialisation et gestion de l'IHM

;; --------------------------------------------------------
;; fonction cree pour gere l'action accept trajectoire
;; (recuperation des valeurs du dialogue)
;; parametres : 
;;    AUCUN
;; valeur retournee :
;;   AUNCUNE
(defun action_accept_traj ()
 (setq n_bloc_agv (get_tile "liste_agv"))
 (setq s_empattement (get_tile "edit_empattement"))
 (done_dialog)
)

;; ------------------------------------------------------------------------
;; initialisation du script
;; mise a jour des variables globales
;; saisie des plans, des noms blocs, empattement avec boite de dialogue
;; parametres
;;    AUNCUN
;; valeur retournee
;;    AUCUNE
;;
(defun init ()
 ;; mise du SCU dans quelque chose de correct
 ; (command "_UCS" "G")
 (setq script_init 0)

 ;; vrai si import troncon en cours ...
 (setq import_tronc 0)
 (while (/= script_init 1)
   ;; creation d'une liste contenant les noms de blocs
   (setq liste_bloc (liste_mot_clef "BLOCK"))
   (setq liste_bloc_simul ( filter match_simul_block liste_bloc ))
   ;; initialisation de la boite de dialogue
   ;;
   (setq dcl_id (load_dialog "laser8.dcl"))
   ;; charge fichier DCL
   (if	(NOT (new_dialog "laser_traj" dcl_id))
     ( alert "erreur ouverture fichier dcl" )
   )
   ;; initialisation des listes
   (start_list "liste_agv")
   (mapcar 'add_list liste_bloc_simul)
   (end_list)
   ;; recuperation des valeurs precedentes si elles existent

   ;; attention, comme des blocs ou des plans ont pu etre crees
   ;; il faut chercher le numero de la precedente selection
   ;; dans la liste...

   ;; les fonctions suivantes remplissent :
   ;; n_bloc_agv
   ;; n_plan_simu
   ;; n_plan_cote
   ;; n_plan_traj
   ;; n_plan_carf
   ;;                  -> en valeur numerique
   ;;                  -> les valeurs seront ensuite 
   ;;                  -> converties en chaine

   (setq n_bloc_agv
   (cherche_liste liste_bloc_simul nom_bloc_agv)
   )
   (if	(/= n_bloc_agv nil)
     (set_tile "liste_agv" (itoa n_bloc_agv))
   )

   (if	(/= s_empattement nil)
     (set_tile "edit_empattement" s_empattement)
   )

   (action_tile
     "accept"
     "(action_accept_traj)"
   )
   (start_dialog)

   ;; recuperation des valeurs
   (setq nom_bloc_agv (nth (atoi n_bloc_agv) liste_bloc_simul))
   (setq E (atoi s_empattement))
   (unload_dialog dcl_id)

   (if	(= E 0)
     (alert "Empattement non correct!")
   )
   (setq script_init 1)
 )
)


;; insert a block
;; @param
;; blockname block name 
;; x pos in x 
;; y pos in y 
;; theta orientation in degree
( defun insert_block (blockname  x  y theta)
(command
  "_insert"
  blockname
  "_non" (list x y)
  ""
  ""
  (rad2deg theta)
)
)

;; --------------------------
;; renvoi le nom du bloc ou nil si l'entite n'est pas un bloc
(defun nom_bloc	(entite)
 (setq choix (entget (car entite)))
 (if (= (cdr (assoc 0 choix)) "INSERT")
   (cdr (assoc 2 choix))
   nil
 )
)

;; performs a filter on list
;; @param
;; f filter function, (if f elmt) is used to select elements
;; l list to filter
(defun filter (f l / a)
    (foreach i l 
        ( if ( f i )
            (setq a (append a (list  i) )) 
            nil
        )   
    ) a
) 

;; returns if block name corresponds to simulation
;; 
(defun match_simul_block ( blockname )
  (wcmatch blockname "*SI")
)

;; "safe" itoa
;; @return itoa(i) or nil if str is nil
(defun itoa_safe (i)
   ( if i
      (itoa i)
      nil
   )
)

;; -------------------------------------------------------------------------
;; sauvegarde des parametres qui vont etre modifies pendant le script et
;; modification des valeurs necessaire
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun contexte_debut ()
 ;; sauvegarde du plan courant
 (setq sauve_clayer (getvar "CLAYER"))
)

;; -------------------------------------------------------------------------
;; restauration du contexte
;; remise du layer a la valeur sauvegardee
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun contexte_restaure ()
 ;; restauration du plan
 (command "_layer" "CH" sauve_clayer "")
)

;;-----------------------------------------------------------------------------
;; Fonctions utilitaires pour AutoCAD

;;-----------------------------------------------------------------------

;; -------------------------------------------------------------------------
;; conversion angle en radians en degres
;; parametre
;;   a : angle en radians
;; valeur retournee 
;;  angle en degres
;;
(defun rad2deg (a)
 (* 180 (/ a pi))
)

;; -------------------------------------------------------------------------
;; calcul d'une tangeante
;; parametre
;;   a : angle en radians
;; valeur retournee
;;   tangeante de l'angle
;;   ou erreur si a = 0 mod pi
;;
(defun tan (a)
 (/ (sin a) (cos a))
)

;; -------------------------------------------------------------------------
;; calcul d'un angle en radians entre -pi et +pi
;;    a : angle en radians
;; valeur retournee
;;    a : angle raporte entre -pi et +pi
(defun mod2pi (a)
 (while (> a pi)
   (setq a (- a (* 2.0 pi)))
 )
 (while (< a (- pi))
   (setq a (+ a (* 2.0 pi)))
 )
 a
)

;; -------------------------------------------------------------------------
;; calcul d'un carre
;; parametre
;;    a : valeur
;; valeur retournee
;;    a : carre ( a*a )
;;
(defun carre (a)
 (* a a)
)


;; fonction qui recherche des valeurs dans les tables d'AutoCAD
;; le resultat est une liste, qui contient toutes les valeurs trouvees
;; classees par ordre alphabetique
;;
;; exemple d'utilisation : liste_mot_clef( "LAYER" ) renvoie une liste contenant tous
;; les plans du dessin.
;;
;; cette fonction peut etre utilisee pour :
;; LAYER, BLOCK, ...
;;
;; parametres
;;    mot_clef : chaine contenant un mot clef d'une table AutoCAD
;; valeur retournee
;;    liste contenant l'ensmble des identifiant pour cette clef (cf exemple)
;;
(defun liste_mot_clef (mot_clef)
 (setq liste_mot nil)
 (setq l (tblnext mot_clef 1))
 (while l
   (setq liste_mot
   (cons
     (cdr (assoc 2 l))
     liste_mot
   )
   )
   (setq l (tblnext mot_clef))
 )
 (reverse liste_mot)
 (setq liste_mot (acad_strlsort liste_mot))
)

;; --------------------------------------------------------
;; renvoie le premier numero de article si il est present dans la liste
;; parametre
;;    liste   : liste a examiner
;;    article : element a rechercher 
;; valeur retournee :
;;   indice (dans la liste) de article s'il existe
;;   nil si l'article n'est pas dans la liste
;;
(defun cherche_liste (liste article)
 (if
   (
    /=
     (setq l2 (member article liste))
     nil
   )
    (- (length liste) (length l2))
    nil
 )
)

;; ------------------------------------------------------------------------
;; Fonctions de recherche des elements du plan

(defun liste_magnet ()
 (liste_bloc_attr 1 nil nom_bloc_magnet)
)


;; ------------------------------------------------------------------------
;; exportation

;; ecriture d'une liste sur le disque formattee avec des espaces
;; paramatres :
;; - fichier : descripteur de fichier
;; - debut ligne : chaine a mettre en debut de chaque ligne
;; - list : liste a ecrire
;; - separ : caractere ou chaine de separation
(defun export_liste (fichier debut_ligne liste separ)
 (foreach article liste
   (setq debut 1)
   (if	debut_ligne
     (progn
(princ debut_ligne fichier)
(princ separ fichier)
     )
   )

   (foreach attr article
     (if debut
(setq debut nil)
(princ separ fichier)
     )
     (princ attr fichier)
   )
   (princ "\n" fichier)
 )
)

;; ------------------------------------------------------------------------
;; retourne une liste de bloc avec attributs presents sur le dessin
;; la liste comprend en final
;;   la position d'insertion du bloc ( optionnel ) 
;;   la liste des attributs
;; parametres
;;   insert_pos ( different de nil si la position d'insertion doir etre 
;;                ajoutee dans la liste )
;;   attr_name   ( si different de nil, le nom des champs est mis dans la
;;                 liste )
;;   nom_bloc  nom du bloc
;; valeur retournee :
;;   liste 
;; format du retour :
;; ( ( attribut1, attribut2, ... <x1, y1, theta1> ),
;;   ( attribut1, attribut2, ... <x2, y2, theta2> ),
;;    ...
;; )
;;
(defun liste_bloc_attr (insert_pos attr_name nom_bloc)
 ;; initialisation liste ensmble troncon
 (setq ensemble_bloc nil)
 ;; parcours de la liste des blocs 
 (setq	selection
 (ssget	"X"
	(list (cons 0 "INSERT") (cons 2 nom_bloc))
 )
 )

 (if (/= selection nil)
   (progn
     ;; parcours de la selection
     (setq i 0)
     (setq n (sslength selection))
     (while (< i n)
(setq entite (entget (ssname selection i)))
;; l'entite selectionnee est un bloc compose d'attributs
;; on va parcourir l'entite a la recherche des attributs
(setq id_entite (cdar entite))

(setq attribut id_entite)

;; initialisation bloc courant
(setq bloc nil)

;; test de la presence d'attributs en suite...

(if (= (cdr (assoc 66 entite)) 1)
  (setq fin 0)
  (setq fin 1)
)

;; principe :
;; extraction de la prochaine entite : si nil, 
;;  cond arrete le traitement 
;; test si entite est "SEQ END" : si oui, cond arrete
;;  traitement 
;; test si entite est "ATTRIB" : extraction des donnees
;;  sinon, rien


(while
  (AND
    ;; extraction entite du bloc
    (/= (setq attribut (entnext attribut)) nil)
    (= fin 0)
  )

   (if
     (/=
       (cdr (assoc 0 (entget attribut)))
       "SEQEND"
     )

      (progn
	;; ajout du nom de l'attribut ( si attr_name )
	(if attr_name
	  (setq	bloq
		 (
		  append
		   bloc
		   (list (cdr (assoc 2 (entget attribut))))
		 )
	  )
	)
	;; ajout de la valeur de l'attribut
	(setq bloc
	       (
		append
		 bloc
		 (list (cdr (assoc 1 (entget attribut))))
	       )
	)
	nil
      )

      (setq fin 1)
      ;; pour passer a l'objet suivant
   )
)

;; point d'insertion ?
(if insert_pos
  (progn
    (setq point_insertion (cdr (assoc 10 entite)))
    (setq x (car point_insertion))
    (setq y (cadr point_insertion))
    (setq theta (cdr (assoc 50 entite)))

    (if	attr_name
      (setq bloc (append bloc (list "x" x "y" y "theta" theta)))
      (setq bloc (append bloc (list x y theta)))
    )
  )
)

(setq ensemble_bloc
       (
	append
	 ensemble_bloc
	 (list bloc)
       )
)
(setq i (+ 1 i))
     )
     ensemble_bloc
   )
   nil
 )
)

;; -------------------------------------------------------------------------
;; conversion angle en degre en radians
;; parametre
;;   a : angle en degres
;; valeur retournee 
;;  angle en radians
;;
(defun deg2rad (a)
 (* pi (/ a 180.0))
)

;; -------------------------------------------------------------------------
;; calcul du premier arc du surcompense
;; parametre
;;    s      : represente l'avancement dans le virage
;;              il doit varier entre 0 et 0.5
;; valteur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense_arc1 (s)

 ;; -----> prevoir gestion d'erreur si s<0 et s>0.5

 ;; affectation de xar_t
 ;; pendant que s varie de 0 a 0.5, xar_t varie de 0 a xm

 (setq xar_t (* 2 s xm))
 (setq yar_t (* k xar_t xar_t xar_t))
 ;; calcul du vecteur norme tangeant a la courbe decrite par les roues ar
 (setq u 1)
 (setq v (* 3.0 k xar_t xar_t))
 (setq
   norme (
   distance
    (list u v)
    (list 0 0)
  )
 )

 (setq u (/ u norme))
 (setq v (/ v norme))
 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E u)))
 (setq yav_t (+ yar_t (* E v)))
 ;; calcul position roue avant dans repere absolu
 (setq	xav (- (+ x1 (* xav_t (cos angle1)))
       (* yav_t (sin angle1))
    )
 )
 (setq	yav (+ (+ y1 (* xav_t (sin angle1)))
       (* yav_t (cos angle1))
    )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq	xar (- (+ x1 (* xar_t (cos angle1)))
       (* yar_t (sin angle1))
    )
 )
 (setq	yar (+ (+ y1 (* xar_t (sin angle1)))
       (* yar_t (cos angle1))
    )
 )

 (setq
   cap	(
 angle
  (list 0 0)
  (list u v)
)
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; calcul du deuxieme arc du surcompense
;; parametre
;;    s      : represente l'avancement dans le virage
;;              il doit varier entre 0 et 0.5
;; valteur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense_arc2 (s)

 ;; -----> prevoir gestion d'erreur si s<0.5 et s>1

 ;; affecation de z
 ;; s varie de 0.5 a 1 et z varie de xm a 0

 (setq z (* (- 1 s) 2 xm))
 (setq t (* k z z z))

 ;; calcul du vecteur norme tangeant a la courbe decrite par les roues ar
 (setq u 1)
 (setq v (* 3.0 k z z))
 (setq
   norme (
   distance
    (list u v)
    (list 0 0)
  )
 )

 (setq u (/ u norme))
 (setq v (/ v norme))
 (setq u_2 (+ (* u (cos beta)) (* v (sin beta))))
 (setq v_2 (- (* u (sin beta)) (* v (cos beta))))

 ;; calcul position roue ar dans repere troncon 
 (setq	xar_t (- (- xf
	    (* z (cos beta))
	 )
	 (* t (sin beta))
      )
 )
 (setq	yar_t (+ (- yf
	    (* z (sin beta))
	 )
	 (* t (cos beta))
      )
 )
 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E u_2)))
 (setq yav_t (+ yar_t (* E v_2)))
 ;; calcul position roue avant dans repere absolu
 (setq	xav (- (+ x1 (* xav_t (cos angle1)))
       (* yav_t (sin angle1))
    )
 )
 (setq	yav (+ (+ y1 (* xav_t (sin angle1)))
       (* yav_t (cos angle1))
    )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq	xar (- (+ x1 (* xar_t (cos angle1)))
       (* yar_t (sin angle1))
    )
 )
 (setq	yar (+ (+ y1 (* xar_t (sin angle1)))
       (* yar_t (cos angle1))
    )
 )

 (setq
   cap	(
 angle
  (list 0 0)
  (list u_2 v_2)
)
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; routine de precalcul pour un surcompense
;; calcul des differents parametres de la cubique...

;; -------------------------------------------------------------------------
;; routine de calcul pour un surcompense
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense (s)
 (if (< s 0.5)
   (calcul_surcompense_arc1 s)
   (calcul_surcompense_arc2 s)
 )
)

;; -------------------------------------------------------------------------
;; SC : surcompense
;; saisie et trace d'un surcompense
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun sc ()

 (init)

 ;;
 ;; SAISIE DES POINTS
 ;;

 (setq p1 (getpoint "\nSC point 1:"))
 (setq p2 (getpoint "\nSC point 2:"))
 (setq p3 (getpoint "\nSC point 3:"))

 ;; saisie de l'encombrement
 (setq enc (getdist "\nSC Encombrement du virage (mm) :"))

 ;; apres la saisie des points, on peut changer les parametres de snap
 (contexte_debut)

 ;;
 ;; CALCUL DES PARAMETRES
 ;;

 ;; extraction des coordonnees
 (setq x1 (car p1))
 (setq x2 (car p2))
 (setq x3 (car p3))

 (setq y1 (cadr p1))
 (setq y2 (cadr p2))
 (setq y3 (cadr p3))

 ;; calcul de l'angle de depart
 (setq angle1 (atan (- y2 y1) (- x2 x1)))

 ;; calcul de l'angle final
 (setq angle2 (atan (- y3 y2) (- x3 x2)))

 ;; modification de x1 et y1 pour tenir compte de l'encombrement du virage
 ;; d est utilise temporairement
 (setq d (distance p1 p2))
 (setq x1 (+ x2 (/ (* (- x1 x2) enc) d)))
 (setq y1 (+ y2 (/ (* (- y1 y2) enc) d)))

 ;; modification de x3 et y3 pour tenir compte de l'encombrement du virage
 ;; d est utilise temporairement
 (setq d (distance p2 p3))
 (setq x3 (+ x2 (/ (* (- x3 x2) enc) d)))
 (setq y3 (+ y2 (/ (* (- y3 y2) enc) d)))

 ;; angle du virage
 (setq beta (- angle2 angle1))

 ;; on veut beta dans [-pi, pi]
 (while (> beta pi)
   (setq beta (- beta (* 2 pi)))
 )
 (while (< beta (- pi))
   (setq beta (+ beta (* 2 pi)))
 )

 (dessin_sc Enc beta x1 y1 angle1)

 ;; restauration du contexte
 (contexte_restaure)
 (princ)
)

;; -------------------------------------------------------------------------
;; calcul_param_sc
;; calcul des parametres d'un virage surcompense
(defun calcul_param_sc (_Enc _beta _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq Enc _Enc)
 (setq beta _beta)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)


 ;; calcul de la fin du virage

 ;; calcul de la fin du virage en fin de troncon
 (setq xf (* (+ 1 (cos beta)) Enc))
 (setq yf (* (sin beta) Enc))

 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq	x3
 (
  +
   x1
   (
    -
     (* xf (cos angle1))
     (* yf (sin angle1))
   )
 )
 )
 (setq	y3
 (
  +
   y1
   (
    +
     (* yf (cos angle1))
     (* xf (sin angle1))
   )
 )
 )

 ;; variable intermediaire
 (setq tb2 (tan (/ beta 2.0)))
 ;; tan( beta/ 2 )

 ;; rayon des roues arrieres
 (setq rar (/ Enc tb2))

 ;; parametres de la cubique  
 ;; on calcul morceau par morceau...
 (setq k (* tb2 tb2))
 ;; (tan( beta/2) )^2
 (setq k (+ 3 k))
 ;; 3 + (tan( beta/2) )^2 
 (setq k (* k k))
 ;; ( 3 + (tan( beta/2) )^2 )^2

 (setq k (/ k (* 27 rar rar tb2)))

 ;; coordonnees de fin de virage dans le repere troncon
 (setq xf (* enc (+ 1 (cos beta))))
 (setq yf (* enc (sin beta)))

 ;; coordonnees de changement d'arc dans le repere troncon
 (setq xm (sqrt (abs (/ tb2 (* 3.0 k)))))
 (setq ym (* xm xm xm k))

 ;; calcul de la longeur theorique
 (setq longueur_troncon (abs (* rar beta)))
)

;; chagne the layer, if exists otherwise an error message
(defun change_layer_safe (layername)
   ( if ( member layername (liste_mot_clef "LAYER") ) 
       ;;( setvar "CLAYER" layername )
       (command "_layer" "E" layername "")
       ( alert (strcat "Unable to find layer:" layername) )
   )
)

;; dessin d'une polyline
;;le parametre doit etre une list de type ( ( x1 y1) (x2 y2) ... )
(defun draw_traj (lst)
   (change_layer_safe "ba-trajectoire")
   (command "_.pline" 
       (foreach pt lst (command "_non" pt)) ; draw each point from the list
   ) ; draw the polyline
   (princ )
)

;; extract rear point from traj point, which is index 3 and  4 in list
;; @param :
;; l : list as (xav xar yav yar theta)
;; @return (xar yar)
(defun extrat_rear_point (l)
  (list (nth 2 l) (nth 3 l))
)

;; extract rear point from traj point, which is index 3 and  4 in list
;; @param :
;; @return (xar yar theta)
(defun extrat_rear_pose (l)
  (list (nth 2 l) (nth 3 l) (nth 4 l))
)

;; draw agv pose
;; @param:
;; l : list as (xav xar yav yar theta)
(defun draw_agv_pose (agv_pose)
  (change_layer_safe "ba-AGV\ simul")
  (insert_block nom_bloc_agv (nth 0 agv_pose) (nth 1 agv_pose) (nth 4 agv_pose) )
)

;; -------------------------------------------------------------------------
;; dessin_sc : dessin d'un virage surcompense
;; parametres :
;;      Enc           : encombrement du virage
;;      beta          : angle du virage 
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_sc (Enc beta x1 y1 angle1 )

 (calcul_param_sc Enc beta x1 y1 angle1 )
 (setq traj (mapcar 'calcul_surcompense ss) )
 (draw_traj (mapcar 'extrat_rear_point traj))
 (mapcar 'draw_agv_pose traj)  
)


;; -------------------------------------------------------------------------
;; calcul du premier arc d'un changement de ligne
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 0.5
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne1 (s)
 ;; xar_t varie de 0 a l pendant que s varie de 0 a 0.5
 (setq xar_t (* 2.0 s l))
 (setq	yar_t
 (/
   (* d xar_t xar_t xar_t (- 2.0 (/ xar_t l)))
   (* l l l)
 )
 )

 (setq	cap
 (
  atan
   (/
     (* 2 d xar_t xar_t (- (* 3 l) (* 2 xar_t)))
     (* l l l l)
   )
 )
 )

 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E (cos cap))))
 (setq yav_t (+ yar_t (* E (sin cap))))

 ;; nouvelle version sur roue AR
 ;; calcul position roue avant dans repere absolu
 (setq	xav (- (+ x1 (* xav_t (cos angle1)))
       (* yav_t (sin angle1))
    )
 )
 (setq	yav (+ (+ y1 (* xav_t (sin angle1)))
       (* yav_t (cos angle1))
    )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq	xar (- (+ x1 (* xar_t (cos angle1)))
       (* yar_t (sin angle1))
    )
 )
 (setq	yar (+ (+ y1 (* xar_t (sin angle1)))
       (* yar_t (cos angle1))
    )
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; calcul du deuxieme arc d'un chagnement de ligne 
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.5 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne2 (s)
 ;; z varie de l a 0 pendant que s varie de 0.5 a 1.0
 (setq z (* (- 1 s) 2 l))
 (setq	t
 (/
   (* d z z z (- 2.0 (/ z l)))
   (* l l l)
 )
 )
 (setq	cap (
     atan (/
	    (* 2 d z z (- (* 3 l) (* 2 z)))
	    (* l l l l)
	  )
    )
 )

 (setq xar_t (- (* 2.0 l) z))
 (setq yar_t (- (* 2.0 d) t))

 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E (cos cap))))
 (setq yav_t (+ yar_t (* E (sin cap))))

 ;; calcul position roue avant dans repere absolu
 (setq	xav (- (+ x1 (* xav_t (cos angle1)))
       (* yav_t (sin angle1))
    )
 )
 (setq	yav (+ (+ y1 (* xav_t (sin angle1)))
       (* yav_t (cos angle1))
    )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq	xar (- (+ x1 (* xar_t (cos angle1)))
       (* yar_t (sin angle1))
    )
 )
 (setq	yar (+ (+ y1 (* xar_t (sin angle1)))
       (* yar_t (cos angle1))
    )
 )
 (list xav yav xar yar (+ cap angle1))
)

;; -------------------------------------------------------------------------
;; routine de calcul pour un changement de ligne
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne	(s)
 (if (< s 0.5)
   (calcul_chgtligne1 s)
   (calcul_chgtligne2 s)
 )
)

;; -------------------------------------------------------------------------
;; CL : changement de ligne
;; saisie et trace d'un changement de ligne surcompense
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun cl ()

 (init)

 ;;
 ;; SAISIE DES POINTS
 ;; 

 (setq p1 (getpoint "\nCL point 1:"))
 (setq p2 (getpoint "\nCL point 2:"))
 (setq p3 (getpoint "\nCL point 3:"))

 ;; extraction des coordonnees
 (setq x1 (car p1))
 (setq x2 (car p2))
 (setq x3 (car p3))

 (setq y1 (cadr p1))
 (setq y2 (cadr p2))
 (setq y3 (cadr p3))

 ;; recalcul de x2 et y2 pour avoir un rectangle
 ;; k est utilise temporairement

 (setq	k
 (+ (* (- x2 x1) (- x3 x1))
    (* (- y2 y1) (- y3 y1))
 )
 )
 (setq	k (/ k
     (+	(* (- x2 x1) (- x2 x1))
	(* (- y2 y1) (- y2 y1))
     )
  )
 )

 (setq x2 (+ x1 (* k (- x2 x1))))
 (setq y2 (+ y1 (* k (- y2 y1))))

 ;; apres la saisie des points, on peut changer les parametres de snap
 (contexte_debut)

 ;;
 ;; CALCUL DES PARAMETRES
 ;;

 ;; calcul angle de depart
 (setq angle1 (atan (- y2 y1) (- x2 x1)))


 ;; calcul de la DEMI longueur du changement de ligne
 (setq	l
 (* 0.5 (sqrt (+ (carre (- x2 x1)) (carre (- y2 y1)))))
 )

 ;; calcul de la DEMI largeur du changement de ligne
 (setq	d
 (* 0.5 (sqrt (+ (carre (- x3 x2)) (carre (- y3 y2)))))
 )
 ;; changement de signe de d dans le cas d'un virage a droite
 ;; tres elegamment, on utilise le signe du produit vectoriel...

 (if (<
(-
  (* (- x2 x1) (- y3 y1))
  (* (- x3 x1) (- y2 y1))
)
0
     )
   (setq d (- 1.0 d))
 )

 (dessin_cl l d x1 y1 angle1)

 ;; restauration du contexte
 (contexte_restaure)
 (princ)
)

;; -------------------------------------------------------------------------
;; calcul des parametres du virage changement de ligne
;; parametres
;;      _l               : demi longueur cl
;;      _d               : demi largeur cl
;;      _x1,_y1,_ angle1 : parametres du repere absolu
(defun calcul_param_cl (_l _d _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq l _l)
 (setq d _d)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)

 ;; calcul de la fin du virage en fin de troncon
 (setq xf (* 2.0 l))
 (setq yf (* 2.0 d))

 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq	x3
 (
  +
   x1
   (
    -
     (* xf (cos angle1))
     (* yf (sin angle1))
   )
 )
 )
 (setq	y3
 (
  +
   y1
   (
    +
     (* yf (cos angle1))
     (* xf (sin angle1))
   )
 )
 )

 ;; calcul de la longeur theorique
 (setq longueur_troncon (* 2 l))

)

;; -------------------------------------------------------------------------
;; dessin_cl : dessin d'un changement de ligne
;; parametres
;;      l             : demi longueur cl
;;      d             : demi largeur cl
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_cl (l d x1 y1 angle1 )

 (calcul_param_cl l d x1 y1 angle1 )
 (setq traj (mapcar 'calcul_chgtligne ss) )
 (draw_traj (mapcar 'extrat_rear_point traj))
 (mapcar 'draw_agv_pose traj) 
 
)

;; -------------------------------------------------------------------------
;; routine de calcul pour un virage traine
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0 pour le virage traine
;;                lorsqu'il est superieur a 1 on calcul la traine pour le troncon droit suivant
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_viragetraine (s)

 ;; initialisation (alpha2 memorise l'ancien alpha pour ne pas avoir a gerer le pas ici)
 (if (= s 0.0)
   (progn
     (setq phi 0)
     (setq cap 0)
     (setq alpha2 s)
   )
 )

 (setq alpha (abs (* s beta)))
 ;; angle realise dans le virage

 ;; distance parcourue depuis dernier appel
 (setq dist (abs (* rayon (- alpha alpha2))))

 ;; distance parcourue dans la ligne droite apres le virage
 (if (> s 1.01)
   (setq dist2 (+ dist2 dist))
   (setq dist2 0)
 )

 ;; calcul de la position de la roue avant dans le repere du troncon
 (if (<= s 1.01)
   (progn
     ;; le virage est en cours
     (setq xav_t (* rayon (sin alpha)))
     (setq yav_t (* rayon (- 1.0 (cos alpha))))
   )
   (progn
     ;; le virage est termine
     (setq xav_t (+ (* rayon (sin (abs beta)))
	     (* dist2 (cos (abs beta)))
	  )
     )
     (setq yav_t (+ (* rayon (- 1.0 (cos (abs beta))))
	     (* dist2 (sin (abs beta)))
	  )
     )
   )
 )

 (if (= sens_virage "D")
   (setq yav_t (* -1 yav_t))
 )

 ;; simulation de l'angle de tourelle...

 (if (<= s 1.01)
   (if	(= sens_virage "G")
     (setq phi (- alpha cap))
     ;; alpha - cap
     (setq phi (- 0 alpha cap))
     ;; -alpha - cap
   )
   (if	(= sens_virage "G")
     (setq phi (- (abs beta) cap))
     ;; alpha - cap
     (setq phi (- 0 (abs beta) cap))
     ;; -alpha - cap
   )
 )

 ;; variation de cap
 (setq cap (+ cap (/ (* dist (sin phi)) E)))

 ;; memorisation ancien alpha
 (setq alpha2 alpha)

 ;; calcul de la position des roues arrieres dans le repere du troncon
 (setq xar_t (- xav_t (* E (cos cap))))
 (setq yar_t (- yav_t (* E (sin cap))))

 ;; calcul position roue avant dans repere absolu
 (setq	xav (- (+ x1 (* xav_t (cos angle1)))
       (* yav_t (sin angle1))
    )
 )
 (setq	yav (+ (+ y1 (* xav_t (sin angle1)))
       (* yav_t (cos angle1))
    )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq	xar (- (+ x1 (* xar_t (cos angle1)))
       (* yar_t (sin angle1))
    )
 )
 (setq	yar (+ (+ y1 (* xar_t (sin angle1)))
       (* yar_t (cos angle1))
    )
 )
 (list xav yav xar yar (+ cap angle1) )
)
;; -------------------------------------------------------------------------
;; traiter_choix_vt
;; routine de traitement de l'arc selectionne
;; Parametre : entite selectionnee
;; retour
;; 0 si succes
(defun traiter_choix_vt	(choix)

 ;; verifier que c'est un arc
 (if (/= (cdr (assoc 0 choix)) "ARC")
   (setq res 1)
   (progn

     ;;extraction du centre...
     (setq centre_cercle (cdr (assoc 10 choix)))

     ;;extraction du rayon
     (setq rayon (cdr (assoc 40 choix)))

     ;; extraction des angles
     (setq angle1 (cdr (assoc 50 choix)))
     (setq angle2 (cdr (assoc 51 choix)))

     ;; angle1 et angle2 sont comptes (par AutoCAD)
     ;; pour un arc oriente dans le sens trigo
     ;; entre 0 et 2 pi.
     ;; Comme on souhaite toujours avoir angle1 < angle2
     ;; on modifie eventuellement angle1

     (if (> angle1 angle2)
(setq angle1 (- angle1 (* 2 pi)))
     )

     ;; savoir si c'est un virage a droite ou a gauche...
     (if (= mode_choix_sens_virage 1)
(progn
  (initget 1 "Droite Gauche")
  (setq	sens_virage
	 (getkword "VT Sens du virage (Droite Gauche)")
  )
  (setq sens_virage (substr sens_virage 1 1))
)
(setq sens_virage "G")
     )

     ;; permuter les angles si besoin
     (if (= sens_virage "D")
(progn
  ;; echange de angle1 et angle2 
  (setq temp angle1)
  (setq angle1 angle2)
  (setq angle2 temp)
)
     )

     ;; calcul de x1 y1 : point de depart du virage 
     (setq x1 (+ (car centre_cercle) (* rayon (cos angle1))))
     (setq y1 (+ (cadr centre_cercle) (* rayon (sin angle1))))
     ;; calcul de x3 et y3 : point d'arrivee du virage
     (setq x3 (+ (car centre_cercle) (* rayon (cos angle2))))
     (setq y3 (+ (cadr centre_cercle) (* rayon (sin angle2))))

     ;; angle1 represente maintenant le cap du chariot en entree de virage
     ;; et angle2 le cap en fin de virage...

     (if (= sens_virage "G")
(progn
  (setq angle1 (+ angle1 (/ pi 2)))
  (setq angle2 (+ angle2 (/ pi 2)))
)
(progn
  (setq angle1 (- angle1 (/ pi 2)))
  (setq angle2 (- angle2 (/ pi 2)))
)
     )

     (setq beta (- angle2 angle1))

     ;; angle1 n'est peut-etre pas dans le bon interval
     (setq angle1 (mod2pi angle1))

     (dessin_vt rayon beta x1 y1 angle1)
     (setq res 0)
   )
 )
 res
)

;; -------------------------------------------------------------------------
;; VT : virage traine (nouvelle version : selection d'un arc)
;; saisie et trace d'un virage traine
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun vt ()
 (init)
 (contexte_debut)
 ;; demander une selection
 (setq entite nil)

 (while (= entite nil)
   (setq entite (entsel "\n VT : cliquer sur un arc"))
 )
 (setq mode_choix_sens_virage 1)

 ;; extraire l'entite choisie
 (setq choix (entget (car entite)))
 (if (= (traiter_choix_vt choix) 1)
   (princ "\n ce n'est pas un arc !!")
 )
 (contexte_restaure)
)

;; -------------------------------------------------------------------------
;; calcul_param_vt
;; calcul des parametres du virage traine
(defun calcul_param_vt (_rayon _beta _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq rayon _rayon)
 (setq beta _beta)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)

 ;; calcul de la fin du virage

 ;; calcul de la fin du virage en fin de troncon
 (if (= sens_virage "G")
   (progn
     (setq xf (* (sin beta) rayon))
     (setq yf (* (- 1 (cos beta)) rayon))
   )
   (progn
     (setq xf (* (- (sin beta)) rayon))
     (setq yf (* (- (cos beta) 1) rayon))
   )
 )
 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq	x3
 (
  +
   x1
   (
    -
     (* xf (cos angle1))
     (* yf (sin angle1))
   )
 )
 )
 (setq	y3
 (
  +
   y1
   (
    +
     (* yf (cos angle1))
     (* xf (sin angle1))
   )
 )
 )

 ;; calcul de la longeur theorique
 (setq longueur_troncon (abs (* rayon beta)))

)

;; -------------------------------------------------------------------------
;; dessin_vt : dessin d'un virage traine
;; parametres :
;;      rayon         : rayon du virage
;;      beta          : angle du virage 
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_vt (rayon beta x1 y1 angle1 )
   (calcul_param_vt rayon beta x1 y1 angle1)
   (setq traj (mapcar 'calcul_viragetraine ss) )
   (draw_traj (mapcar 'extrat_rear_point traj))
   (mapcar 'draw_agv_pose traj)    
)

;; -------------------------------------------------------------------------
;; fonction cree pour gerer l'action accept cible
;; (recuperation des valeurs du dialogue)
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun action_accept_cible ()
 (setq n_bloc_cible (get_tile "liste_cible"))
 (setq n_plan_mur (get_tile "liste_mur"))
 (setq n_plan_dessin (get_tile "liste_dessin"))
 (done_dialog)
)

;; -------------------------------------------------------------------------
;; fonction cree pour gere l'action accept cible
;; (recuperation des valeurs du dialogue)
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun action_accept_cible ()
 (setq n_bloc_cible (get_tile "liste_cible"))
 (setq n_plan_mur (get_tile "liste_mur"))
 (setq n_plan_dessin (get_tile "liste_dessin"))
 (done_dialog)
)

;; -------------------------------------------------------------------------
;; fonction d'exortation de traits vers un fichier texte
;; le nom du fichier est fichier
;; l'exportation se fait sur la selection passee en parametre
;; parametres :
;; nom plan : nom du plan a filtrer ou vide
;; valeur retournee
;; AUCUNE
(defun export_trait (nom_plan)

 (setq selection (ssget "X" '((0 . "LINE"))))

 (setq i 0)
 (setq n (sslength selection))

 (princ "export_trait( nom plan = ")
 (princ nom_plan)
 (princ " )\n")
 (princ " lg selection = ")
 (princ n)
 (princ " \n")

 ;; parcours des entites
 (while (< i n)
   (setq entite (entget (ssname selection i)))
   (if
     (or
(= nom_plan "*")
(= (cdr (assoc 8 entite)) nom_plan)
     )
      (progn
 (setq x1 (cadr (assoc 10 entite)))
 (setq y1 (caddr (assoc 10 entite)))
 (setq x2 (cadr (assoc 11 entite)))
 (setq y2 (caddr (assoc 11 entite)))

 ;; ecriture dans le fichier

 (write-line
   (strcat
     (rtos x1)
     " "
     (rtos y1)
     " "
     (rtos x2)
     " "
     (rtos y2)
     "\n"
   )
   fichier
 )
      )
   )
   (setq i (+ i 1))
 )
)

;; -------------------------------------------------------------------------
;; fonction qui gere l'exportation des cibles au format IML    
;;    - saisie du nom du bloc qui definit les cibles (DCL)
;;    - parcours de la base de donnee pour extraire les blocs cibles
;;    - ecriture du fichier cible
;;    - ecriture du fichier mur
;;    - ecriture du fichier dessin
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun cible ()
 ;; initialisation du script, gestion de la boite de dialogue

 ;; creation d'une liste contenant
 ;; les noms des layer et des blocks
 (setq liste_layer (liste_mot_clef "LAYER"))
 (setq liste_bloc (liste_mot_clef "BLOCK"))

 ;; initialisation de la boite de dialogue
 ;;
 (setq dcl_id (load_dialog "laser8.dcl"))
 ;; charge fichier DCL
 (if (NOT (new_dialog "laser_cible" dcl_id))
   (exit)
 )

 ;; initialisation des listes
 (start_list "liste_cible")
 (mapcar 'add_list liste_bloc)
 (end_list)

 (start_list "liste_mur")
 (mapcar 'add_list liste_layer)
 (end_list)

 (start_list "liste_dessin")
 (mapcar 'add_list liste_layer)
 (end_list)

 ;; recuperation des valeurs precedentes si elles existent
 (if (/= n_bloc_cible nil)
   (set_tile "liste_cible" n_bloc_cible)
 )
 (if (/= n_plan_mur nil)
   (set_tile "liste_mur" n_plan_mur)
 )

 (if (/= n_plan_dessin nil)
   (set_tile "liste_dessin" n_plan_dessin)
 )

 ;; que se passe-t-il lorsque l'on clique sur OK ?
 (action_tile
   "accept"
   "(action_accept_cible)"
 )

 (start_dialog)

 ;; recuperation des valeurs

 (setq nom_bloc_cible (nth (atoi n_bloc_cible) liste_bloc))
 (setq nom_plan_mur (nth (atoi n_plan_mur) liste_layer))
 (setq nom_plan_dessin (nth (atoi n_plan_dessin) liste_layer))

 (unload_dialog dcl_id)

 ;; ---------------------------------------------------------------
 ;; gestion des cibles        

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\mark_1.dat" "w"))

 ;; cela serait beaucoup mieux, mais je ne sais pas comment le faire marcher
 ;; ( setq selection ( ssget "X" '(( 2 . nom_bloc_cible )) ) )

 (setq selection (ssget "X" '((0 . "INSERT"))))

 ;; parcours de la selection
 (setq i 0)
 (setq n (sslength selection))

 ;; indice dans le fichier
 (setq j 0)

 ;; parcours des entites
 (while (< i n)
   (setq entite (entget (ssname selection i)))
   ;;if ( /= ( cdr ( assoc 2 entite ) ) nul )

   (setq nom_bloc (cdr (assoc 2 entite)))

   (if	(= nom_bloc nom_bloc_cible)
     (progn
(setq x (cadr (assoc 10 entite)))
(setq y (caddr (assoc 10 entite)))

(setq theta (cdr (assoc 50 entite)))

;; ecriture dans le fichier
(setq j (+ j 1))
(write-line
  (strcat
    (itoa j)
    " "
    (rtos x)
    " "
    (rtos y)
    " "
    (rtos (/ (* 180 theta) 3.1415926))
    " "
    " 1 1"
  )
  fichier
)
     )
   )
   (setq i (+ i 1))
 )

 (close fichier)

 ;; ------------------------------------------------------------------
 ;; gestion des murs

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\mur.txt" "w"))
 (export_trait nom_plan_mur)
 (close fichier)

 ;; ------------------------------------------------------------------
 ;; gestion du dessin sur le plan

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\dessin.txt" "w"))
 (export_trait nom_plan_dessin)
 (close fichier)
)

;; -------------------------------------------------------------------------
;; revoie true si caractere est un separateur
;; parametres
;;    aucun
;; valeur retournee :
;;    aucune
(defun separateur (char)
 (or
   (= char (ascii " "))
   (= char (ascii "\n"))
   (= char (ascii "\t"))
   (= char 13)
   (= char 10)
 )
)

(setq script_init 0)
(command "ATTREQ" 1)
(command "ATTDIA" 1)
;; force saisie attributs insertion bloc

;; -------------------------------------------------------------------
;; affichage de depart
(princ
 "\nScripts Laser LASER.LSP v8.0  NMB (c)2001-2010 B.A Systemes. Chargement OK"
)
(princ
 "\n Traj: (VT) (SC) (CL) Cibles: (CIBLE):Export. cibles murs"
)
(princ)

;; Creates here the list for the acisses in the curve (20 points)
(setq ss (list))
(setq s 0.0)
(while (<= s 1.001 )
  (setq ss (append ss (list s) ))
  (setq s ( + s 0.05 ) )
)

;; default values
;; simulation
(setq s_empattement "2000" )

;; cibles
(setq n_bloc_cible ( itoa_safe ( cherche_liste ( liste_mot_clef  "BLOCK" ) "ba-cible") ) )
(setq n_plan_mur ( itoa_safe ( cherche_liste ( liste_mot_clef  "LAYER" ) "ba-laser-mur") ) )
(setq n_plan_dessin ( itoa_safe ( cherche_liste ( liste_mot_clef  "LAYER" ) "ba-trajectoire") ) )


;; ecriture du fichier magnet.txt
(defun export_magnet ()

 (setq fichier (open "c:\\prog_las\\magnet.txt" "w"))

 (if (= nom_bloc_magnet nil)
   (setq nom_bloc_magnet (getstring "\n Nom du bloc magnet :"))
 )

 ;; liste_magnet sort ( ID, Enabled, X, Y, theta)
 (foreach magnet (liste_magnet)
   (progn
     ;; ID
     (princ (nth 0 magnet) fichier)
     (princ " " fichier)
     ;; x
     (princ (nth 2 magnet) fichier)
     (princ " " fichier)
     ;; y
     (princ (nth 3 magnet) fichier)
     (princ " " fichier)
     ;; Enabled
     (princ (nth 1 magnet) fichier)
     (princ "\n" fichier)
   )
 )


 (close fichier)
 (princ "\nExportation magnet terminee")
)

LASER8.DCL

[Aleck_Ultimate]

Salut.

 

Devoir passer par MP (message privé) pour connaitre le LISP ça complique beaucoup le procédé pour ceux qui peuvent t'aider, sans parler des échanges entre internautes qui peuvent être utiles à tous, maintenant ou plus tard.

 

Je doute fortement d'avoir le niveau de te répondre, mais si ton fichier n'est pas confidentiel le plus simple serait que tu face un copié-collé du LISP dans un poste en utilisant le bouton "insérer du code" [<>], tout à droite de l'émoji dans la barre d'outils de l'éditeur de texte du forum. Ça donnera déjà une bonne idée aux pro du codage de comment modifier ton LISP. Si le DCL est important pour les modifications tu devrait pouvoir l'ajouter en pièce-jointe en natif sur le forum, il faudra peut-être le zipper si l’extension actuel est refusée, on sais jamais (sous réserve que l'upload en natif ne soit pas à nouveau down, dans ce cas voir ici : https://cadxp.com/topic/45263-pieces-jointes-et-insertion-dimages-sur-le-forum/page__view__findpost__p__261784).

 

Cordialy.

[yb1971]

j'ai modifier mon message du coup

:)

[yb1971]

Personne pour m'aider? :(

[dilack]

Salut,

Franchement, c'est pas évident de modifier un lips dont on n'est pas l'auteur.

Plusieurs personnes te le diront je pense.

Surtout sur ce genre de programme.

[Aleck_Ultimate]

De plus, pour être un habitué de ce forum, je peut te dire que sa fréquentation a beaucoup baissée avec les vacances des un·e·s et des autr·e·s. Peut-être un "up" début septembre ?

 

Mais la vache, j'aie rarement vue des LISP aussi longs sur le forum , copié-collé dans notepad++ il affiche 1718 lignes. C'est une structure aéré et balisée avec pas mal de commentaires, mais quant-même. Sur un code de cette catégorie même une petite modification demanderait pas mal d’efforts rien que pour trouver où et quoi modifier, donc à moins qu'avec leur expérience pour certaine de nos pointure sur le sujet ce soit suffisamment simple, c'est quant même beaucoup pour des bénévoles donc je voudrais pas te donner de faux-espoirs sur l'aide que peut t'apporter ce forum.

 

Cordialy.

[rebcao]

Bonjour,

 

+1 avec Aleck...

 

Les commentaires c'est effectivement une bonne chose...

 

Mais comme le souligne Aleck, ce source contient pas moins de 46 FONCTIONS DEFUN... ça veut dire qu'il faut à chaque fois "lire" à quoi correspond le renvoie vers ces différentes FONCTIONS...

 

 

Christian

[(gile)]

Salut,

 

Quand on souhaite une modification d'une routine glanée sur internet, le mieux est de s'adresser directement à l'auteur de la routine.

[GEGEMATIC]

Salut,

je n'ai pas essayé ton lisp, et je ne sais pas à quoi il sert.

J'ai simplement supprimé le "x" dans les 3 ssget.

donc il faudra que tu sélectionne manuellement 3 fois quelque chose, à toi de savoir quoi !

la sélection s'entends comme une fenêtre ou une capture, le programme filtre ensuite les bon éléments: on sélectionne une zone.

dis moi si ça marche ?

a+

gégé

;; script Autolisp v8.0 - 
;; 18.02.2010 - NMB
;; utilitaires AutoCAD 
;; pour configuration laser
;;
;; But :
;;           - dessin des trajectoires laser
;;           - exportation des coordonnees des cibles
;; ------------------------------------------------------- 
;; trajectoires :
;; trajectoires disponnibles :
;;   - Virage Traine : (vt)
;;   - virage SurCompense : (sc)
;;   - Changement de Ligne (surcompense) : (cl)
;;
;; ------------------------------------------------------- 
;; cibles
;; exportation dans 2 fichiers :
;;     - mark_1.dat (au format IML) 
;;     - mur.txt    (au format ligne a ligne x1 y1 x2 y2)
;;     - dessin.txt (au format ligne a ligne x1 y1 x2 y2)
;; ces fichiers sont prets a l'emploi pour utilisation les utilitaires windows
;; IML et PsiNav
;;
;;-----------------------------------------------------------------------------
;; Initialisation et gestion de l'IHM

;; --------------------------------------------------------
;; fonction cree pour gere l'action accept trajectoire
;; (recuperation des valeurs du dialogue)
;; parametres : 
;;    AUCUN
;; valeur retournee :
;;   AUNCUNE
(defun action_accept_traj ()
 (setq n_bloc_agv (get_tile "liste_agv"))
 (setq s_empattement (get_tile "edit_empattement"))
 (done_dialog)
)

;; ------------------------------------------------------------------------
;; initialisation du script
;; mise a jour des variables globales
;; saisie des plans, des noms blocs, empattement avec boite de dialogue
;; parametres
;;    AUNCUN
;; valeur retournee
;;    AUCUNE
;;
(defun init ()
 ;; mise du SCU dans quelque chose de correct
 ; (command "_UCS" "G")
 (setq script_init 0)

 ;; vrai si import troncon en cours ...
 (setq import_tronc 0)
 (while (/= script_init 1)
   ;; creation d'une liste contenant les noms de blocs
   (setq liste_bloc (liste_mot_clef "BLOCK"))
   (setq liste_bloc_simul ( filter match_simul_block liste_bloc ))
   ;; initialisation de la boite de dialogue
   ;;
   (setq dcl_id (load_dialog "laser8.dcl"))
   ;; charge fichier DCL
   (if (NOT (new_dialog "laser_traj" dcl_id))
     ( alert "erreur ouverture fichier dcl" )
   )
   ;; initialisation des listes
   (start_list "liste_agv")
   (mapcar 'add_list liste_bloc_simul)
   (end_list)
   ;; recuperation des valeurs precedentes si elles existent

   ;; attention, comme des blocs ou des plans ont pu etre crees
   ;; il faut chercher le numero de la precedente selection
   ;; dans la liste...

   ;; les fonctions suivantes remplissent :
   ;; n_bloc_agv
   ;; n_plan_simu
   ;; n_plan_cote
   ;; n_plan_traj
   ;; n_plan_carf
   ;;                  -> en valeur numerique
   ;;                  -> les valeurs seront ensuite 
   ;;                  -> converties en chaine

   (setq n_bloc_agv
          (cherche_liste liste_bloc_simul nom_bloc_agv)
   )
   (if (/= n_bloc_agv nil)
     (set_tile "liste_agv" (itoa n_bloc_agv))
   )

   (if (/= s_empattement nil)
     (set_tile "edit_empattement" s_empattement)
   )

   (action_tile
     "accept"
     "(action_accept_traj)"
   )
   (start_dialog)

   ;; recuperation des valeurs
   (setq nom_bloc_agv (nth (atoi n_bloc_agv) liste_bloc_simul))
   (setq E (atoi s_empattement))
   (unload_dialog dcl_id)

   (if (= E 0)
     (alert "Empattement non correct!")
   )
   (setq script_init 1)
 )
)


;; insert a block
;; @param
;; blockname block name 
;; x pos in x 
;; y pos in y 
;; theta orientation in degree
( defun insert_block (blockname  x  y theta)
       (command
         "_insert"
         blockname
         "_non" (list x y)
         ""
         ""
         (rad2deg theta)
       )
)

;; --------------------------
;; renvoi le nom du bloc ou nil si l'entite n'est pas un bloc
(defun nom_bloc (entite)
 (setq choix (entget (car entite)))
 (if (= (cdr (assoc 0 choix)) "INSERT")
   (cdr (assoc 2 choix))
   nil
 )
)

;; performs a filter on list
;; @param
;; f filter function, (if f elmt) is used to select elements
;; l list to filter
(defun filter (f l / a)
    (foreach i l 
        ( if ( f i )
            (setq a (append a (list  i) )) 
            nil
        )   
    ) a
) 

;; returns if block name corresponds to simulation
;; 
(defun match_simul_block ( blockname )
  (wcmatch blockname "*SI")
)

;; "safe" itoa
;; @return itoa(i) or nil if str is nil
(defun itoa_safe (i)
   ( if i
      (itoa i)
      nil
   )
)

;; -------------------------------------------------------------------------
;; sauvegarde des parametres qui vont etre modifies pendant le script et
;; modification des valeurs necessaire
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun contexte_debut ()
 ;; sauvegarde du plan courant
 (setq sauve_clayer (getvar "CLAYER"))
)

;; -------------------------------------------------------------------------
;; restauration du contexte
;; remise du layer a la valeur sauvegardee
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun contexte_restaure ()
 ;; restauration du plan
 (command "_layer" "CH" sauve_clayer "")
)

;;-----------------------------------------------------------------------------
;; Fonctions utilitaires pour AutoCAD

;;-----------------------------------------------------------------------

;; -------------------------------------------------------------------------
;; conversion angle en radians en degres
;; parametre
;;   a : angle en radians
;; valeur retournee 
;;  angle en degres
;;
(defun rad2deg (a)
 (* 180 (/ a pi))
)

;; -------------------------------------------------------------------------
;; calcul d'une tangeante
;; parametre
;;   a : angle en radians
;; valeur retournee
;;   tangeante de l'angle
;;   ou erreur si a = 0 mod pi
;;
(defun tan (a)
 (/ (sin a) (cos a))
)

;; -------------------------------------------------------------------------
;; calcul d'un angle en radians entre -pi et +pi
;;    a : angle en radians
;; valeur retournee
;;    a : angle raporte entre -pi et +pi
(defun mod2pi (a)
 (while (> a pi)
   (setq a (- a (* 2.0 pi)))
 )
 (while (< a (- pi))
   (setq a (+ a (* 2.0 pi)))
 )
 a
)

;; -------------------------------------------------------------------------
;; calcul d'un carre
;; parametre
;;    a : valeur
;; valeur retournee
;;    a : carre ( a*a )
;;
(defun carre (a)
 (* a a)
)


;; fonction qui recherche des valeurs dans les tables d'AutoCAD
;; le resultat est une liste, qui contient toutes les valeurs trouvees
;; classees par ordre alphabetique
;;
;; exemple d'utilisation : liste_mot_clef( "LAYER" ) renvoie une liste contenant tous
;; les plans du dessin.
;;
;; cette fonction peut etre utilisee pour :
;; LAYER, BLOCK, ...
;;
;; parametres
;;    mot_clef : chaine contenant un mot clef d'une table AutoCAD
;; valeur retournee
;;    liste contenant l'ensmble des identifiant pour cette clef (cf exemple)
;;
(defun liste_mot_clef (mot_clef)
 (setq liste_mot nil)
 (setq l (tblnext mot_clef 1))
 (while l
   (setq liste_mot
          (cons
            (cdr (assoc 2 l))
            liste_mot
          )
   )
   (setq l (tblnext mot_clef))
 )
 (reverse liste_mot)
 (setq liste_mot (acad_strlsort liste_mot))
)

;; --------------------------------------------------------
;; renvoie le premier numero de article si il est present dans la liste
;; parametre
;;    liste   : liste a examiner
;;    article : element a rechercher 
;; valeur retournee :
;;   indice (dans la liste) de article s'il existe
;;   nil si l'article n'est pas dans la liste
;;
(defun cherche_liste (liste article)
 (if
   (
    /=
     (setq l2 (member article liste))
     nil
   )
    (- (length liste) (length l2))
    nil
 )
)

;; ------------------------------------------------------------------------
;; Fonctions de recherche des elements du plan

(defun liste_magnet ()
 (liste_bloc_attr 1 nil nom_bloc_magnet)
)


;; ------------------------------------------------------------------------
;; exportation

;; ecriture d'une liste sur le disque formattee avec des espaces
;; paramatres :
;; - fichier : descripteur de fichier
;; - debut ligne : chaine a mettre en debut de chaque ligne
;; - list : liste a ecrire
;; - separ : caractere ou chaine de separation
(defun export_liste (fichier debut_ligne liste separ)
 (foreach article liste
   (setq debut 1)
   (if debut_ligne
     (progn
       (princ debut_ligne fichier)
       (princ separ fichier)
     )
   )

   (foreach attr article
     (if debut
       (setq debut nil)
       (princ separ fichier)
     )
     (princ attr fichier)
   )
   (princ "\n" fichier)
 )
)

;; ------------------------------------------------------------------------
;; retourne une liste de bloc avec attributs presents sur le dessin
;; la liste comprend en final
;;   la position d'insertion du bloc ( optionnel ) 
;;   la liste des attributs
;; parametres
;;   insert_pos ( different de nil si la position d'insertion doir etre 
;;                ajoutee dans la liste )
;;   attr_name   ( si different de nil, le nom des champs est mis dans la
;;                 liste )
;;   nom_bloc  nom du bloc
;; valeur retournee :
;;   liste 
;; format du retour :
;; ( ( attribut1, attribut2, ... <x1, y1, theta1> ),
;;   ( attribut1, attribut2, ... <x2, y2, theta2> ),
;;    ...
;; )
;;
(defun liste_bloc_attr (insert_pos attr_name nom_bloc)
 ;; initialisation liste ensmble troncon
 (setq ensemble_bloc nil)
 ;; parcours de la liste des blocs
 (prompt "\nVeuillez sélectionner les blocs contenant les attributs:")
 (setq selection
        (ssget 
               (list (cons 0 "INSERT") (cons 2 nom_bloc))
        )
 )

 (if (/= selection nil)
   (progn
     ;; parcours de la selection
     (setq i 0)
     (setq n (sslength selection))
     (while (< i n)
       (setq entite (entget (ssname selection i)))
       ;; l'entite selectionnee est un bloc compose d'attributs
       ;; on va parcourir l'entite a la recherche des attributs
       (setq id_entite (cdar entite))

       (setq attribut id_entite)

       ;; initialisation bloc courant
       (setq bloc nil)

       ;; test de la presence d'attributs en suite...

       (if (= (cdr (assoc 66 entite)) 1)
         (setq fin 0)
         (setq fin 1)
       )

       ;; principe :
       ;; extraction de la prochaine entite : si nil, 
       ;;  cond arrete le traitement 
       ;; test si entite est "SEQ END" : si oui, cond arrete
       ;;  traitement 
       ;; test si entite est "ATTRIB" : extraction des donnees
       ;;  sinon, rien


       (while
         (AND
           ;; extraction entite du bloc
           (/= (setq attribut (entnext attribut)) nil)
           (= fin 0)
         )

          (if
            (/=
              (cdr (assoc 0 (entget attribut)))
              "SEQEND"
            )

             (progn
               ;; ajout du nom de l'attribut ( si attr_name )
               (if attr_name
                 (setq bloq
                        (
                         append
                          bloc
                          (list (cdr (assoc 2 (entget attribut))))
                        )
                 )
               )
               ;; ajout de la valeur de l'attribut
               (setq bloc
                      (
                       append
                        bloc
                        (list (cdr (assoc 1 (entget attribut))))
                      )
               )
               nil
             )

             (setq fin 1)
             ;; pour passer a l'objet suivant
          )
       )

       ;; point d'insertion ?
       (if insert_pos
         (progn
           (setq point_insertion (cdr (assoc 10 entite)))
           (setq x (car point_insertion))
           (setq y (cadr point_insertion))
           (setq theta (cdr (assoc 50 entite)))

           (if attr_name
             (setq bloc (append bloc (list "x" x "y" y "theta" theta)))
             (setq bloc (append bloc (list x y theta)))
           )
         )
       )

       (setq ensemble_bloc
              (
               append
                ensemble_bloc
                (list bloc)
              )
       )
       (setq i (+ 1 i))
     )
     ensemble_bloc
   )
   nil
 )
)

;; -------------------------------------------------------------------------
;; conversion angle en degre en radians
;; parametre
;;   a : angle en degres
;; valeur retournee 
;;  angle en radians
;;
(defun deg2rad (a)
 (* pi (/ a 180.0))
)

;; -------------------------------------------------------------------------
;; calcul du premier arc du surcompense
;; parametre
;;    s      : represente l'avancement dans le virage
;;              il doit varier entre 0 et 0.5
;; valteur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense_arc1 (s)

 ;; -----> prevoir gestion d'erreur si s<0 et s>0.5

 ;; affectation de xar_t
 ;; pendant que s varie de 0 a 0.5, xar_t varie de 0 a xm

 (setq xar_t (* 2 s xm))
 (setq yar_t (* k xar_t xar_t xar_t))
 ;; calcul du vecteur norme tangeant a la courbe decrite par les roues ar
 (setq u 1)
 (setq v (* 3.0 k xar_t xar_t))
 (setq
   norme (
          distance
           (list u v)
           (list 0 0)
         )
 )

 (setq u (/ u norme))
 (setq v (/ v norme))
 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E u)))
 (setq yav_t (+ yar_t (* E v)))
 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )

 (setq
   cap (
        angle
         (list 0 0)
         (list u v)
       )
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; calcul du deuxieme arc du surcompense
;; parametre
;;    s      : represente l'avancement dans le virage
;;              il doit varier entre 0 et 0.5
;; valteur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense_arc2 (s)

 ;; -----> prevoir gestion d'erreur si s<0.5 et s>1

 ;; affecation de z
 ;; s varie de 0.5 a 1 et z varie de xm a 0

 (setq z (* (- 1 s) 2 xm))
 (setq t (* k z z z))

 ;; calcul du vecteur norme tangeant a la courbe decrite par les roues ar
 (setq u 1)
 (setq v (* 3.0 k z z))
 (setq
   norme (
          distance
           (list u v)
           (list 0 0)
         )
 )

 (setq u (/ u norme))
 (setq v (/ v norme))
 (setq u_2 (+ (* u (cos beta)) (* v (sin beta))))
 (setq v_2 (- (* u (sin beta)) (* v (cos beta))))

 ;; calcul position roue ar dans repere troncon 
 (setq xar_t (- (- xf
                   (* z (cos beta))
                )
                (* t (sin beta))
             )
 )
 (setq yar_t (+ (- yf
                   (* z (sin beta))
                )
                (* t (cos beta))
             )
 )
 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E u_2)))
 (setq yav_t (+ yar_t (* E v_2)))
 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )

 (setq
   cap (
        angle
         (list 0 0)
         (list u_2 v_2)
       )
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; routine de precalcul pour un surcompense
;; calcul des differents parametres de la cubique...

;; -------------------------------------------------------------------------
;; routine de calcul pour un surcompense
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense (s)
 (if (< s 0.5)
   (calcul_surcompense_arc1 s)
   (calcul_surcompense_arc2 s)
 )
)

;; -------------------------------------------------------------------------
;; SC : surcompense
;; saisie et trace d'un surcompense
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun sc ()

 (init)

 ;;
 ;; SAISIE DES POINTS
 ;;

 (setq p1 (getpoint "\nSC point 1:"))
 (setq p2 (getpoint "\nSC point 2:"))
 (setq p3 (getpoint "\nSC point 3:"))

 ;; saisie de l'encombrement
 (setq enc (getdist "\nSC Encombrement du virage (mm) :"))

 ;; apres la saisie des points, on peut changer les parametres de snap
 (contexte_debut)

 ;;
 ;; CALCUL DES PARAMETRES
 ;;

 ;; extraction des coordonnees
 (setq x1 (car p1))
 (setq x2 (car p2))
 (setq x3 (car p3))

 (setq y1 (cadr p1))
 (setq y2 (cadr p2))
 (setq y3 (cadr p3))

 ;; calcul de l'angle de depart
 (setq angle1 (atan (- y2 y1) (- x2 x1)))

 ;; calcul de l'angle final
 (setq angle2 (atan (- y3 y2) (- x3 x2)))

 ;; modification de x1 et y1 pour tenir compte de l'encombrement du virage
 ;; d est utilise temporairement
 (setq d (distance p1 p2))
 (setq x1 (+ x2 (/ (* (- x1 x2) enc) d)))
 (setq y1 (+ y2 (/ (* (- y1 y2) enc) d)))

 ;; modification de x3 et y3 pour tenir compte de l'encombrement du virage
 ;; d est utilise temporairement
 (setq d (distance p2 p3))
 (setq x3 (+ x2 (/ (* (- x3 x2) enc) d)))
 (setq y3 (+ y2 (/ (* (- y3 y2) enc) d)))

 ;; angle du virage
 (setq beta (- angle2 angle1))

 ;; on veut beta dans [-pi, pi]
 (while (> beta pi)
   (setq beta (- beta (* 2 pi)))
 )
 (while (< beta (- pi))
   (setq beta (+ beta (* 2 pi)))
 )

 (dessin_sc Enc beta x1 y1 angle1)

 ;; restauration du contexte
 (contexte_restaure)
 (princ)
)

;; -------------------------------------------------------------------------
;; calcul_param_sc
;; calcul des parametres d'un virage surcompense
(defun calcul_param_sc (_Enc _beta _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq Enc _Enc)
 (setq beta _beta)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)


 ;; calcul de la fin du virage

 ;; calcul de la fin du virage en fin de troncon
 (setq xf (* (+ 1 (cos beta)) Enc))
 (setq yf (* (sin beta) Enc))

 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq x3
        (
         +
          x1
          (
           -
            (* xf (cos angle1))
            (* yf (sin angle1))
          )
        )
 )
 (setq y3
        (
         +
          y1
          (
           +
            (* yf (cos angle1))
            (* xf (sin angle1))
          )
        )
 )

 ;; variable intermediaire
 (setq tb2 (tan (/ beta 2.0)))
 ;; tan( beta/ 2 )

 ;; rayon des roues arrieres
 (setq rar (/ Enc tb2))

 ;; parametres de la cubique  
 ;; on calcul morceau par morceau...
 (setq k (* tb2 tb2))
 ;; (tan( beta/2) )^2
 (setq k (+ 3 k))
 ;; 3 + (tan( beta/2) )^2 
 (setq k (* k k))
 ;; ( 3 + (tan( beta/2) )^2 )^2

 (setq k (/ k (* 27 rar rar tb2)))

 ;; coordonnees de fin de virage dans le repere troncon
 (setq xf (* enc (+ 1 (cos beta))))
 (setq yf (* enc (sin beta)))

 ;; coordonnees de changement d'arc dans le repere troncon
 (setq xm (sqrt (abs (/ tb2 (* 3.0 k)))))
 (setq ym (* xm xm xm k))

 ;; calcul de la longeur theorique
 (setq longueur_troncon (abs (* rar beta)))
)

;; chagne the layer, if exists otherwise an error message
(defun change_layer_safe (layername)
   ( if ( member layername (liste_mot_clef "LAYER") ) 
       ;;( setvar "CLAYER" layername )
       (command "_layer" "E" layername "")
       ( alert (strcat "Unable to find layer:" layername) )
   )
)

;; dessin d'une polyline
;;le parametre doit etre une list de type ( ( x1 y1) (x2 y2) ... )
(defun draw_traj (lst)
   (change_layer_safe "ba-trajectoire")
   (command "_.pline" 
       (foreach pt lst (command "_non" pt)) ; draw each point from the list
   ) ; draw the polyline
   (princ )
)

;; extract rear point from traj point, which is index 3 and  4 in list
;; @param :
;; l : list as (xav xar yav yar theta)
;; @return (xar yar)
(defun extrat_rear_point (l)
  (list (nth 2 l) (nth 3 l))
)

;; extract rear point from traj point, which is index 3 and  4 in list
;; @param :
;; @return (xar yar theta)
(defun extrat_rear_pose (l)
  (list (nth 2 l) (nth 3 l) (nth 4 l))
)

;; draw agv pose
;; @param:
;; l : list as (xav xar yav yar theta)
(defun draw_agv_pose (agv_pose)
  (change_layer_safe "ba-AGV\ simul")
  (insert_block nom_bloc_agv (nth 0 agv_pose) (nth 1 agv_pose) (nth 4 agv_pose) )
)

;; -------------------------------------------------------------------------
;; dessin_sc : dessin d'un virage surcompense
;; parametres :
;;      Enc           : encombrement du virage
;;      beta          : angle du virage 
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_sc (Enc beta x1 y1 angle1 )

 (calcul_param_sc Enc beta x1 y1 angle1 )
 (setq traj (mapcar 'calcul_surcompense ss) )
 (draw_traj (mapcar 'extrat_rear_point traj))
 (mapcar 'draw_agv_pose traj)  
)


;; -------------------------------------------------------------------------
;; calcul du premier arc d'un changement de ligne
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 0.5
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne1 (s)
 ;; xar_t varie de 0 a l pendant que s varie de 0 a 0.5
 (setq xar_t (* 2.0 s l))
 (setq yar_t
        (/
          (* d xar_t xar_t xar_t (- 2.0 (/ xar_t l)))
          (* l l l)
        )
 )

 (setq cap
        (
         atan
          (/
            (* 2 d xar_t xar_t (- (* 3 l) (* 2 xar_t)))
            (* l l l l)
          )
        )
 )

 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E (cos cap))))
 (setq yav_t (+ yar_t (* E (sin cap))))

 ;; nouvelle version sur roue AR
 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; calcul du deuxieme arc d'un chagnement de ligne 
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.5 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne2 (s)
 ;; z varie de l a 0 pendant que s varie de 0.5 a 1.0
 (setq z (* (- 1 s) 2 l))
 (setq t
        (/
          (* d z z z (- 2.0 (/ z l)))
          (* l l l)
        )
 )
 (setq cap (
            atan (/
                   (* 2 d z z (- (* 3 l) (* 2 z)))
                   (* l l l l)
                 )
           )
 )

 (setq xar_t (- (* 2.0 l) z))
 (setq yar_t (- (* 2.0 d) t))

 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E (cos cap))))
 (setq yav_t (+ yar_t (* E (sin cap))))

 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )
 (list xav yav xar yar (+ cap angle1))
)

;; -------------------------------------------------------------------------
;; routine de calcul pour un changement de ligne
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne (s)
 (if (< s 0.5)
   (calcul_chgtligne1 s)
   (calcul_chgtligne2 s)
 )
)

;; -------------------------------------------------------------------------
;; CL : changement de ligne
;; saisie et trace d'un changement de ligne surcompense
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun cl ()

 (init)

 ;;
 ;; SAISIE DES POINTS
 ;; 

 (setq p1 (getpoint "\nCL point 1:"))
 (setq p2 (getpoint "\nCL point 2:"))
 (setq p3 (getpoint "\nCL point 3:"))

 ;; extraction des coordonnees
 (setq x1 (car p1))
 (setq x2 (car p2))
 (setq x3 (car p3))

 (setq y1 (cadr p1))
 (setq y2 (cadr p2))
 (setq y3 (cadr p3))

 ;; recalcul de x2 et y2 pour avoir un rectangle
 ;; k est utilise temporairement

 (setq k
        (+ (* (- x2 x1) (- x3 x1))
           (* (- y2 y1) (- y3 y1))
        )
 )
 (setq k (/ k
            (+ (* (- x2 x1) (- x2 x1))
               (* (- y2 y1) (- y2 y1))
            )
         )
 )

 (setq x2 (+ x1 (* k (- x2 x1))))
 (setq y2 (+ y1 (* k (- y2 y1))))

 ;; apres la saisie des points, on peut changer les parametres de snap
 (contexte_debut)

 ;;
 ;; CALCUL DES PARAMETRES
 ;;

 ;; calcul angle de depart
 (setq angle1 (atan (- y2 y1) (- x2 x1)))


 ;; calcul de la DEMI longueur du changement de ligne
 (setq l
        (* 0.5 (sqrt (+ (carre (- x2 x1)) (carre (- y2 y1)))))
 )

 ;; calcul de la DEMI largeur du changement de ligne
 (setq d
        (* 0.5 (sqrt (+ (carre (- x3 x2)) (carre (- y3 y2)))))
 )
 ;; changement de signe de d dans le cas d'un virage a droite
 ;; tres elegamment, on utilise le signe du produit vectoriel...

 (if (<
       (-
         (* (- x2 x1) (- y3 y1))
         (* (- x3 x1) (- y2 y1))
       )
       0
     )
   (setq d (- 1.0 d))
 )

 (dessin_cl l d x1 y1 angle1)

 ;; restauration du contexte
 (contexte_restaure)
 (princ)
)

;; -------------------------------------------------------------------------
;; calcul des parametres du virage changement de ligne
;; parametres
;;      _l               : demi longueur cl
;;      _d               : demi largeur cl
;;      _x1,_y1,_ angle1 : parametres du repere absolu
(defun calcul_param_cl (_l _d _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq l _l)
 (setq d _d)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)

 ;; calcul de la fin du virage en fin de troncon
 (setq xf (* 2.0 l))
 (setq yf (* 2.0 d))

 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq x3
        (
         +
          x1
          (
           -
            (* xf (cos angle1))
            (* yf (sin angle1))
          )
        )
 )
 (setq y3
        (
         +
          y1
          (
           +
            (* yf (cos angle1))
            (* xf (sin angle1))
          )
        )
 )

 ;; calcul de la longeur theorique
 (setq longueur_troncon (* 2 l))

)
       
;; -------------------------------------------------------------------------
;; dessin_cl : dessin d'un changement de ligne
;; parametres
;;      l             : demi longueur cl
;;      d             : demi largeur cl
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_cl (l d x1 y1 angle1 )

 (calcul_param_cl l d x1 y1 angle1 )
 (setq traj (mapcar 'calcul_chgtligne ss) )
 (draw_traj (mapcar 'extrat_rear_point traj))
 (mapcar 'draw_agv_pose traj) 
 
)

;; -------------------------------------------------------------------------
;; routine de calcul pour un virage traine
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0 pour le virage traine
;;                lorsqu'il est superieur a 1 on calcul la traine pour le troncon droit suivant
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_viragetraine (s)

 ;; initialisation (alpha2 memorise l'ancien alpha pour ne pas avoir a gerer le pas ici)
 (if (= s 0.0)
   (progn
     (setq phi 0)
     (setq cap 0)
     (setq alpha2 s)
   )
 )

 (setq alpha (abs (* s beta)))
 ;; angle realise dans le virage

 ;; distance parcourue depuis dernier appel
 (setq dist (abs (* rayon (- alpha alpha2))))

 ;; distance parcourue dans la ligne droite apres le virage
 (if (> s 1.01)
   (setq dist2 (+ dist2 dist))
   (setq dist2 0)
 )

 ;; calcul de la position de la roue avant dans le repere du troncon
 (if (<= s 1.01)
   (progn
     ;; le virage est en cours
     (setq xav_t (* rayon (sin alpha)))
     (setq yav_t (* rayon (- 1.0 (cos alpha))))
   )
   (progn
     ;; le virage est termine
     (setq xav_t (+ (* rayon (sin (abs beta)))
                    (* dist2 (cos (abs beta)))
                 )
     )
     (setq yav_t (+ (* rayon (- 1.0 (cos (abs beta))))
                    (* dist2 (sin (abs beta)))
                 )
     )
   )
 )

 (if (= sens_virage "D")
   (setq yav_t (* -1 yav_t))
 )

 ;; simulation de l'angle de tourelle...

 (if (<= s 1.01)
   (if (= sens_virage "G")
     (setq phi (- alpha cap))
     ;; alpha - cap
     (setq phi (- 0 alpha cap))
     ;; -alpha - cap
   )
   (if (= sens_virage "G")
     (setq phi (- (abs beta) cap))
     ;; alpha - cap
     (setq phi (- 0 (abs beta) cap))
     ;; -alpha - cap
   )
 )

 ;; variation de cap
 (setq cap (+ cap (/ (* dist (sin phi)) E)))

 ;; memorisation ancien alpha
 (setq alpha2 alpha)

 ;; calcul de la position des roues arrieres dans le repere du troncon
 (setq xar_t (- xav_t (* E (cos cap))))
 (setq yar_t (- yav_t (* E (sin cap))))

 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )
 (list xav yav xar yar (+ cap angle1) )
)
;; -------------------------------------------------------------------------
;; traiter_choix_vt
;; routine de traitement de l'arc selectionne
;; Parametre : entite selectionnee
;; retour
;; 0 si succes
(defun traiter_choix_vt (choix)

 ;; verifier que c'est un arc
 (if (/= (cdr (assoc 0 choix)) "ARC")
   (setq res 1)
   (progn

     ;;extraction du centre...
     (setq centre_cercle (cdr (assoc 10 choix)))

     ;;extraction du rayon
     (setq rayon (cdr (assoc 40 choix)))

     ;; extraction des angles
     (setq angle1 (cdr (assoc 50 choix)))
     (setq angle2 (cdr (assoc 51 choix)))

     ;; angle1 et angle2 sont comptes (par AutoCAD)
     ;; pour un arc oriente dans le sens trigo
     ;; entre 0 et 2 pi.
     ;; Comme on souhaite toujours avoir angle1 < angle2
     ;; on modifie eventuellement angle1

     (if (> angle1 angle2)
       (setq angle1 (- angle1 (* 2 pi)))
     )

     ;; savoir si c'est un virage a droite ou a gauche...
     (if (= mode_choix_sens_virage 1)
       (progn
         (initget 1 "Droite Gauche")
         (setq sens_virage
                (getkword "VT Sens du virage (Droite Gauche)")
         )
         (setq sens_virage (substr sens_virage 1 1))
       )
       (setq sens_virage "G")
     )

     ;; permuter les angles si besoin
     (if (= sens_virage "D")
       (progn
         ;; echange de angle1 et angle2 
         (setq temp angle1)
         (setq angle1 angle2)
         (setq angle2 temp)
       )
     )

     ;; calcul de x1 y1 : point de depart du virage 
     (setq x1 (+ (car centre_cercle) (* rayon (cos angle1))))
     (setq y1 (+ (cadr centre_cercle) (* rayon (sin angle1))))
     ;; calcul de x3 et y3 : point d'arrivee du virage
     (setq x3 (+ (car centre_cercle) (* rayon (cos angle2))))
     (setq y3 (+ (cadr centre_cercle) (* rayon (sin angle2))))

     ;; angle1 represente maintenant le cap du chariot en entree de virage
     ;; et angle2 le cap en fin de virage...

     (if (= sens_virage "G")
       (progn
         (setq angle1 (+ angle1 (/ pi 2)))
         (setq angle2 (+ angle2 (/ pi 2)))
       )
       (progn
         (setq angle1 (- angle1 (/ pi 2)))
         (setq angle2 (- angle2 (/ pi 2)))
       )
     )

     (setq beta (- angle2 angle1))

     ;; angle1 n'est peut-etre pas dans le bon interval
     (setq angle1 (mod2pi angle1))

     (dessin_vt rayon beta x1 y1 angle1)
     (setq res 0)
   )
 )
 res
)

;; -------------------------------------------------------------------------
;; VT : virage traine (nouvelle version : selection d'un arc)
;; saisie et trace d'un virage traine
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun vt ()
 (init)
 (contexte_debut)
 ;; demander une selection
 (setq entite nil)

 (while (= entite nil)
   (setq entite (entsel "\n VT : cliquer sur un arc"))
 )
 (setq mode_choix_sens_virage 1)

 ;; extraire l'entite choisie
 (setq choix (entget (car entite)))
 (if (= (traiter_choix_vt choix) 1)
   (princ "\n ce n'est pas un arc !!")
 )
 (contexte_restaure)
)

;; -------------------------------------------------------------------------
;; calcul_param_vt
;; calcul des parametres du virage traine
(defun calcul_param_vt (_rayon _beta _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq rayon _rayon)
 (setq beta _beta)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)

 ;; calcul de la fin du virage

 ;; calcul de la fin du virage en fin de troncon
 (if (= sens_virage "G")
   (progn
     (setq xf (* (sin beta) rayon))
     (setq yf (* (- 1 (cos beta)) rayon))
   )
   (progn
     (setq xf (* (- (sin beta)) rayon))
     (setq yf (* (- (cos beta) 1) rayon))
   )
 )
 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq x3
        (
         +
          x1
          (
           -
            (* xf (cos angle1))
            (* yf (sin angle1))
          )
        )
 )
 (setq y3
        (
         +
          y1
          (
           +
            (* yf (cos angle1))
            (* xf (sin angle1))
          )
        )
 )

 ;; calcul de la longeur theorique
 (setq longueur_troncon (abs (* rayon beta)))

)

;; -------------------------------------------------------------------------
;; dessin_vt : dessin d'un virage traine
;; parametres :
;;      rayon         : rayon du virage
;;      beta          : angle du virage 
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_vt (rayon beta x1 y1 angle1 )
   (calcul_param_vt rayon beta x1 y1 angle1)
   (setq traj (mapcar 'calcul_viragetraine ss) )
   (draw_traj (mapcar 'extrat_rear_point traj))
   (mapcar 'draw_agv_pose traj)    
)

;; -------------------------------------------------------------------------
;; fonction cree pour gerer l'action accept cible
;; (recuperation des valeurs du dialogue)
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun action_accept_cible ()
 (setq n_bloc_cible (get_tile "liste_cible"))
 (setq n_plan_mur (get_tile "liste_mur"))
 (setq n_plan_dessin (get_tile "liste_dessin"))
 (done_dialog)
)

;; -------------------------------------------------------------------------
;; fonction cree pour gere l'action accept cible
;; (recuperation des valeurs du dialogue)
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun action_accept_cible ()
 (setq n_bloc_cible (get_tile "liste_cible"))
 (setq n_plan_mur (get_tile "liste_mur"))
 (setq n_plan_dessin (get_tile "liste_dessin"))
 (done_dialog)
)

;; -------------------------------------------------------------------------
;; fonction d'exortation de traits vers un fichier texte
;; le nom du fichier est fichier
;; l'exportation se fait sur la selection passee en parametre
;; parametres :
;; nom plan : nom du plan a filtrer ou vide
;; valeur retournee
;; AUCUNE
(defun export_trait (nom_plan)
(prompt "\nVeuillez sélectionner les trait (lignes)à exporter :")
 (setq selection (ssget  '((0 . "LINE"))))

 (setq i 0)
 (setq n (sslength selection))

 (princ "export_trait( nom plan = ")
 (princ nom_plan)
 (princ " )\n")
 (princ " lg selection = ")
 (princ n)
 (princ " \n")

 ;; parcours des entites
 (while (< i n)
   (setq entite (entget (ssname selection i)))
   (if
     (or
       (= nom_plan "*")
       (= (cdr (assoc 8 entite)) nom_plan)
     )
      (progn
        (setq x1 (cadr (assoc 10 entite)))
        (setq y1 (caddr (assoc 10 entite)))
        (setq x2 (cadr (assoc 11 entite)))
        (setq y2 (caddr (assoc 11 entite)))

        ;; ecriture dans le fichier

        (write-line
          (strcat
            (rtos x1)
            " "
            (rtos y1)
            " "
            (rtos x2)
            " "
            (rtos y2)
            "\n"
          )
          fichier
        )
      )
   )
   (setq i (+ i 1))
 )
)

;; -------------------------------------------------------------------------
;; fonction qui gere l'exportation des cibles au format IML    
;;    - saisie du nom du bloc qui definit les cibles (DCL)
;;    - parcours de la base de donnee pour extraire les blocs cibles
;;    - ecriture du fichier cible
;;    - ecriture du fichier mur
;;    - ecriture du fichier dessin
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun cible ()
 ;; initialisation du script, gestion de la boite de dialogue

 ;; creation d'une liste contenant
 ;; les noms des layer et des blocks
 (setq liste_layer (liste_mot_clef "LAYER"))
 (setq liste_bloc (liste_mot_clef "BLOCK"))

 ;; initialisation de la boite de dialogue
 ;;
 (setq dcl_id (load_dialog "laser8.dcl"))
 ;; charge fichier DCL
 (if (NOT (new_dialog "laser_cible" dcl_id))
   (exit)
 )

 ;; initialisation des listes
 (start_list "liste_cible")
 (mapcar 'add_list liste_bloc)
 (end_list)

 (start_list "liste_mur")
 (mapcar 'add_list liste_layer)
 (end_list)

 (start_list "liste_dessin")
 (mapcar 'add_list liste_layer)
 (end_list)

 ;; recuperation des valeurs precedentes si elles existent
 (if (/= n_bloc_cible nil)
   (set_tile "liste_cible" n_bloc_cible)
 )
 (if (/= n_plan_mur nil)
   (set_tile "liste_mur" n_plan_mur)
 )

 (if (/= n_plan_dessin nil)
   (set_tile "liste_dessin" n_plan_dessin)
 )

 ;; que se passe-t-il lorsque l'on clique sur OK ?
 (action_tile
   "accept"
   "(action_accept_cible)"
 )

 (start_dialog)

 ;; recuperation des valeurs

 (setq nom_bloc_cible (nth (atoi n_bloc_cible) liste_bloc))
 (setq nom_plan_mur (nth (atoi n_plan_mur) liste_layer))
 (setq nom_plan_dessin (nth (atoi n_plan_dessin) liste_layer))

 (unload_dialog dcl_id)

 ;; ---------------------------------------------------------------
 ;; gestion des cibles        

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\mark_1.dat" "w"))

 ;; cela serait beaucoup mieux, mais je ne sais pas comment le faire marcher
 ;; ( setq selection ( ssget "X" '(( 2 . nom_bloc_cible )) ) )

(prompt "\nVeuillez sélectionner les blocs (cibles) à exporter dans mark_1.dat")
 (setq selection (ssget  '((0 . "INSERT"))))

 ;; parcours de la selection
 (setq i 0)
 (setq n (sslength selection))

 ;; indice dans le fichier
 (setq j 0)

 ;; parcours des entites
 (while (< i n)
   (setq entite (entget (ssname selection i)))
   ;;if ( /= ( cdr ( assoc 2 entite ) ) nul )

   (setq nom_bloc (cdr (assoc 2 entite)))

   (if (= nom_bloc nom_bloc_cible)
     (progn
       (setq x (cadr (assoc 10 entite)))
       (setq y (caddr (assoc 10 entite)))

       (setq theta (cdr (assoc 50 entite)))

       ;; ecriture dans le fichier
       (setq j (+ j 1))
       (write-line
         (strcat
           (itoa j)
           " "
           (rtos x)
           " "
           (rtos y)
           " "
           (rtos (/ (* 180 theta) 3.1415926))
           " "
           " 1 1"
         )
         fichier
       )
     )
   )
   (setq i (+ i 1))
 )

 (close fichier)

 ;; ------------------------------------------------------------------
 ;; gestion des murs

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\mur.txt" "w"))
 (export_trait nom_plan_mur)
 (close fichier)

 ;; ------------------------------------------------------------------
 ;; gestion du dessin sur le plan

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\dessin.txt" "w"))
 (export_trait nom_plan_dessin)
 (close fichier)
)

;; -------------------------------------------------------------------------
;; revoie true si caractere est un separateur
;; parametres
;;    aucun
;; valeur retournee :
;;    aucune
(defun separateur (char)
 (or
   (= char (ascii " "))
   (= char (ascii "\n"))
   (= char (ascii "\t"))
   (= char 13)
   (= char 10)
 )
)

(setq script_init 0)
(command "ATTREQ" 1)
(command "ATTDIA" 1)
;; force saisie attributs insertion bloc

;; -------------------------------------------------------------------
;; affichage de depart
(princ
 "\nScripts Laser LASER.LSP v8.0  NMB (c)2001-2010 B.A Systemes. Chargement OK"
)
(princ
 "\n Traj: (VT) (SC) (CL) Cibles: (CIBLE):Export. cibles murs"
)
(princ)

;; Creates here the list for the acisses in the curve (20 points)
(setq ss (list))
(setq s 0.0)
(while (<= s 1.001 )
  (setq ss (append ss (list s) ))
  (setq s ( + s 0.05 ) )
)

;; default values
;; simulation
(setq s_empattement "2000" )

;; cibles
(setq n_bloc_cible ( itoa_safe ( cherche_liste ( liste_mot_clef  "BLOCK" ) "ba-cible") ) )
(setq n_plan_mur ( itoa_safe ( cherche_liste ( liste_mot_clef  "LAYER" ) "ba-laser-mur") ) )
(setq n_plan_dessin ( itoa_safe ( cherche_liste ( liste_mot_clef  "LAYER" ) "ba-trajectoire") ) )


;; ecriture du fichier magnet.txt
(defun export_magnet ()

 (setq fichier (open "c:\\prog_las\\magnet.txt" "w"))

 (if (= nom_bloc_magnet nil)
   (setq nom_bloc_magnet (getstring "\n Nom du bloc magnet :"))
 )

 ;; liste_magnet sort ( ID, Enabled, X, Y, theta)
 (foreach magnet (liste_magnet)
   (progn
     ;; ID
     (princ (nth 0 magnet) fichier)
     (princ " " fichier)
     ;; x
     (princ (nth 2 magnet) fichier)
     (princ " " fichier)
     ;; y
     (princ (nth 3 magnet) fichier)
     (princ " " fichier)
     ;; Enabled
     (princ (nth 1 magnet) fichier)
     (princ "\n" fichier)
   )
 )


 (close fichier)
 (princ "\nExportation magnet terminee")
)

[yb1971]

Salut,

 

Quand on souhaite une modification d'une routine glanée sur internet, le mieux est de s'adresser directement à l'auteur de la routine.

Cela n'est pas glané sur internet déjà mais un Lisp du boulot, le soucis est que l’auteur n'est plus là!

[lecrabe]

Hello

 

Ton probleme (UNE SEULE Routine Lisp) m'interpelle par rapport a un client lambda ...

 

Propos du client lambda : Au fait j'ai qq centaines de routines Lisp qui tournent sur AutoCAD 2010/2011/2012

et qui bien sur pour la plupart d'entre elles ne tournent plus sur un AutoCAD RECENT 2021/2020/2019/2018/2017/etc !

 

SVP comment je fais !?

Sachant que le developpeur Lisp qui etait un salarie est parti depuis longtemps !

 

Et aujourd'hui sur Windows 10, je dois utiliser des versions RECENTES de AutoCAD !!

 

Good Luck, LA SANTE (Stay Safe), Bye, lecrabe "triste"

Automne 2020, la retraite

[yb1971]

Salut,

je n'ai pas essayé ton lisp, et je ne sais pas à quoi il sert.

J'ai simplement supprimé le "x" dans les 3 ssget.

donc il faudra que tu sélectionne manuellement 3 fois quelque chose, à toi de savoir quoi !

la sélection s'entends comme une fenêtre ou une capture, le programme filtre ensuite les bon éléments: on sélectionne une zone.

dis moi si ça marche ?

a+

gégé

;; script Autolisp v8.0 - 
;; 18.02.2010 - NMB
;; utilitaires AutoCAD 
;; pour configuration laser
;;
;; But :
;;           - dessin des trajectoires laser
;;           - exportation des coordonnees des cibles
;; ------------------------------------------------------- 
;; trajectoires :
;; trajectoires disponnibles :
;;   - Virage Traine : (vt)
;;   - virage SurCompense : (sc)
;;   - Changement de Ligne (surcompense) : (cl)
;;
;; ------------------------------------------------------- 
;; cibles
;; exportation dans 2 fichiers :
;;     - mark_1.dat (au format IML) 
;;     - mur.txt    (au format ligne a ligne x1 y1 x2 y2)
;;     - dessin.txt (au format ligne a ligne x1 y1 x2 y2)
;; ces fichiers sont prets a l'emploi pour utilisation les utilitaires windows
;; IML et PsiNav
;;
;;-----------------------------------------------------------------------------
;; Initialisation et gestion de l'IHM

;; --------------------------------------------------------
;; fonction cree pour gere l'action accept trajectoire
;; (recuperation des valeurs du dialogue)
;; parametres : 
;;    AUCUN
;; valeur retournee :
;;   AUNCUNE
(defun action_accept_traj ()
 (setq n_bloc_agv (get_tile "liste_agv"))
 (setq s_empattement (get_tile "edit_empattement"))
 (done_dialog)
)

;; ------------------------------------------------------------------------
;; initialisation du script
;; mise a jour des variables globales
;; saisie des plans, des noms blocs, empattement avec boite de dialogue
;; parametres
;;    AUNCUN
;; valeur retournee
;;    AUCUNE
;;
(defun init ()
 ;; mise du SCU dans quelque chose de correct
 ; (command "_UCS" "G")
 (setq script_init 0)

 ;; vrai si import troncon en cours ...
 (setq import_tronc 0)
 (while (/= script_init 1)
   ;; creation d'une liste contenant les noms de blocs
   (setq liste_bloc (liste_mot_clef "BLOCK"))
   (setq liste_bloc_simul ( filter match_simul_block liste_bloc ))
   ;; initialisation de la boite de dialogue
   ;;
   (setq dcl_id (load_dialog "laser8.dcl"))
   ;; charge fichier DCL
   (if (NOT (new_dialog "laser_traj" dcl_id))
     ( alert "erreur ouverture fichier dcl" )
   )
   ;; initialisation des listes
   (start_list "liste_agv")
   (mapcar 'add_list liste_bloc_simul)
   (end_list)
   ;; recuperation des valeurs precedentes si elles existent

   ;; attention, comme des blocs ou des plans ont pu etre crees
   ;; il faut chercher le numero de la precedente selection
   ;; dans la liste...

   ;; les fonctions suivantes remplissent :
   ;; n_bloc_agv
   ;; n_plan_simu
   ;; n_plan_cote
   ;; n_plan_traj
   ;; n_plan_carf
   ;;                  -> en valeur numerique
   ;;                  -> les valeurs seront ensuite 
   ;;                  -> converties en chaine

   (setq n_bloc_agv
          (cherche_liste liste_bloc_simul nom_bloc_agv)
   )
   (if (/= n_bloc_agv nil)
     (set_tile "liste_agv" (itoa n_bloc_agv))
   )

   (if (/= s_empattement nil)
     (set_tile "edit_empattement" s_empattement)
   )

   (action_tile
     "accept"
     "(action_accept_traj)"
   )
   (start_dialog)

   ;; recuperation des valeurs
   (setq nom_bloc_agv (nth (atoi n_bloc_agv) liste_bloc_simul))
   (setq E (atoi s_empattement))
   (unload_dialog dcl_id)

   (if (= E 0)
     (alert "Empattement non correct!")
   )
   (setq script_init 1)
 )
)


;; insert a block
;; @param
;; blockname block name 
;; x pos in x 
;; y pos in y 
;; theta orientation in degree
( defun insert_block (blockname  x  y theta)
       (command
         "_insert"
         blockname
         "_non" (list x y)
         ""
         ""
         (rad2deg theta)
       )
)

;; --------------------------
;; renvoi le nom du bloc ou nil si l'entite n'est pas un bloc
(defun nom_bloc (entite)
 (setq choix (entget (car entite)))
 (if (= (cdr (assoc 0 choix)) "INSERT")
   (cdr (assoc 2 choix))
   nil
 )
)

;; performs a filter on list
;; @param
;; f filter function, (if f elmt) is used to select elements
;; l list to filter
(defun filter (f l / a)
    (foreach i l 
        ( if ( f i )
            (setq a (append a (list  i) )) 
            nil
        )   
    ) a
) 

;; returns if block name corresponds to simulation
;; 
(defun match_simul_block ( blockname )
  (wcmatch blockname "*SI")
)

;; "safe" itoa
;; @return itoa(i) or nil if str is nil
(defun itoa_safe (i)
   ( if i
      (itoa i)
      nil
   )
)

;; -------------------------------------------------------------------------
;; sauvegarde des parametres qui vont etre modifies pendant le script et
;; modification des valeurs necessaire
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun contexte_debut ()
 ;; sauvegarde du plan courant
 (setq sauve_clayer (getvar "CLAYER"))
)

;; -------------------------------------------------------------------------
;; restauration du contexte
;; remise du layer a la valeur sauvegardee
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun contexte_restaure ()
 ;; restauration du plan
 (command "_layer" "CH" sauve_clayer "")
)

;;-----------------------------------------------------------------------------
;; Fonctions utilitaires pour AutoCAD

;;-----------------------------------------------------------------------

;; -------------------------------------------------------------------------
;; conversion angle en radians en degres
;; parametre
;;   a : angle en radians
;; valeur retournee 
;;  angle en degres
;;
(defun rad2deg (a)
 (* 180 (/ a pi))
)

;; -------------------------------------------------------------------------
;; calcul d'une tangeante
;; parametre
;;   a : angle en radians
;; valeur retournee
;;   tangeante de l'angle
;;   ou erreur si a = 0 mod pi
;;
(defun tan (a)
 (/ (sin a) (cos a))
)

;; -------------------------------------------------------------------------
;; calcul d'un angle en radians entre -pi et +pi
;;    a : angle en radians
;; valeur retournee
;;    a : angle raporte entre -pi et +pi
(defun mod2pi (a)
 (while (> a pi)
   (setq a (- a (* 2.0 pi)))
 )
 (while (< a (- pi))
   (setq a (+ a (* 2.0 pi)))
 )
 a
)

;; -------------------------------------------------------------------------
;; calcul d'un carre
;; parametre
;;    a : valeur
;; valeur retournee
;;    a : carre ( a*a )
;;
(defun carre (a)
 (* a a)
)


;; fonction qui recherche des valeurs dans les tables d'AutoCAD
;; le resultat est une liste, qui contient toutes les valeurs trouvees
;; classees par ordre alphabetique
;;
;; exemple d'utilisation : liste_mot_clef( "LAYER" ) renvoie une liste contenant tous
;; les plans du dessin.
;;
;; cette fonction peut etre utilisee pour :
;; LAYER, BLOCK, ...
;;
;; parametres
;;    mot_clef : chaine contenant un mot clef d'une table AutoCAD
;; valeur retournee
;;    liste contenant l'ensmble des identifiant pour cette clef (cf exemple)
;;
(defun liste_mot_clef (mot_clef)
 (setq liste_mot nil)
 (setq l (tblnext mot_clef 1))
 (while l
   (setq liste_mot
          (cons
            (cdr (assoc 2 l))
            liste_mot
          )
   )
   (setq l (tblnext mot_clef))
 )
 (reverse liste_mot)
 (setq liste_mot (acad_strlsort liste_mot))
)

;; --------------------------------------------------------
;; renvoie le premier numero de article si il est present dans la liste
;; parametre
;;    liste   : liste a examiner
;;    article : element a rechercher 
;; valeur retournee :
;;   indice (dans la liste) de article s'il existe
;;   nil si l'article n'est pas dans la liste
;;
(defun cherche_liste (liste article)
 (if
   (
    /=
     (setq l2 (member article liste))
     nil
   )
    (- (length liste) (length l2))
    nil
 )
)

;; ------------------------------------------------------------------------
;; Fonctions de recherche des elements du plan

(defun liste_magnet ()
 (liste_bloc_attr 1 nil nom_bloc_magnet)
)


;; ------------------------------------------------------------------------
;; exportation

;; ecriture d'une liste sur le disque formattee avec des espaces
;; paramatres :
;; - fichier : descripteur de fichier
;; - debut ligne : chaine a mettre en debut de chaque ligne
;; - list : liste a ecrire
;; - separ : caractere ou chaine de separation
(defun export_liste (fichier debut_ligne liste separ)
 (foreach article liste
   (setq debut 1)
   (if debut_ligne
     (progn
       (princ debut_ligne fichier)
       (princ separ fichier)
     )
   )

   (foreach attr article
     (if debut
       (setq debut nil)
       (princ separ fichier)
     )
     (princ attr fichier)
   )
   (princ "\n" fichier)
 )
)

;; ------------------------------------------------------------------------
;; retourne une liste de bloc avec attributs presents sur le dessin
;; la liste comprend en final
;;   la position d'insertion du bloc ( optionnel ) 
;;   la liste des attributs
;; parametres
;;   insert_pos ( different de nil si la position d'insertion doir etre 
;;                ajoutee dans la liste )
;;   attr_name   ( si different de nil, le nom des champs est mis dans la
;;                 liste )
;;   nom_bloc  nom du bloc
;; valeur retournee :
;;   liste 
;; format du retour :
;; ( ( attribut1, attribut2, ... <x1, y1, theta1> ),
;;   ( attribut1, attribut2, ... <x2, y2, theta2> ),
;;    ...
;; )
;;
(defun liste_bloc_attr (insert_pos attr_name nom_bloc)
 ;; initialisation liste ensmble troncon
 (setq ensemble_bloc nil)
 ;; parcours de la liste des blocs
 (prompt "\nVeuillez sélectionner les blocs contenant les attributs:")
 (setq selection
        (ssget 
               (list (cons 0 "INSERT") (cons 2 nom_bloc))
        )
 )

 (if (/= selection nil)
   (progn
     ;; parcours de la selection
     (setq i 0)
     (setq n (sslength selection))
     (while (< i n)
       (setq entite (entget (ssname selection i)))
       ;; l'entite selectionnee est un bloc compose d'attributs
       ;; on va parcourir l'entite a la recherche des attributs
       (setq id_entite (cdar entite))

       (setq attribut id_entite)

       ;; initialisation bloc courant
       (setq bloc nil)

       ;; test de la presence d'attributs en suite...

       (if (= (cdr (assoc 66 entite)) 1)
         (setq fin 0)
         (setq fin 1)
       )

       ;; principe :
       ;; extraction de la prochaine entite : si nil, 
       ;;  cond arrete le traitement 
       ;; test si entite est "SEQ END" : si oui, cond arrete
       ;;  traitement 
       ;; test si entite est "ATTRIB" : extraction des donnees
       ;;  sinon, rien


       (while
         (AND
           ;; extraction entite du bloc
           (/= (setq attribut (entnext attribut)) nil)
           (= fin 0)
         )

          (if
            (/=
              (cdr (assoc 0 (entget attribut)))
              "SEQEND"
            )

             (progn
               ;; ajout du nom de l'attribut ( si attr_name )
               (if attr_name
                 (setq bloq
                        (
                         append
                          bloc
                          (list (cdr (assoc 2 (entget attribut))))
                        )
                 )
               )
               ;; ajout de la valeur de l'attribut
               (setq bloc
                      (
                       append
                        bloc
                        (list (cdr (assoc 1 (entget attribut))))
                      )
               )
               nil
             )

             (setq fin 1)
             ;; pour passer a l'objet suivant
          )
       )

       ;; point d'insertion ?
       (if insert_pos
         (progn
           (setq point_insertion (cdr (assoc 10 entite)))
           (setq x (car point_insertion))
           (setq y (cadr point_insertion))
           (setq theta (cdr (assoc 50 entite)))

           (if attr_name
             (setq bloc (append bloc (list "x" x "y" y "theta" theta)))
             (setq bloc (append bloc (list x y theta)))
           )
         )
       )

       (setq ensemble_bloc
              (
               append
                ensemble_bloc
                (list bloc)
              )
       )
       (setq i (+ 1 i))
     )
     ensemble_bloc
   )
   nil
 )
)

;; -------------------------------------------------------------------------
;; conversion angle en degre en radians
;; parametre
;;   a : angle en degres
;; valeur retournee 
;;  angle en radians
;;
(defun deg2rad (a)
 (* pi (/ a 180.0))
)

;; -------------------------------------------------------------------------
;; calcul du premier arc du surcompense
;; parametre
;;    s      : represente l'avancement dans le virage
;;              il doit varier entre 0 et 0.5
;; valteur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense_arc1 (s)

 ;; -----> prevoir gestion d'erreur si s<0 et s>0.5

 ;; affectation de xar_t
 ;; pendant que s varie de 0 a 0.5, xar_t varie de 0 a xm

 (setq xar_t (* 2 s xm))
 (setq yar_t (* k xar_t xar_t xar_t))
 ;; calcul du vecteur norme tangeant a la courbe decrite par les roues ar
 (setq u 1)
 (setq v (* 3.0 k xar_t xar_t))
 (setq
   norme (
          distance
           (list u v)
           (list 0 0)
         )
 )

 (setq u (/ u norme))
 (setq v (/ v norme))
 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E u)))
 (setq yav_t (+ yar_t (* E v)))
 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )

 (setq
   cap (
        angle
         (list 0 0)
         (list u v)
       )
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; calcul du deuxieme arc du surcompense
;; parametre
;;    s      : represente l'avancement dans le virage
;;              il doit varier entre 0 et 0.5
;; valteur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense_arc2 (s)

 ;; -----> prevoir gestion d'erreur si s<0.5 et s>1

 ;; affecation de z
 ;; s varie de 0.5 a 1 et z varie de xm a 0

 (setq z (* (- 1 s) 2 xm))
 (setq t (* k z z z))

 ;; calcul du vecteur norme tangeant a la courbe decrite par les roues ar
 (setq u 1)
 (setq v (* 3.0 k z z))
 (setq
   norme (
          distance
           (list u v)
           (list 0 0)
         )
 )

 (setq u (/ u norme))
 (setq v (/ v norme))
 (setq u_2 (+ (* u (cos beta)) (* v (sin beta))))
 (setq v_2 (- (* u (sin beta)) (* v (cos beta))))

 ;; calcul position roue ar dans repere troncon 
 (setq xar_t (- (- xf
                   (* z (cos beta))
                )
                (* t (sin beta))
             )
 )
 (setq yar_t (+ (- yf
                   (* z (sin beta))
                )
                (* t (cos beta))
             )
 )
 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E u_2)))
 (setq yav_t (+ yar_t (* E v_2)))
 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )

 (setq
   cap (
        angle
         (list 0 0)
         (list u_2 v_2)
       )
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; routine de precalcul pour un surcompense
;; calcul des differents parametres de la cubique...

;; -------------------------------------------------------------------------
;; routine de calcul pour un surcompense
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_surcompense (s)
 (if (< s 0.5)
   (calcul_surcompense_arc1 s)
   (calcul_surcompense_arc2 s)
 )
)

;; -------------------------------------------------------------------------
;; SC : surcompense
;; saisie et trace d'un surcompense
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun sc ()

 (init)

 ;;
 ;; SAISIE DES POINTS
 ;;

 (setq p1 (getpoint "\nSC point 1:"))
 (setq p2 (getpoint "\nSC point 2:"))
 (setq p3 (getpoint "\nSC point 3:"))

 ;; saisie de l'encombrement
 (setq enc (getdist "\nSC Encombrement du virage (mm) :"))

 ;; apres la saisie des points, on peut changer les parametres de snap
 (contexte_debut)

 ;;
 ;; CALCUL DES PARAMETRES
 ;;

 ;; extraction des coordonnees
 (setq x1 (car p1))
 (setq x2 (car p2))
 (setq x3 (car p3))

 (setq y1 (cadr p1))
 (setq y2 (cadr p2))
 (setq y3 (cadr p3))

 ;; calcul de l'angle de depart
 (setq angle1 (atan (- y2 y1) (- x2 x1)))

 ;; calcul de l'angle final
 (setq angle2 (atan (- y3 y2) (- x3 x2)))

 ;; modification de x1 et y1 pour tenir compte de l'encombrement du virage
 ;; d est utilise temporairement
 (setq d (distance p1 p2))
 (setq x1 (+ x2 (/ (* (- x1 x2) enc) d)))
 (setq y1 (+ y2 (/ (* (- y1 y2) enc) d)))

 ;; modification de x3 et y3 pour tenir compte de l'encombrement du virage
 ;; d est utilise temporairement
 (setq d (distance p2 p3))
 (setq x3 (+ x2 (/ (* (- x3 x2) enc) d)))
 (setq y3 (+ y2 (/ (* (- y3 y2) enc) d)))

 ;; angle du virage
 (setq beta (- angle2 angle1))

 ;; on veut beta dans [-pi, pi]
 (while (> beta pi)
   (setq beta (- beta (* 2 pi)))
 )
 (while (< beta (- pi))
   (setq beta (+ beta (* 2 pi)))
 )

 (dessin_sc Enc beta x1 y1 angle1)

 ;; restauration du contexte
 (contexte_restaure)
 (princ)
)

;; -------------------------------------------------------------------------
;; calcul_param_sc
;; calcul des parametres d'un virage surcompense
(defun calcul_param_sc (_Enc _beta _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq Enc _Enc)
 (setq beta _beta)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)


 ;; calcul de la fin du virage

 ;; calcul de la fin du virage en fin de troncon
 (setq xf (* (+ 1 (cos beta)) Enc))
 (setq yf (* (sin beta) Enc))

 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq x3
        (
         +
          x1
          (
           -
            (* xf (cos angle1))
            (* yf (sin angle1))
          )
        )
 )
 (setq y3
        (
         +
          y1
          (
           +
            (* yf (cos angle1))
            (* xf (sin angle1))
          )
        )
 )

 ;; variable intermediaire
 (setq tb2 (tan (/ beta 2.0)))
 ;; tan( beta/ 2 )

 ;; rayon des roues arrieres
 (setq rar (/ Enc tb2))

 ;; parametres de la cubique  
 ;; on calcul morceau par morceau...
 (setq k (* tb2 tb2))
 ;; (tan( beta/2) )^2
 (setq k (+ 3 k))
 ;; 3 + (tan( beta/2) )^2 
 (setq k (* k k))
 ;; ( 3 + (tan( beta/2) )^2 )^2

 (setq k (/ k (* 27 rar rar tb2)))

 ;; coordonnees de fin de virage dans le repere troncon
 (setq xf (* enc (+ 1 (cos beta))))
 (setq yf (* enc (sin beta)))

 ;; coordonnees de changement d'arc dans le repere troncon
 (setq xm (sqrt (abs (/ tb2 (* 3.0 k)))))
 (setq ym (* xm xm xm k))

 ;; calcul de la longeur theorique
 (setq longueur_troncon (abs (* rar beta)))
)

;; chagne the layer, if exists otherwise an error message
(defun change_layer_safe (layername)
   ( if ( member layername (liste_mot_clef "LAYER") ) 
       ;;( setvar "CLAYER" layername )
       (command "_layer" "E" layername "")
       ( alert (strcat "Unable to find layer:" layername) )
   )
)

;; dessin d'une polyline
;;le parametre doit etre une list de type ( ( x1 y1) (x2 y2) ... )
(defun draw_traj (lst)
   (change_layer_safe "ba-trajectoire")
   (command "_.pline" 
       (foreach pt lst (command "_non" pt)) ; draw each point from the list
   ) ; draw the polyline
   (princ )
)

;; extract rear point from traj point, which is index 3 and  4 in list
;; @param :
;; l : list as (xav xar yav yar theta)
;; @return (xar yar)
(defun extrat_rear_point (l)
  (list (nth 2 l) (nth 3 l))
)

;; extract rear point from traj point, which is index 3 and  4 in list
;; @param :
;; @return (xar yar theta)
(defun extrat_rear_pose (l)
  (list (nth 2 l) (nth 3 l) (nth 4 l))
)

;; draw agv pose
;; @param:
;; l : list as (xav xar yav yar theta)
(defun draw_agv_pose (agv_pose)
  (change_layer_safe "ba-AGV\ simul")
  (insert_block nom_bloc_agv (nth 0 agv_pose) (nth 1 agv_pose) (nth 4 agv_pose) )
)

;; -------------------------------------------------------------------------
;; dessin_sc : dessin d'un virage surcompense
;; parametres :
;;      Enc           : encombrement du virage
;;      beta          : angle du virage 
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_sc (Enc beta x1 y1 angle1 )

 (calcul_param_sc Enc beta x1 y1 angle1 )
 (setq traj (mapcar 'calcul_surcompense ss) )
 (draw_traj (mapcar 'extrat_rear_point traj))
 (mapcar 'draw_agv_pose traj)  
)


;; -------------------------------------------------------------------------
;; calcul du premier arc d'un changement de ligne
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 0.5
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne1 (s)
 ;; xar_t varie de 0 a l pendant que s varie de 0 a 0.5
 (setq xar_t (* 2.0 s l))
 (setq yar_t
        (/
          (* d xar_t xar_t xar_t (- 2.0 (/ xar_t l)))
          (* l l l)
        )
 )

 (setq cap
        (
         atan
          (/
            (* 2 d xar_t xar_t (- (* 3 l) (* 2 xar_t)))
            (* l l l l)
          )
        )
 )

 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E (cos cap))))
 (setq yav_t (+ yar_t (* E (sin cap))))

 ;; nouvelle version sur roue AR
 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )

 (list xav yav xar yar (+ cap angle1) )
)

;; -------------------------------------------------------------------------
;; calcul du deuxieme arc d'un chagnement de ligne 
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.5 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne2 (s)
 ;; z varie de l a 0 pendant que s varie de 0.5 a 1.0
 (setq z (* (- 1 s) 2 l))
 (setq t
        (/
          (* d z z z (- 2.0 (/ z l)))
          (* l l l)
        )
 )
 (setq cap (
            atan (/
                   (* 2 d z z (- (* 3 l) (* 2 z)))
                   (* l l l l)
                 )
           )
 )

 (setq xar_t (- (* 2.0 l) z))
 (setq yar_t (- (* 2.0 d) t))

 ;; calcul position roue avant dans repere troncon
 (setq xav_t (+ xar_t (* E (cos cap))))
 (setq yav_t (+ yar_t (* E (sin cap))))

 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )
 (list xav yav xar yar (+ cap angle1))
)

;; -------------------------------------------------------------------------
;; routine de calcul pour un changement de ligne
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_chgtligne (s)
 (if (< s 0.5)
   (calcul_chgtligne1 s)
   (calcul_chgtligne2 s)
 )
)

;; -------------------------------------------------------------------------
;; CL : changement de ligne
;; saisie et trace d'un changement de ligne surcompense
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun cl ()

 (init)

 ;;
 ;; SAISIE DES POINTS
 ;; 

 (setq p1 (getpoint "\nCL point 1:"))
 (setq p2 (getpoint "\nCL point 2:"))
 (setq p3 (getpoint "\nCL point 3:"))

 ;; extraction des coordonnees
 (setq x1 (car p1))
 (setq x2 (car p2))
 (setq x3 (car p3))

 (setq y1 (cadr p1))
 (setq y2 (cadr p2))
 (setq y3 (cadr p3))

 ;; recalcul de x2 et y2 pour avoir un rectangle
 ;; k est utilise temporairement

 (setq k
        (+ (* (- x2 x1) (- x3 x1))
           (* (- y2 y1) (- y3 y1))
        )
 )
 (setq k (/ k
            (+ (* (- x2 x1) (- x2 x1))
               (* (- y2 y1) (- y2 y1))
            )
         )
 )

 (setq x2 (+ x1 (* k (- x2 x1))))
 (setq y2 (+ y1 (* k (- y2 y1))))

 ;; apres la saisie des points, on peut changer les parametres de snap
 (contexte_debut)

 ;;
 ;; CALCUL DES PARAMETRES
 ;;

 ;; calcul angle de depart
 (setq angle1 (atan (- y2 y1) (- x2 x1)))


 ;; calcul de la DEMI longueur du changement de ligne
 (setq l
        (* 0.5 (sqrt (+ (carre (- x2 x1)) (carre (- y2 y1)))))
 )

 ;; calcul de la DEMI largeur du changement de ligne
 (setq d
        (* 0.5 (sqrt (+ (carre (- x3 x2)) (carre (- y3 y2)))))
 )
 ;; changement de signe de d dans le cas d'un virage a droite
 ;; tres elegamment, on utilise le signe du produit vectoriel...

 (if (<
       (-
         (* (- x2 x1) (- y3 y1))
         (* (- x3 x1) (- y2 y1))
       )
       0
     )
   (setq d (- 1.0 d))
 )

 (dessin_cl l d x1 y1 angle1)

 ;; restauration du contexte
 (contexte_restaure)
 (princ)
)

;; -------------------------------------------------------------------------
;; calcul des parametres du virage changement de ligne
;; parametres
;;      _l               : demi longueur cl
;;      _d               : demi largeur cl
;;      _x1,_y1,_ angle1 : parametres du repere absolu
(defun calcul_param_cl (_l _d _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq l _l)
 (setq d _d)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)

 ;; calcul de la fin du virage en fin de troncon
 (setq xf (* 2.0 l))
 (setq yf (* 2.0 d))

 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq x3
        (
         +
          x1
          (
           -
            (* xf (cos angle1))
            (* yf (sin angle1))
          )
        )
 )
 (setq y3
        (
         +
          y1
          (
           +
            (* yf (cos angle1))
            (* xf (sin angle1))
          )
        )
 )

 ;; calcul de la longeur theorique
 (setq longueur_troncon (* 2 l))

)
       
;; -------------------------------------------------------------------------
;; dessin_cl : dessin d'un changement de ligne
;; parametres
;;      l             : demi longueur cl
;;      d             : demi largeur cl
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_cl (l d x1 y1 angle1 )

 (calcul_param_cl l d x1 y1 angle1 )
 (setq traj (mapcar 'calcul_chgtligne ss) )
 (draw_traj (mapcar 'extrat_rear_point traj))
 (mapcar 'draw_agv_pose traj) 
 
)

;; -------------------------------------------------------------------------
;; routine de calcul pour un virage traine
;; parametres 
;;     s       : represente l'avancement dans le virage
;;                il doit varier entre 0.0 et 1.0 pour le virage traine
;;                lorsqu'il est superieur a 1 on calcul la traine pour le troncon droit suivant
;; valeur retournee : (liste)
;; (  xav(mm) yav(mm) xar(mm) yar(mm) theta(rad) )
;;
(defun calcul_viragetraine (s)

 ;; initialisation (alpha2 memorise l'ancien alpha pour ne pas avoir a gerer le pas ici)
 (if (= s 0.0)
   (progn
     (setq phi 0)
     (setq cap 0)
     (setq alpha2 s)
   )
 )

 (setq alpha (abs (* s beta)))
 ;; angle realise dans le virage

 ;; distance parcourue depuis dernier appel
 (setq dist (abs (* rayon (- alpha alpha2))))

 ;; distance parcourue dans la ligne droite apres le virage
 (if (> s 1.01)
   (setq dist2 (+ dist2 dist))
   (setq dist2 0)
 )

 ;; calcul de la position de la roue avant dans le repere du troncon
 (if (<= s 1.01)
   (progn
     ;; le virage est en cours
     (setq xav_t (* rayon (sin alpha)))
     (setq yav_t (* rayon (- 1.0 (cos alpha))))
   )
   (progn
     ;; le virage est termine
     (setq xav_t (+ (* rayon (sin (abs beta)))
                    (* dist2 (cos (abs beta)))
                 )
     )
     (setq yav_t (+ (* rayon (- 1.0 (cos (abs beta))))
                    (* dist2 (sin (abs beta)))
                 )
     )
   )
 )

 (if (= sens_virage "D")
   (setq yav_t (* -1 yav_t))
 )

 ;; simulation de l'angle de tourelle...

 (if (<= s 1.01)
   (if (= sens_virage "G")
     (setq phi (- alpha cap))
     ;; alpha - cap
     (setq phi (- 0 alpha cap))
     ;; -alpha - cap
   )
   (if (= sens_virage "G")
     (setq phi (- (abs beta) cap))
     ;; alpha - cap
     (setq phi (- 0 (abs beta) cap))
     ;; -alpha - cap
   )
 )

 ;; variation de cap
 (setq cap (+ cap (/ (* dist (sin phi)) E)))

 ;; memorisation ancien alpha
 (setq alpha2 alpha)

 ;; calcul de la position des roues arrieres dans le repere du troncon
 (setq xar_t (- xav_t (* E (cos cap))))
 (setq yar_t (- yav_t (* E (sin cap))))

 ;; calcul position roue avant dans repere absolu
 (setq xav (- (+ x1 (* xav_t (cos angle1)))
              (* yav_t (sin angle1))
           )
 )
 (setq yav (+ (+ y1 (* xav_t (sin angle1)))
              (* yav_t (cos angle1))
           )
 )
 ;; calcul position roue arriere dans repere absolu
 (setq xar (- (+ x1 (* xar_t (cos angle1)))
              (* yar_t (sin angle1))
           )
 )
 (setq yar (+ (+ y1 (* xar_t (sin angle1)))
              (* yar_t (cos angle1))
           )
 )
 (list xav yav xar yar (+ cap angle1) )
)
;; -------------------------------------------------------------------------
;; traiter_choix_vt
;; routine de traitement de l'arc selectionne
;; Parametre : entite selectionnee
;; retour
;; 0 si succes
(defun traiter_choix_vt (choix)

 ;; verifier que c'est un arc
 (if (/= (cdr (assoc 0 choix)) "ARC")
   (setq res 1)
   (progn

     ;;extraction du centre...
     (setq centre_cercle (cdr (assoc 10 choix)))

     ;;extraction du rayon
     (setq rayon (cdr (assoc 40 choix)))

     ;; extraction des angles
     (setq angle1 (cdr (assoc 50 choix)))
     (setq angle2 (cdr (assoc 51 choix)))

     ;; angle1 et angle2 sont comptes (par AutoCAD)
     ;; pour un arc oriente dans le sens trigo
     ;; entre 0 et 2 pi.
     ;; Comme on souhaite toujours avoir angle1 < angle2
     ;; on modifie eventuellement angle1

     (if (> angle1 angle2)
       (setq angle1 (- angle1 (* 2 pi)))
     )

     ;; savoir si c'est un virage a droite ou a gauche...
     (if (= mode_choix_sens_virage 1)
       (progn
         (initget 1 "Droite Gauche")
         (setq sens_virage
                (getkword "VT Sens du virage (Droite Gauche)")
         )
         (setq sens_virage (substr sens_virage 1 1))
       )
       (setq sens_virage "G")
     )

     ;; permuter les angles si besoin
     (if (= sens_virage "D")
       (progn
         ;; echange de angle1 et angle2 
         (setq temp angle1)
         (setq angle1 angle2)
         (setq angle2 temp)
       )
     )

     ;; calcul de x1 y1 : point de depart du virage 
     (setq x1 (+ (car centre_cercle) (* rayon (cos angle1))))
     (setq y1 (+ (cadr centre_cercle) (* rayon (sin angle1))))
     ;; calcul de x3 et y3 : point d'arrivee du virage
     (setq x3 (+ (car centre_cercle) (* rayon (cos angle2))))
     (setq y3 (+ (cadr centre_cercle) (* rayon (sin angle2))))

     ;; angle1 represente maintenant le cap du chariot en entree de virage
     ;; et angle2 le cap en fin de virage...

     (if (= sens_virage "G")
       (progn
         (setq angle1 (+ angle1 (/ pi 2)))
         (setq angle2 (+ angle2 (/ pi 2)))
       )
       (progn
         (setq angle1 (- angle1 (/ pi 2)))
         (setq angle2 (- angle2 (/ pi 2)))
       )
     )

     (setq beta (- angle2 angle1))

     ;; angle1 n'est peut-etre pas dans le bon interval
     (setq angle1 (mod2pi angle1))

     (dessin_vt rayon beta x1 y1 angle1)
     (setq res 0)
   )
 )
 res
)

;; -------------------------------------------------------------------------
;; VT : virage traine (nouvelle version : selection d'un arc)
;; saisie et trace d'un virage traine
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun vt ()
 (init)
 (contexte_debut)
 ;; demander une selection
 (setq entite nil)

 (while (= entite nil)
   (setq entite (entsel "\n VT : cliquer sur un arc"))
 )
 (setq mode_choix_sens_virage 1)

 ;; extraire l'entite choisie
 (setq choix (entget (car entite)))
 (if (= (traiter_choix_vt choix) 1)
   (princ "\n ce n'est pas un arc !!")
 )
 (contexte_restaure)
)

;; -------------------------------------------------------------------------
;; calcul_param_vt
;; calcul des parametres du virage traine
(defun calcul_param_vt (_rayon _beta _x1 _y1 _angle1 )

 ;; sauvegarde des parametres
 (setq rayon _rayon)
 (setq beta _beta)
 (setq x1 _x1)
 (setq y1 _y1)
 (setq angle1 _angle1)

 ;; calcul de la fin du virage

 ;; calcul de la fin du virage en fin de troncon
 (if (= sens_virage "G")
   (progn
     (setq xf (* (sin beta) rayon))
     (setq yf (* (- 1 (cos beta)) rayon))
   )
   (progn
     (setq xf (* (- (sin beta)) rayon))
     (setq yf (* (- (cos beta) 1) rayon))
   )
 )
 ;; calcul de x3 et y3 : position de fin dans rep abs
 (setq x3
        (
         +
          x1
          (
           -
            (* xf (cos angle1))
            (* yf (sin angle1))
          )
        )
 )
 (setq y3
        (
         +
          y1
          (
           +
            (* yf (cos angle1))
            (* xf (sin angle1))
          )
        )
 )

 ;; calcul de la longeur theorique
 (setq longueur_troncon (abs (* rayon beta)))

)

;; -------------------------------------------------------------------------
;; dessin_vt : dessin d'un virage traine
;; parametres :
;;      rayon         : rayon du virage
;;      beta          : angle du virage 
;;      x1,y1, angle1 : parametres du repere absolu
(defun dessin_vt (rayon beta x1 y1 angle1 )
   (calcul_param_vt rayon beta x1 y1 angle1)
   (setq traj (mapcar 'calcul_viragetraine ss) )
   (draw_traj (mapcar 'extrat_rear_point traj))
   (mapcar 'draw_agv_pose traj)    
)

;; -------------------------------------------------------------------------
;; fonction cree pour gerer l'action accept cible
;; (recuperation des valeurs du dialogue)
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun action_accept_cible ()
 (setq n_bloc_cible (get_tile "liste_cible"))
 (setq n_plan_mur (get_tile "liste_mur"))
 (setq n_plan_dessin (get_tile "liste_dessin"))
 (done_dialog)
)

;; -------------------------------------------------------------------------
;; fonction cree pour gere l'action accept cible
;; (recuperation des valeurs du dialogue)
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun action_accept_cible ()
 (setq n_bloc_cible (get_tile "liste_cible"))
 (setq n_plan_mur (get_tile "liste_mur"))
 (setq n_plan_dessin (get_tile "liste_dessin"))
 (done_dialog)
)

;; -------------------------------------------------------------------------
;; fonction d'exortation de traits vers un fichier texte
;; le nom du fichier est fichier
;; l'exportation se fait sur la selection passee en parametre
;; parametres :
;; nom plan : nom du plan a filtrer ou vide
;; valeur retournee
;; AUCUNE
(defun export_trait (nom_plan)
(prompt "\nVeuillez sélectionner les trait (lignes)à exporter :")
 (setq selection (ssget  '((0 . "LINE"))))

 (setq i 0)
 (setq n (sslength selection))

 (princ "export_trait( nom plan = ")
 (princ nom_plan)
 (princ " )\n")
 (princ " lg selection = ")
 (princ n)
 (princ " \n")

 ;; parcours des entites
 (while (< i n)
   (setq entite (entget (ssname selection i)))
   (if
     (or
       (= nom_plan "*")
       (= (cdr (assoc 8 entite)) nom_plan)
     )
      (progn
        (setq x1 (cadr (assoc 10 entite)))
        (setq y1 (caddr (assoc 10 entite)))
        (setq x2 (cadr (assoc 11 entite)))
        (setq y2 (caddr (assoc 11 entite)))

        ;; ecriture dans le fichier

        (write-line
          (strcat
            (rtos x1)
            " "
            (rtos y1)
            " "
            (rtos x2)
            " "
            (rtos y2)
            "\n"
          )
          fichier
        )
      )
   )
   (setq i (+ i 1))
 )
)

;; -------------------------------------------------------------------------
;; fonction qui gere l'exportation des cibles au format IML    
;;    - saisie du nom du bloc qui definit les cibles (DCL)
;;    - parcours de la base de donnee pour extraire les blocs cibles
;;    - ecriture du fichier cible
;;    - ecriture du fichier mur
;;    - ecriture du fichier dessin
;; parametres
;;    AUCUN
;; valeur retournee :
;;    AUCUNE
;;
(defun cible ()
 ;; initialisation du script, gestion de la boite de dialogue

 ;; creation d'une liste contenant
 ;; les noms des layer et des blocks
 (setq liste_layer (liste_mot_clef "LAYER"))
 (setq liste_bloc (liste_mot_clef "BLOCK"))

 ;; initialisation de la boite de dialogue
 ;;
 (setq dcl_id (load_dialog "laser8.dcl"))
 ;; charge fichier DCL
 (if (NOT (new_dialog "laser_cible" dcl_id))
   (exit)
 )

 ;; initialisation des listes
 (start_list "liste_cible")
 (mapcar 'add_list liste_bloc)
 (end_list)

 (start_list "liste_mur")
 (mapcar 'add_list liste_layer)
 (end_list)

 (start_list "liste_dessin")
 (mapcar 'add_list liste_layer)
 (end_list)

 ;; recuperation des valeurs precedentes si elles existent
 (if (/= n_bloc_cible nil)
   (set_tile "liste_cible" n_bloc_cible)
 )
 (if (/= n_plan_mur nil)
   (set_tile "liste_mur" n_plan_mur)
 )

 (if (/= n_plan_dessin nil)
   (set_tile "liste_dessin" n_plan_dessin)
 )

 ;; que se passe-t-il lorsque l'on clique sur OK ?
 (action_tile
   "accept"
   "(action_accept_cible)"
 )

 (start_dialog)

 ;; recuperation des valeurs

 (setq nom_bloc_cible (nth (atoi n_bloc_cible) liste_bloc))
 (setq nom_plan_mur (nth (atoi n_plan_mur) liste_layer))
 (setq nom_plan_dessin (nth (atoi n_plan_dessin) liste_layer))

 (unload_dialog dcl_id)

 ;; ---------------------------------------------------------------
 ;; gestion des cibles        

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\mark_1.dat" "w"))

 ;; cela serait beaucoup mieux, mais je ne sais pas comment le faire marcher
 ;; ( setq selection ( ssget "X" '(( 2 . nom_bloc_cible )) ) )

(prompt "\nVeuillez sélectionner les blocs (cibles) à exporter dans mark_1.dat")
 (setq selection (ssget  '((0 . "INSERT"))))

 ;; parcours de la selection
 (setq i 0)
 (setq n (sslength selection))

 ;; indice dans le fichier
 (setq j 0)

 ;; parcours des entites
 (while (< i n)
   (setq entite (entget (ssname selection i)))
   ;;if ( /= ( cdr ( assoc 2 entite ) ) nul )

   (setq nom_bloc (cdr (assoc 2 entite)))

   (if (= nom_bloc nom_bloc_cible)
     (progn
       (setq x (cadr (assoc 10 entite)))
       (setq y (caddr (assoc 10 entite)))

       (setq theta (cdr (assoc 50 entite)))

       ;; ecriture dans le fichier
       (setq j (+ j 1))
       (write-line
         (strcat
           (itoa j)
           " "
           (rtos x)
           " "
           (rtos y)
           " "
           (rtos (/ (* 180 theta) 3.1415926))
           " "
           " 1 1"
         )
         fichier
       )
     )
   )
   (setq i (+ i 1))
 )

 (close fichier)

 ;; ------------------------------------------------------------------
 ;; gestion des murs

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\mur.txt" "w"))
 (export_trait nom_plan_mur)
 (close fichier)

 ;; ------------------------------------------------------------------
 ;; gestion du dessin sur le plan

 ;; ouverture d'un fichier
 (setq fichier (open "c:\\prog_las\\dessin.txt" "w"))
 (export_trait nom_plan_dessin)
 (close fichier)
)

;; -------------------------------------------------------------------------
;; revoie true si caractere est un separateur
;; parametres
;;    aucun
;; valeur retournee :
;;    aucune
(defun separateur (char)
 (or
   (= char (ascii " "))
   (= char (ascii "\n"))
   (= char (ascii "\t"))
   (= char 13)
   (= char 10)
 )
)

(setq script_init 0)
(command "ATTREQ" 1)
(command "ATTDIA" 1)
;; force saisie attributs insertion bloc

;; -------------------------------------------------------------------
;; affichage de depart
(princ
 "\nScripts Laser LASER.LSP v8.0  NMB (c)2001-2010 B.A Systemes. Chargement OK"
)
(princ
 "\n Traj: (VT) (SC) (CL) Cibles: (CIBLE):Export. cibles murs"
)
(princ)

;; Creates here the list for the acisses in the curve (20 points)
(setq ss (list))
(setq s 0.0)
(while (<= s 1.001 )
  (setq ss (append ss (list s) ))
  (setq s ( + s 0.05 ) )
)

;; default values
;; simulation
(setq s_empattement "2000" )

;; cibles
(setq n_bloc_cible ( itoa_safe ( cherche_liste ( liste_mot_clef  "BLOCK" ) "ba-cible") ) )
(setq n_plan_mur ( itoa_safe ( cherche_liste ( liste_mot_clef  "LAYER" ) "ba-laser-mur") ) )
(setq n_plan_dessin ( itoa_safe ( cherche_liste ( liste_mot_clef  "LAYER" ) "ba-trajectoire") ) )


;; ecriture du fichier magnet.txt
(defun export_magnet ()

 (setq fichier (open "c:\\prog_las\\magnet.txt" "w"))

 (if (= nom_bloc_magnet nil)
   (setq nom_bloc_magnet (getstring "\n Nom du bloc magnet :"))
 )

 ;; liste_magnet sort ( ID, Enabled, X, Y, theta)
 (foreach magnet (liste_magnet)
   (progn
     ;; ID
     (princ (nth 0 magnet) fichier)
     (princ " " fichier)
     ;; x
     (princ (nth 2 magnet) fichier)
     (princ " " fichier)
     ;; y
     (princ (nth 3 magnet) fichier)
     (princ " " fichier)
     ;; Enabled
     (princ (nth 1 magnet) fichier)
     (princ "\n" fichier)
   )
 )


 (close fichier)
 (princ "\nExportation magnet terminee")
)

 

 

Merci déjà GEGEMATIC.

Donc après avoir essayer, cela ne fonctionne plus!

 

Ce Lisp nous sert effectivement à plusieurs choses:

 

-commande (sc) : qui nous permet de faire des courbes de virage suivant un empattement défini et un point de navigation avec un Bloc.

 

- commande (cl) : idem que "sc" mais pour un changement d'axe.

 

- commande (cible) : c'est celle-ci que je voudrais qui soit modifiee! donc celle-ci nous permet d'extraire la position x,y d'un bloc (qui sont des réflecteurs pour nous); d'extraire le contenu d'un calque (des murs pour nous) et le contenu d'un autre calque (des trajectoires pour nous). Donc 3 fichiers (1 dessin.txt / 2 mur.txt / 3 Mark_1.dat).

 

Ces fichiers sont ensuite utilisés avec un autre logiciel. Mon souci en fait, c'est que suivant la taille de l'affaire sur-laquelle nous bossons, quand on traite les données extraites, cela peut-être très long... D'où mon souhait de pouvoir selectionner juste une partie du plan, plutôt que de calculer toute l'affaire.

 

Bonne fin de journée et encore merci

[GEGEMATIC]

Salut,

Si ça ne fonctionne pas en sélectionnant manuellement,

(3 fois minimum, je le répète, je n'ai pas regardé si ces ssget étaient dans un boucle)

l'adaptation de ton logiciel est du ressort d'un développeur, car le travail nécessaire dépasse selon moi le cadre de l'entraide.

mais tout le monde ne partage pas mon avis ...

a+

gégé