Développer les surfaces développables

[vévou]

Bonjour,

 

Si si .. ça intéresse

 

J'ai un peu le même type de routine peut être un peu plus élaborée, puisqu'elle génère les points de repères disposés sur la pièce en 3D lors de la mise à plat ...

 

J'ai quelques soucis avec ces routines (il y en a deux principales), une qui met à plat des surfaces un peu comme des tranches d'oranges, une autre qui met à plat une forme vrillée comme une papillote .... Ce type de routine s'adresse pour du travail de confection, mise à plat de surfaces de tissus !

 

Depuis l'avênement du 64 bits, elles ne fonctionnent plus correctement, y aurait il quelqu'un ici capable de modifier et éventuellement les améliorer ?

 

à quelle boite dois je m'adresser ?

 

 

le créateur de ces formidables routines est hélas décédé :(

[(gile)]

Je m'aperçois aujourd'hui que ce LISP ne fonctionne pas avec les nouvelles versions.

En effet, la commande SURFREGL (_RULESURF) ne génère plus des maillages de type POLYLINE mais des maillages de type MESH.

Voici donc une nouvelle version (renommée MESHDEV) pour développer les maillages créés avec SURFREG depuis 2013 il me semble, tout ce qui a tété dit précédemment concernant la validité et la précision des maillages reste valable.

 

(vl-load-com)
(or *acad* (setq *acad* (vlax-get-acad-object)))
(or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))

;; gc:massoc
;; Retourne la liste de toutes les valeurs pour le code spécifié dans une liste d'association
;;
;; Arguments
;; key : la clé à rechercher dans la liste
;; alst : une liste d'association
(defun gc:massoc (key alst)
 (if (setq alst (member (assoc key alst) alst))
   (cons (cdar alst) (gc:massoc key (cdr alst)))
 )
)

;; gc:acos
;; Retourne l'arc cosinus du nombre
;;
;; Argument
;; n : le cosinus de l'angle
(defun gc:acos (n)
 (cond
   ((equal n 1. 1e-9) 0.)
   ((equal n -1. 1e-9) pi)
   ((< -1. n 1.)
    (atan (sqrt (- 1. (expt n 2))) n)
   )
 )
)

;; gc:breakAt
;; Retourne une liste de deux sous listes,
;; la première contenant les n premiers éléments, la seconde les éléments restants
;;
;; Arguments
;; n : le nombre d'éléments pour la première sous liste
;; l : une liste
(defun gc:breakAt (n l / r)
 (while (and l (< 0 n))
   (setq r (cons (car l) r)
         l (cdr l)
         n (1- n)
   )
 )
 (list (reverse r) l)
)

