Lisp calcul de coton

[mschneider]

Bonjour à tous, 

 

merci à ceux qui gère les modifications de lisp et explique la manière de faire avant tout 🙂

J'utilise actuellement un lisp qui me permet de dessiner un habillage de mur ( coton ) de certaines hauteurs, je peux renseigner la couleur, la hauteur et si c'est une face ou deux. 

celui ci me crée un calque en fonction de la couleur renseigné ( ex : couleur = bleu1015 / le calque crée est coton bleu1015 )

J'aurais aimé modifié ce lisp de la manière suivante : 

-> pas de création de calque mais plutôt se mettre au préalable sur un calque déjà crée sur mon gabarit 

-> j'aurais aimé savoir si un lisp comme sa pouvait être également utilisé pour de l'habillage au sol, différente largeur avec indication en supplément de la référence au milieu de celle ci et sa largeur 

 

merci pour l'aide apporté : 

voici le lisp en question : 

 

;; CotonGratte.lsp : préparation et dessin des multilignes pour représenter des faces de coton gratté.
;;
;; Fichiers et styles nécessaires :
;;   1. Style de texte :
;;      nom=CotonGratté, police=romans.shx, ht.=0.18
;;
;;=============================================================================================
;; Contrôle d'erreur

(defun *cgr_err* (s)
  (if U:F
    (eval (read U:F))
  )
  (if (not
    (member    s
        '("Fonction annulée" "interruption de la console")
    )
      )
    (princ (strcat "\nErreur: " s))
  )
  (if old_tx
    (setvar "textstyle" old_tx)
  )
  (if old_cycle
    (setvar "selectioncycling" old_cycle)
  )
  (if old_fd
    (setvar "filedia" old_fd)
  )
  (if old_cd
    (setvar "cmddia" old_cd)
  )
  (if old_ce
    (setvar "cmdecho" old_ce)
  )
  (if old_celtscale
    (setvar "celtscale" old_celtscale)
  )
  (if old_cecolor
    (setvar "cecolor" old_cecolor)
  )
  (if old_trans
    (setvar "cetransparency" old_trans)
  )
  (if old_lay
    (setvar "clayer" old_lay)
  )
  (if cgr:err
    (setq *error* cgr:err
      cgr:err nil
    )
  )
  (princ)
)

;;;=============================================================================================
(defun c:cgr ()
  (c:CotonGratte)
)

;;;=============================================================================================