(defun c:MeshDev (/ *error* ent elst lst1 lst2 rslt1 rslt2 n1 n2)
 (defun *error* (msg)
   (and msg
        (/= msg "Fonction annulée")
        (prompt (strcat "\nErreur: " msg))
   )
   (and osm (setvar 'osmode osm))
   (and cmd (setvar 'cmdecho cmd))
   (and del (setvar 'delobj del))
   (vla-EndUndoMark *acdoc*)
   (princ)
 )

 (defun sqr (x) (* x x))

 (defun third_pt (pt1 pt2 dist1 dist2 /)
   (cond
     ((zerop dist1) pt1)
     ((zerop dist2) pt2)
     (T
      (polar
        pt1
        (+ (angle pt1 pt2)
           (gc:acos
             (/ (+ (sqr (distance pt1 pt2)) (sqr dist1) (- (sqr dist2)))
                (* 2 (distance pt1 pt2) dist1)
             )
           )
        )
        dist1
      )
     )
   )
 )

 (defun index_name (tbl prfx / nom compt)
   (setq nom   (strcat prfx "1")
         compt 1
   )
   (while (tblsearch tbl nom)
     (setq compt (1+ compt)
           nom   (strcat prfx (itoa compt))

     )
   )
   nom
 )

 (while
   (not
     (and
       (setq
         ent (car (entsel "\Sélectionnez la surface à développer: "))
       )
       (= (cdr (assoc 0 (setq elst (entget ent)))) "MESH")
     )
   )
 )
 (mapcar 'set
         '(lst1 lst2)
         (gc:breakAt (/ (cdr (assoc 92 elst)) 2) (gc:massoc 10 elst))
 )
 (if (equal (car lst1) (car lst2) 1e-9)
   (setq rslt1 (cons '(0 0 0) rslt1)
         rslt2 (cons '(0 0 0) rslt2)
         rslt1 (cons (polar '(0 0 0)
                            (angle (car lst1) (cadr lst1))
                            (distance (car lst1) (cadr lst1))
                     )
                     rslt1
               )
         rslt2 (cons (third_pt (car rslt1)
                               '(0 0 0)
                               (distance (cadr lst1) (cadr lst2))
                               (distance (car lst2) (cadr lst2))
                     )
                     rslt2
               )
         lst1  (cdr lst1)
         lst2  (cdr lst2)
   )
   (setq rslt1 (cons '(0 0 0) rslt1)
         rslt2 (cons (polar '(0 0 0)
                            (angle (car lst1) (car lst2))
                            (distance (car lst1) (car lst2))
                     )
                     rslt2
               )
   )
 )
 (setq n1 0
       n2 0
 )
 (repeat (1- (length lst1))
   (setq rslt1 (cons (third_pt
                       (car rslt1)
                       (car rslt2)
                       (distance (nth n1 lst1)
                                 (nth (setq n1 (1+ n1)) lst1)
                       )
                       (distance (nth n2 lst2) (nth n1 lst1))
                     )
                     rslt1
               )
   )
   (if (equal (nth n1 lst1) (nth (1+ n2) lst2) 1e-9)
     (setq rslt2 (cons (car rslt1) rslt2)
           n2    (1+ n2)
     )
     (setq rslt2
            (cons (third_pt
                    (car rslt1)
                    (car rslt2)
                    (distance (nth n1 lst1) (nth (1+ n2) lst2))
                    (distance (nth n2 lst2)
                              (nth (setq n2 (1+ n2)) lst2)
                    )
                  )
                  rslt2
            )
     )
   )
 )

 (vla-StartUndoMark *acdoc*)
 (setq osm (getvar 'osmode)
       cmd (getvar 'cmdecho)
       del (getvar 'delobj)
 )

 (setvar 'cmdecho 0)
 (setvar 'osmode 0)
 (setvar 'delobj 1)

 (setq ss (ssadd))
 (foreach l (list rslt1 rslt2)
   (if (not
         (vl-every '(lambda (pt) (equal pt (car l) 1e-9)) l)
       )
     (progn
       (command "_.spline")
       (mapcar 'command l)
       (command "" "" "")
       (ssadd (entlast) ss)
     )
   )
 )
 (foreach fun (list 'car 'last)
   (if (not (equal (apply fun (list rslt1))
                   (apply fun (list rslt2))
                   1e-9
            )
       )
     (progn
       (command "_.line"
                (apply fun (list rslt1))
                (apply fun (list rslt2))
                ""
       )
       (ssadd (entlast) ss)
     )
   )
 )
 (setq ind (index_name "BLOCK" "MeshDev_"))
 (command "_.block" ind '(0 0 0) ss "")
 (setvar "OSMODE" osm)
 (command "_.insert" ind "_scale" 1)
 (princ "\nSpécifiez le point d'insertion: ")
 (command pause)
 (princ (strcat "\nSpécifiez l'angle de rotation <"
                (angtos 0)
                ">: "
        )
 )
 (command pause)
 (setq bloc (entlast))
 (initget "Oui Non")
 (if (= "Oui"
        (getkword "\nEffectuer un miroir ? [Oui/Non] < Non >: ")
     )
   (progn
     (command "_mirror"
              bloc
              ""
              (setq pt (cdr (assoc 10 (entget bloc))))
              "_non"
              (polar pt 0.0 1)
              "_yes"
              "_.explode"
              bloc
              "_.block"
              ind
              "_yes"
              pt
              "_previous"
              ""
     )
     (command "_.insert" ind "_scale" 1)
     (princ "\nSpécifiez le point d'insertion: ")
     (command pause)
     (princ (strcat "\nSpécifiez l'angle de rotation <"
                    (angtos 0)
                    ">: "
            )
     )
     (command pause)
   )
 )
 (initget "Oui Non")
 (if (= "Oui"
        (getkword (strcat "\nRenommer le bloc \""
                          ind
                          "\" ? [Oui/Non] < Non >: "
                  )
        )
     )
   (progn
     (initdia)
     (command "_.rename" "_block")
     (while (< 7 (getvar "CMDACTIVE"))
       (command pause)
     )
     (command)
   )
 )
 (*error* nil)
)