(defun c:CotonGratte (/         old_fd        old_cd     old_ce
              old_tx     temp        temp_coul  temp_lai
              U:D     U:F        list_coul  tex
              p1     p2        p3           mlines
              mlineslist whatnext   lstyltxt   temp_face
              old_trans     old_lay    fillcolor
             )
  (setq    cgr:err         *error*
    *error*         *cgr_err*
    old_fd         (getvar "filedia")
    old_cd         (getvar "cmddia")
    old_ce         (getvar "cmdecho")
    old_tx         (getvar "textstyle")
    old_lay         (getvar "clayer")
    old_cycle (getvar "selectioncycling")
    coul_coton   (if (or (= nil coul_coton) (= "" coul_coton))
               ""
               (strcase coul_coton)
             )
    coul_temp    ""
    hauteur_face (if (or (= nil hauteur_face) (= "" hauteur_face))
               ""
               hauteur_face
             )
    df_ou_sf     (if (or (= nil df_ou_sf) (= "" df_ou_sf))
               ""
               df_ou_sf
             )
    lstyl         (getvar "cmlstyle")
    temp         T
    temp_lai     ""
  )
  (setvar "filedia" 0)
  (setvar "cmddia" 0)
  (setvar "cmdecho" 0)
  (setvar "selectioncycling" 0)
  (setq    U:D "(command-s \"_UNDO\" \"_be\")"
    U:F "(command-s \"_UNDO\" \"_e\")"
  )
  (eval (read U:D))

  (if (= 1 (cgr:definestyles))        ;define text style and charge pointillé line type
    (progn
      (if (= 1 (makemlinelist))
    (cgr:userchoice)        ;main command line
      )
    )
  )

  (if U:F
    (eval (read U:F))
  )
  (if old_tx
    (setvar "textstyle" old_tx)
  )
  (if old_cycle
    (setvar "selectioncycling" old_cycle)
  )
  (if old_fd
    (setvar "filedia" old_fd)
  )
  (if old_cd
    (setvar "cmddia" old_cd)
  )
  (if old_ce
    (setvar "cmdecho" old_ce)
  )
  (if old_celtscale
    (setvar "celtscale" old_celtscale)
  )
  (if old_cecolor
    (setvar "cecolor" old_cecolor)
  )
  (if old_trans
    (setvar "cetransparency" old_trans)
  )
  (if old_lay
    (setvar "clayer" old_lay)
  )
  (if cgr:err
    (setq *error* cgr:err
      cgr:err nil
    )
  )
  (princ)
)
;;;=============================================================================================
(defun cgr:definestyles    ()
  (if (not (tblsearch "STYLE" "CotonG"))
    (progn
      (if (vl-cmdf "_.-style" "CotonG" "romans.shx" "0.18"    "1" "0"    "" "" "")
    (setq whatnext 1)
    (setq whatnext 0)
      )
      (setvar "textstyle" "CotonG")
    )
    (progn
      (setvar "textstyle" "CotonG")
      (setq whatnext 1)
    )
  )
                    ;(if (not (tblsearch "LTYPE" "POINTILLE"))
  (if (not (tblsearch "LTYPE" "POINTILLE"))
    (progn
      (if (vl-cmdf ".-typeligne" "ch" "POINTILLE" "acad.lin" "")
    (setq whatnext 1)
    (setq whatnext 0)
      )
    )
    (setq whatnext 1)
  )
)
;;;============================================================================================
;; make list of mlinestyles
(defun makemlinelist ()
  (setq mlines (dictsearch (namedobjdict) "ACAD_MLINESTYLE"))
  (foreach x mlines
    (if    (= 3 (car x))
      (setq mlineslist (cons (cdr x) mlineslist))
    )
  )
;;;  (if
  (setq mlineslist (reverse mlineslist))
  (setq whatnext 1)
;;;  )
)
;;;=============================================================================================
(defun cgr:userchoice ()
  (setq p1 T)

  (while (/= nil p1)
    (initget (+ 1024 128) "Paramètres")
    (setq p1 (getpoint
           (strcat
         "\nParamètres courants : Coton gratté = "
;;;         lstyl
         coul_coton
         " / Simple ou double face = "
         df_ou_sf
         "\nSélectionnez un point du départ ou [Paramètres] : "
        )
         )
    )

    (cond
      ((or (= p1 "Paramètres")
       (= nil coul_coton)
       (= "?" coul_coton)
       (= "" coul_coton)
       (= nil hauteur_face)
       (= "?" hauteur_face)
       (= "" coul_coton)
       (= nil df_ou_sf)
       (= "?" df_ou_sf)
       (= "" coul_coton)
       )
       (setq ptemp T)
       (while (/= nil ptemp)
     (Initget "Couleur Hauteur Nombre Faces")
     (setq ptemp (getkword (strcat
                 "\nModifier les paramètres [Couleur<"
                 coul_coton
                 ">/Hauteur<"
                 hauteur_face
                 ">/Nombre de Faces<"
                 df_ou_sf
                 ">] : "
                )
             )
     )
     (cond
       ((= ptemp "Couleur")
        (setq
          coul_temp    (strcase
              (getstring
                (strcat "\nRéférence de coton <"
                    coul_coton
                    "> : "
                )
              )
            )
        )
        (if
          (and (/= nil coul_temp) (/= "" coul_temp))
           (setq coul_coton coul_temp)
        )
       )
       ((= ptemp "Hauteur")
        (initget "0.25 0.5 1 1.10 1.25 1.5 1.6 1.7 2 2.25 2.5 2.7 3 3.2 3.5 4 4.30 5")
        (setq temp_lai
           (getkword
             (strcat
               "\nHauteur de face 0.25 / 0.5 / 1 / 1.10 / 1.25 / 1.5 / 1.6 / 1.7 / 2 / 2.25 / 2.5 / 2.7 / 3 / 3.2 / 3.5 / 4 / 4.30 / 5 /<"
               hauteur_face
               "> : "
             )
           )
        )
        (if
          (and (/= nil temp_lai) (/= "" temp_lai))
           (setq hauteur_face temp_lai)
        )
       )
       ((or (= ptemp "Nombre") (= ptemp "Faces"))
        (initget "SF DF")
        (setq
          temp_face    (getkword
              (strcat "\nSimple ou double face <"
                  df_ou_sf
                  "> : "
              )
            )
        )
        (if    (and (/= nil temp_face) (/= "" temp_face))
          (setq df_ou_sf (strcase temp_face))
        )
       )
       (T
        (if    (and coul_coton hauteur_face)
          (progn
        (setq
          lstyl    (strcat "CG_" coul_coton "_X_" hauteur_face)
;;;              lstyltxt (strcat coul_coton "x" hauteur_face)
        )
        (if (/= 0 (- (atof hauteur_face) (atoi hauteur_face)))
          (setq    lstyl (strcat "CG_"
                      coul_coton
                      "_X_"
                      (substr hauteur_face 1 1)
                      "-"
                      (substr hauteur_face 3 3)
                  )
          )
        )
        (if (member lstyl mlineslist)
          (setq ptemp nil)
          (progn
            (cgr:mlstylemake lstyl hauteur_face)
            (if    (= 1 whatnext)
              (setq ptemp nil)
            )
          )
        )

          )
        )

       )
     )
       )
      )

      (T
       (setq lstyltxt (strcat coul_coton "x" hauteur_face))
       (if (tblsearch "LAYER"
              (strcat "Coton Gratté " coul_coton)
       )
     (progn
       (vl-cmdf "_.-layer"
            "_Thaw"
            (strcat "Coton Gratté " coul_coton)
            "_On"
            (strcat "Coton Gratté " coul_coton)
            "_Unlock"
            (strcat "Coton Gratté " coul_coton)
            "E"
            (strcat "Coton Gratté " coul_coton)
            ""
       )
       (setq whatnext 1)
     )
     (progn
       (if (= nil fillcolor)
         (setq fillcolor (acad_colordlg 1))
       )
       (vl-cmdf "_.-layer"
            "E"
            (strcat "Coton Gratté " coul_coton)
            "CO"
            fillcolor
            (strcat "Coton Gratté " coul_coton)
            ""
       )
       (setq whatnext 1)
     )
       )
       (if p1
     (cgr:draw p1 lstyl lstyltxt)
       )
      )
    )
  )
)
;;;=============================================================================================

(defun cgr:mlstylemake (newstyle newlarg / datalist xname decal_haut)
  (alert
    "Creation de nouveau style. Vous allez choisir un couleur du fond."
  )
  (if (setq fillcolor (acad_colordlg 1))
    (progn
      (setq
;;;    fillcolor  (cons
;;;             62
;;;             fillcolor
;;;               )
    decal_haut (cons 49 0.25)
    datalist
           '((0 . "MLINESTYLE")
             (100 . "AcDbMlineStyle")
             (70 . 1)
             (3 . "")
;;;             (62 . 10)
             (51 . 1.5708)
             (52 . 1.5708)
             (71 . 2)
             (49 . 1)
             (62 . 7)
             (6 . "CONTINUOUS")
             (49 . 0.0)
             (62 . 7)
             (6 . "POINTILLE")
            )
;;;        datalist   (subst fillcolor '(62 . 10) datalist)
    datalist   (subst decal_haut '(49 . 1) datalist)
    xname       (entmakex datalist)
      )
      (dictadd (cdr
         (assoc -1 (dictsearch (namedobjdict) "ACAD_MLINESTYLE"))
           )
           newstyle
           xname
      )
      (makemlinelist)            ;update list mlines
      (setq whatnext 1)
    )
    (setq whatnext 0)
  )
)
;;;=============================================================================================

(defun cgr:draw    (p1 mline mlinetxt / p2)
;;;  (while (setq p1 (getpoint "\nDu point : "))
  (if (setq p2 (getpoint p1 "\nAu point : "))
    (progn
      (cgr:draw2 p1 p2 mline mlinetxt)
      (if (= df_ou_sf "DF")
    (cgr:draw2 p2 p1 mline mlinetxt)
      )
    )
  )
;;;  )
)

;;;=============================================================================================
(defun cgr:draw2
       (p1 p2 mline mlinetxt / p1 p2 old_celtscale old_cecolor)
  (setq old_celtscale (getvar "celtscale"))
  (setvar "celtscale" 100)
  (setq    ptemp p1
    p1    (polar p1
             (+ (angtof "90.0") (angle ptemp p2))
             0.15
          )
    p2    (polar p2
             (+ (angtof "90.0") (angle ptemp p2))
             0.15
          )
  )
  (command "mligne" "_j" "_z" "_st" mline "_s" "1" p1 p2 "")
  (setvar "celtscale" old_celtscale)
  (setq    old_cecolor (getvar "cecolor")
    old_trans   (getvar "cetransparency")
  )
  (setvar "cecolor" "7")
  (setvar "cetransparency" 0)
  (setq    ptemp p1
    p1    (polar p1
             (+ (angtof "90.0") (angle ptemp p2))
             0.125
          )
    p2    (polar p2
             (+ (angtof "90.0") (angle ptemp p2))
             0.125
          )
  )
  (vl-cmdf
    "_text"
    "_j"
    "mc"
    (polar p1 (angle p1 p2) (/ (distance p1 p2) 2))
    (angtos (angle p1 p2) 0 4)
    mlinetxt
  )
  (setvar "cecolor" old_cecolor)
  (setvar "cetransparency" old_trans)
)

;;;=============================================================================================
;;CGext.lsp : routine pour calculer les longueurs des lignes utilis‚s
;;pour longueurs de coton (y compris multilignes).

;;===========================================================================
;; Extraire second partie d'une paire pointé (type dxf)

(defun dxf (n ed) (cdr (assoc n ed)))

;;===========================================================================
;; Construire liste par addition

(defun cdr_cg++    (key alist dist)
  ((lambda (x)
     (cond (x (subst (cons (car x) (+ dist (cdr x))) x alist))
       (t (cons (cons key dist) alist))
     )
   )
    (assoc key alist)
  )
)

;;===========================================================================
;; Trouver le nombre de caractères jusqu'à une clé donnée

(defun list_str    (string key)
  (setq    cs (strlen string)
    l1 '()
  )
  (repeat cs
    (setq l1 (cons (cons (substr string cs 1) cs) l1)
      cs (1- cs)
    )
  )
  (cdr (assoc key l1))
)

;;============================================================================
;; Imprimer les résultats dans un fichier sous form de table, 1 par bloc

(defun table_print_cg (alist     title1       title2    headsub
               coltab     padchr       car-form  cdr-form
               /     maxlen       maxline   padstr
              )
  (setq    *cpage-disable*    nil
    car-form    (cond (car-form)
                  (t '(lambda (x) x))
            )
    cdr-form    (cond (cdr-form)
                  (t '(lambda (x) x))
            )
    maxlen
            (mapcar
              '(lambda (pair)
                 (cons (strlen (car pair))
                   (strlen (cdr pair))
                 )
               )
              (setq    alist
                 (mapcar
                   '(lambda (pair)
                      (cons (apply car-form (list (car pair)))
                        (apply cdr-form (list (cdr pair)))
                      )
                    )
                   alist
                 )
              )
            )
    maxlen        (+ -2
               (apply 'max (mapcar 'car maxlen))
               (apply 'max (mapcar 'cdr maxlen))
            )
    maxline        50        ;(max (+ maxlen coltab) (+ (strlen title1 title2) coltab))
    padstr        (repl_cg padchr 70)
  )

  (cprinc-init_cg)
  (cprinc_cg
    (strcat title1
        " "
        (ctab_cg (cons title1 title2)
             maxline
             (repl_cg " " 70)
        )
        " "
        title2
    )
  )
  (cprinc_cg (repl_cg headsub (+ maxline 2)))
  (mapcar
    '(lambda (pair)
       (cprinc_cg
     (strcat (car pair)
         " "
         (ctab_cg pair maxline padstr)
         " "
         (cdr pair)
     )
       )
     )
    alist
  )
)

(defun repl_cg (char len / res)
  (apply 'strcat (repeat len (setq res (cons char res))))
)

(defun ctab_cg (pair ctabmax padstr)
  (substr padstr 1 (- ctabmax (strlen (car pair) (cdr pair))))
)

(defun cprinc-init_cg ()
  (setq    *console-lines*
            (cond (*console-lines*)
                  (t 25)
            )
    *cprinc-msg*
            (cond (*cprinc-msg*)
                  (t "--- Press any key ---")
            )
    *cprinc-rubout*
            (cond ((or textpage *clear-screen*) "")
                  (t (strcat "\r" (repl_cg " " (strlen *cprinc-msg*)) "\r"))
            )
    *cprinc-line*    -1
  )
  (cond    ((= nil fichier)
     (cond (textpage (textpage))
           (*clear-screen* (*clear-screen*))
           (t (textscr) (terpri))
     )
    )
  )
)

(defun cprinc-page_cg ()
  (princ *cprinc-msg*)
  (grread)
  (cond    ((= nil fichier)
     (cond (textpage (textpage))
           (*clear-screen* (*clear-screen*))
           (t (textscr) (terpri))
     )
    )
  )
  (princ *cprinc-rubout*)
  (setq *cprinc-line* 0)
)

(defun cprinc_cg (s)
  (cond    (*cpage-disable*)
    ((not *cprinc-line*)
     (cprinc-init_cg)
    )
    ((eq (setq *cprinc-line* (1+ *cprinc-line*))
         (1- *console-lines*)
     )
     (cprinc-page_cg)
    )
  )
  (cond    (fichier (write-line s fichier))
    (t (write-line s))
  )
)

;;===========================================================================
(defun c:cgext (/     ent_grp  ct       en1        ct2         p1
        p2     d_list      temp_list        ans         fichier
        titre     comment
           )

  (setq    cgr:err    *error*
    *error*    *cgr_err*
    d_list3    nil
    d_list2    nil
  )

  ;; Selectionner
  (if
;;;    (setq ent_grp (ssget "X" '((0 . "MLINE") (2 . "CG_*"))))
    (setq ent_grp (ssget '((0 . "MLINE") (2 . "CG_*"))))

     ;; Pour chaque multiligne, calculer la distance entre chacun des sommets
     ;; et rajouter ce distance, avec le nom de style, dans une liste.
     (progn
       ;; Imprimer ou non les r‚sultats dans une fichier

       (initget 1 "Ecran Fichier")
       (setq ans (getkword "Impression  Ecran/Fichier : "))

       (cond
     ((= ans "Fichier")
      (setq    fichier
         ;;AJ - WARNING: The DWGNAME sysvar has changed.
         (getstring T
           (strcat "\nNom de fichier <" (getvar "dwgprefix")(getvar "dwgname") "> : ")
         )
      )
      (if (or (= "" fichier) (= nil fichier))
        ;;AJ - WARNING: The DWGNAME sysvar has changed.
        (setq fichier (open    (strcat    (getvar "dwgprefix")
                    (getvar "dwgname")
                    ".coton.txt"
                )
                "w"
              )
        )
        (setq fichier (open (strcat (getvar "dwgprefix") fichier ".txt") "w"))
      )
      (setq    titre    (getstring t "\nAffaire : ")
        comment    (getstring t "\nZone : ")
      )
      (write-line (strcat "Affaire : " titre) fichier)
      (write-line (strcat "Zone : " comment) fichier)
      (write-line
        (strcat "Extraction : "
            (getvar "dwgprefix")
            (getvar "dwgname")
        )
        fichier
      )
      (write-line
        (strcat "Dessinateur : " (getvar "loginname"))
        fichier
      )
      (write-line
        (strcat
          "Date : "
          (menucmd
        "M=$(edtime,$(getvar,date),DDDD DD MONTH YYYY - H:MM)"
          )
        )
        fichier
      )
      (write-line "Version : CotonGratte.lsp 27.01.2014" fichier)
      (write-line "" fichier)
     )
     (T nil)
       )

       (setq ct 0)
       (repeat (sslength ent_grp)
     (princ ".")
     (setq en1 (entget (ssname ent_grp ct)))
     (if (= "MLINE" (dxf 0 en1))
       (progn
         (setq ct2 0)
         (while (< ct2 (length en1))
           (if p2
         (setq p1 p2)
           )
           (setq pair (nth ct2 en1))
           (if (= 11 (car pair))
         (progn
           (if (not p1)
             (setq p1 (cdr pair))
             (setq p2 (cdr pair))
           )
           (if p2
             (setq d_list
                (cdr_cg++ (dxf 2 en1) d_list (fix (+ 0.5 (distance p1 p2))))
             )
           )
         )
           )
           (setq ct2 (1+ ct2))
         )                ;fin while
         (setq p1 nil
           p2 nil
         )
       )                ;fin progn
     )                ;fin if
     (setq ct (1+ ct))
       )                ;fin repeat

       (princ "Terminé.")
       (if (= nil fichier)
     (princ "\nRésultats:\n")
       )

       ;;Trier la liste des distances totaux

       (setq temp_list (acad_strlsort (mapcar 'car d_list))
         d_list2
               (mapcar '(lambda    (x)
                  (assoc x d_list)
                )
                   temp_list
               )
         temp_list nil

         ;; Section … garder; cr‚er liste des coloris de coton seules

                    ;  (mapcar '(lambda (x)
                    ;             (setq item (substr (car x) 1 (1- (list_str (car x) "_"))))
                    ;             (if (= nil (member item d_list3))
                    ;               (progn (setq d_list3 (cons item d_list3)) (print d_list3))
                    ;             )               
                    ;           )
                    ;           (reverse d_list2)
                    ;  )

         ;; Imprimer la liste, une table par coloris

                    ; mettre la liste en sens inverse pour garantir le bon
                    ; fonctionnement de wcmatch

         d_list2   (reverse d_list2)
         ct3       (length d_list2)
       )

                    ; Tant que la liste n'est pas vide...

       (while (>= ct3 1)
     (setq en_tete (car (nth 0 d_list2))
           en_tete (substr en_tete 1 (1- (list_str en_tete "_")))
     )

                    ; ...pour chaque pair qui correspond au coloris...

     (while
       (and    (>= ct3 1)
        (wcmatch (car (nth 0 d_list2)) (strcat en_tete "*"))
       )
        (setq temp_list (cons (nth 0 d_list2) temp_list)

                    ; ...tronquer la liste au fur et … mesure...

          d_list2   (cdr d_list2)
          ct3        (1- ct3)
        )
     )

     (if (= nil fichier)
       (terpri)
     )

                    ; ...imprimer la liste

     (table_print_cg
       temp_list en_tete "Longueur"    "-" 8 " " nil 'rtos)
     (if fichier
       (write-line "" fichier)
     )
     (setq temp_list nil)
       )
       (if fichier
     (close fichier)
       )
     )
     (alert "Pas de multiligne à compter")
  )
  (setq    ent_grp    nil
    *error*    cgr:err
    cgr:err    nil
  )
  (princ)
)

(defun c:cgx ()
  (c:cgext)
)

(princ
  "\nCotonGrattév2.lsp chargé. Tapez CGR pour dessiner ou CGX pour extraire les longueurs de coton gratté."
)
(princ)