Scripturi in LISP AutoLISP

[John Doe]

                  Si eu lucrez de multe ori cu Excel+Word, dar ca sa poti scrie un fisier CPXML valid ai nevoie de coordonatele punctelor parcelelor, si asta e cam complicat sa ti le generezi in Excel - mai repede faci CP-ul manual.
Eu am un program scris in LISP sub AutoCAD care isi ia datele dintr-ul Excel (Anexa 2 - adica tabelul care se preda la OCPI odata cu planul parcelar), gaseste fiecare parcela in plan si extrage coordonatele, scrie restul corpului de CP si gata fisierul. Sunt o gramada de algoritmi la care e mai usor sa gasesti solutia decat sa explici ce ai facut, nu stiu cum te-as putea ajuta.
Iti dau totusi o idee: deschide un fisier CPXML cu Notepad ca sa vezi ce structura are. Si daca nu te descurci, iti vând programul meu...  glumesc, depinde ce vrei tu sa faci: esti un pasionat dus cu pluta ca mine sau chiar ai mult de lucru si nu mai razbesti... ambele cazuri au solutia lor.


               

[Mit]

                  John, eu chiar nu te-nteleg de ce nu-ti vinzi softul.
Eu unul, cand aud de extravilan, ma ia cu mancarimi. Dar poate ca sunt colegi carora le place asta... Pune pretul. Spor la afaceri... "colaterale". http://www.3xforum.ro/img/smilies/hi.png">


               

[John Doe]

                  Ba îl vând... e gata de ceva timp, mai dureaza putin testele si îi dau drumul. Pot spune de pe acum ca am facut cam 30 de planuri parcelare trimise la avizat si au fost bune toate CP-urile. Si dureaza vreo 5 minute pâna il faci... de curios, am incercat sa fac un CP manual, si mi-a luat vreo patru ore.


               

[zamfy]

                  Revin cu un program pe care l-am postat mai demult, dar care, dupa ce l-am testat intens, mi-am dat seama ca nu functioneaza cum mi-as dori, asa ca l-am modificat de vreo 13 ori, pana ce l-am adus la functionalitatea pe care mi-am dorit-o.
Aici este programul:
http://www.fileshare.ro/65846426802" target="_blank">http://www.fileshare.ro/65846426802
Acest program numeroteaza un contur inchis cu comanda OT si genereaza si inventarul de coordonate cu comanda INV. Detalii despre modificarile aduse programului le gasiti in comentariile din fisierul lisp.


               

[John Doe]

                  Faina aplicatia. Am observat insa ca daca punctele sunt prea apropiate, textele se cam suprapun; iti dau o idee: calculeaza lungimea segmentelor de polilinie dintre punctele consecutive, si daca sunt prea mici scrie cate un punct in interior si unul in exteriorul conturului, succesiv. Va iesi mai bine.


               

[zamfy]

                  Mai este loc de imbunatatiri. In viitorul apropiat, o sa il fac sa puna cotarile perpendicular pe contur acolo unde este distanta prea mica intre puncte si deja lucrez la functia de optimizare a pozitiei textelor (nu am implementat-o pana acum, deoarece comanda GT_UnClutter din GeoTools merge neasteptat de bine). Pana atunci, mai postez cateva utilitare pe care eu personal le folosesc zilnic sau le-am folosit la un moment dat mai jos.
Toate programele le copiati in editorul de text preferat si le salvati cu extensia .lsp.

Modificat de zamfy (12-06-2012 15:17:00)


               

[John Doe]

                  Multumim, dar vezi ca primul script are zero bytes.

Primul dintre cele din postarea nemodificata.


               

[zamfy]

                  Pune ax intre 2 polilinii deschise:

Code: (defun c:ax (/ ent1 ent2 i len pt p1 ptlst)  (vl-load-com)  (if (and (setq ent1 (car (entsel "\nSelecteaza prima polilinie: ")))  (wcmatch (cdr (assoc 0 (entget ent1))) "*POLYLINE"))  (if (and (setq ent2 (car (entsel "\nSelecteaza a doua polilinie: ")))  (wcmatch (cdr (assoc 0 (entget ent2))) "*POLYLINE"))  (progn  (command "area" "o" ent1)   (setq l1 (getvar "perimeter")) (setq div (/ (* l1 10) 100))  (setq i -1 len (/ (vla-get-Length  (vlax-ename->vla-object ent1)) div))  (while (setq pt (vlax-curve-getPointatDist ent1 (* (setq i (1+ i)) len)))  (setq p1 (vlax-curve-getClosestPointto ent2 pt t)  ptlst (cons (polar pt (angle pt p1) (/ (distance pt p1) 2.)) ptlst)))  (setq ptlst (apply 'append  (mapcar  (function  (lambda (x)  (list (car x) (cadr x)))) ptlst)))  (vla-AddLightWeightPolyline  (vla-get-ModelSpace  (vla-get-ActiveDocument  (vlax-get-acad-object)))  (vlax-make-variant  (vlax-safearray-fill  (vlax-make-safearray  vlax-VBDouble (cons 0 (1- (length ptlst)))) ptlst))))))  (princ))

Ruleaza cu comanda ax.


               

[Atopor]

                  toate fisierele au 0 bytes. incearca pe alt site.


               

[zamfy]

                  Acest program inchide rapid layere, selectand obiecte. Ruleaza cu comanda cl .

Code: (defun c:cl () (setvar "CMDECHO" 0) (if (not(setq startset(cadr(ssgetfirst))))             (setq startset(ssget)))         (setq i -1                 filterlist nil)         ;need?     (repeat(sslength startset)         (setq i(1+ i))         (setq ent(entget(ssname startset i))) (setq lyr (cdr(assoc 8 ent))) (setq clyr (getvar "CLAYER")) (if (= lyr clyr) (progn (command "LAYER" "MAKE" "xtcnv" "C" "140" "" "") (setvar "CLAYER" "xtcnv") (command "layer" "off" (strcat lyr) "") (setvar "CLAYER" lyr) (command "laydel" "n" "xtcnv" "" "y") ) ) (command "layer" "off" (strcat lyr) "") ) (princ) )

               

[zamfy]

                  Acest program insereaza vertecsi intr-o polilinie (asemanatoare cu insvx din TopoLT, numai ca se repeta la infinit). Ruleaza cu comanda iv .

Code: ;--------------------------------------------------------------------------- ; Modified by GLStephens to eliminate "Undo" "mark"! which should not be ; implemented within programs - user function only - use "Undo" "begin/end" ; and to modify the error routine so that it is local rather than over- ; writing the global routine.  Oct 2003 ;--------------------------------------------------------------------------- ;                 Modified by David Garrigues ;                          of the ;                         CADapult ;                http://home1.gte.net/davidgus ;                       E-mail ;                        Version ?.? ;                      October 19, 1997 ;Objective - to add verticies to all polylines/splines except 3D polylines ;Summary of additions ;can do spline or fitted polylines ;can do splines ;keeps pline at original elevation ;Function and reasoning - ;To make it work with R14 and light weight polylines and the new variable PLINETYPE.   ;I also had to take into account what the plinetype setting was so that ;I also could change lines into polylines or lwpolylines.  I also added ;the capability to add verticies in plines where they are splined or fitted ;without turning them into 50,000 segments while still maintaining the ;spline or fit option. Works in 14 on all Polylines, LWPolylines, Splines, and Lines. ;Due the nature of the FIT option on a polyline I decided to ask the user if the wish to RE-FIT ;after the insertion of a new vertex.  While testing this I found areas and instances ;where I thought this might be benificial to the user. The original program performed a loop ;while that is nice I decided I liked it better if did not (just hit enter with your mouse ;button). I added error handlers that will set back the line the way it was after aproaching the ;error.  Last but not least I made sure that this will maintain all elevations as they are ;just for us CIVILized people ;*************************************************************************** ;Original header ;  ADVERT.LSP    Add a Vertex   (c)1995, Steve Houghton ;revised 3/23/95 to ensure new vertex is at crosshairs ;thanks to Patrick Wheatley ;Inserts a vertex in a polyline.  If a line is selected, it offers to convert ;it to a polyline and then insert the vertex. ;Will report: At least one break point must be on polyline. if the end of ;a polyline is chosen ;*************************************************************************** (defun C:iv ( / *Error* POLYLINE POLYNAME PICKPOINT POLYDXF ENTTYPE FTSP ZPT                     LASTENT NEWVERT OLDERR ANSWER)                     (while  (defun *Error* (msg)   (while (> (getvar "CmdActive") 0) (command)) ; if command not ended, then end it     ; now restore environment     (setvar "blipmode" adv:blip)     (setvar "cmdecho" adv:cmd)     (setvar "menuecho" adv:echo)     (setvar "orthomode" adv:ortho)     (setvar "highlight" adv:highlt)     (setvar "texteval" adv:txeval)     (setvar "osmode" adv:snap)   (princ msg)   (princ)  ) ; end defun error ;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ; ;  This section remmed out by GLS - reworked as local *Error* ; ;   ; ;  (setq OLDERR *error*) ;current error handling subroutine ;  (defun *error* (errmes) ;    (princ (strcat "\nExecution of ADVERT.LSP halted by the following error: " ERRMES)) ;    (command "undo" "b");if this program fails or you cancel out of the program this will ;                        ;put the entity back to its original condition ; ;    (setvar "blipmode" blipmode) ;    (setvar "cmdecho" cmdecho) ;    (setvar "menuecho" menuecho) ;    (setvar "orthomode" orthomode) ;    (setvar "highlight" highlight) ;    (setvar "texteval" texteval) ;    (setvar "osmode" oldsnap) ;     ;    (setq *error* OLDERR) ;    (prin1) ;exit quitley ;  ) ;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ; Initial section of Main code follows   ; set ex sysvars to variables to later restore   (setq adv:blip (getvar "blipmode"))   (setq adv:cmd (getvar "cmdecho"))   (setq adv:echo (getvar "menuecho"))   (setq adv:ortho (getvar "orthomode"))   (setq adv:highlt (getvar "highlight"))   (setq adv:txeval (getvar "texteval"))   (setq adv:snap (getvar "osmode"))    ; set sysvars to values for this routine    (setvar "OSMODE" 0)   ;osmode to avoid conflicts with the osnap    (setvar "BLIPMODE" 0) ;so no nasty blips hanging around    (setvar "HIGHLIGHT" 0);so it runs faster on BIG polylines    (setvar "CMDECHO" 0)  ;so you don't see the baggage  (command "._Undo" "_End") ; end any previously active group  (command "._Undo" "_Begin") ; starts new undo group for this command - Advert ; begin main program    (princ "\nAlege o polilinie, linie sau spline ca sa adaugi vertexul: ") (setq POLYLINE  (entsel)                     ;asks you to select the entity       POLYNAME  (car POLYLINE)               ;gets the handle name       PICKPOINT (osnap (cadr POLYLINE) "nea");using the osnap we get a point on the entity       POLYDXF   (entget POLYNAME)            ;get association list       ENTTYPE   (cdr (assoc 0 POLYDXF))      ;finding out what kind of entity it is       FTSP      (cdr (assoc '70 polydxf))    ;is it fitted or splined       ZPT       (CADDR PICKPOINT)            ;elevation point "Z" only  )   (cond   ((or (= ftsp 2)(= ftsp 4))     (fitit)   )   ((= enttype "LWPOLYLINE")      ;vertex insert routine for lwpolylines       (command "break" POLYNAME PICKPOINT PICKPOINT)       ;lwplolylines do not change handle names so there is no need to entmake       (command "PEDIT" polyname "join" (entlast) "" "x")       ;moving the  vertex is easy on a line taht has not been splined or fitted       ;because you can always depend on the point not moving.  When we are dealing       ;with a spine or a fit the vertex could move slightly. This slight movement forces       ;me helpless to try and find that point then aid the user in trying to stretch it.       ;I could write more code and find the point but all I would be doing is the same as       ;you just picking on the entity and using your grips to place the new vertex where       ;you want it to go.       (setvar "osmode" adv:snap)       (princ "\nMutam vertexul: ")       (setq NEWVERT (osnap pickpoint "int,near"))       (COMMAND "STRETCH" "C" NEWVERT NEWVERT "" PICKPOINT pause)   )   ((= enttype "POLYLINE")       (entmake (list '(0 . "POINT") (cons 10 (getvar "VSMIN"))))       (setq LASTENT (entlast))       ;*breaks polyline at pickpoint       (command "break" POLYNAME PICKPOINT PICKPOINT)       ;*(entnext lastent) will be the next polyline created after lastent       ;*(entlast) will be the other polyline created       ;*so now join the two and we have a polyline with the new vertex       ;*inserted          (setq last1 (entnext lastent))      (command "PEDIT" last1 "join" (entlast) last1 "" x)       ;*get rid of temporary point       (entdel LASTENT)       (princ "\nMove new vertex: ")       (setq NEWVERT (osnap pickpoint "int,near"))       (COMMAND "STRETCH" "C" NEWVERT NEWVERT "" PICKPOINT pause)       (if (= (getvar "plinetype") 0);on these the polyline will be set back to          (progn                     ;0 so I have to move them back to their original                                     ;elevation.            (setq topt (LIST 0.0 0.0 ZPT));create a list and still allow it to be evaluated                                          ;thank you Tony Tanzillio            (command "move" "p" "" "0,0,0" topt)           )       )   )   ((= enttype "SPLINE")      (itsaspl)   )   ((= enttype "LINE")      (itsaline)   ) );end cond ;end main program     ; now restore environment     (setvar "blipmode" adv:blip)     (setvar "cmdecho" adv:cmd)     (setvar "menuecho" adv:echo)     (setvar "orthomode" adv:ortho)     (setvar "highlight" adv:highlt)     (setvar "texteval" adv:txeval)     (setvar "osmode" adv:snap)   (command "._Undo" "_End") ; to end undo group for this routine - Advert   (prin1);exiting quietly );end advert.lsp   ;*vertext insert routine for old polylines          ;insertvert ;begin special functions***************************************************** (defun fitit ()   (command "pedit" polyname "decurve" "x" )   (if (>= (getvar "plinetype") 1)              ;if1      (progn                                    ;bprog1        (command "break" POLYNAME PICKPOINT PICKPOINT)        (command "PEDIT" polyname "join" (entlast) "" "x")        (if (= ftsp 2)                          ;bif2          (progn                                ;bprog2            (initget "Yes No");allows the user to typ in y ye yes n or no for an answer            (setq ANSWER (getkword "\nDo you wish to RE-FIT after ddinserting vertex <Y>? "))            (if (or(= ANSWER nil)(= ANSWER "Yes"))   ;bif3              (command "pedit" polyname "fit" "x")            )                                        ;eif3          )                                     ;eprog2          (command "PEDIT" polyname "spline" "x")        )                                       ;eif2      )                                         ;eprogn1      (progn                                    ;then part of if1 bprog4       (entmake (list '(0 . "POINT") (cons 10 (getvar "VSMIN"))))       (setq LASTENT (entlast))       (command "break" POLYNAME PICKPOINT PICKPOINT)       (command "PEDIT" (entnext lastent) "join" (entlast) "" x)       (entdel LASTENT)       (if (= ftsp 2)                           ;bif4         (progn                                 ;bprog5            (initget "Yes No")            (setq ANSWER (getkword "\nDo you wish to REFIT after inserting a vertex <Y>? "))            (if (or (= ANSWER nil)(= ANSWER "Yes"))     ;bif5              (command "pedit" (entlast) "fit" "x")             )                                          ;eif5         )                                       ;eprog5         (command "PEDIT" (entlast) "spline" "x")        )                                        ;eif4       )                                         ;eprog4   )                                             ;eif1 )                                               ;defun             (defun itsaspl ();we need to add vertexes to splines to ya know      (command "splinedit" polyname "r" "add" pickpoint "" "" "")   )   (defun itsaline ();hey lets give the user a chance to make a line into a pline       (initget "Yes No")       (setq ANSWER (getkword "\nDo you wish to turn this line to a polyline <Y>? "))       (if (or (= ANSWER nil)(= ANSWER "Yes"))         (progn           ;*turn current line into a polyline           (command "pedit" POLYNAME "y" "")           (if (=(getvar "plinetype")0)             (insertvert)               ;if the plinetype is 0 then lets do it this way             (progn                     otehrwise do it this way because               (setq polyname (entlast));the handle name did change to                 (vertlw)               ;accomodate for LWplines             );progn           );if         );progn       );if   );defun ;two routines that everyone should have so you can do what I did at the begining of this routine ; Saves the SETVARs specified in the mode list into the global MLST. (defun MODES (a)    (setq MLST '())    (repeat (length a)       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))       (setq a (cdr a))) ) ; ; Restores the SETVARs specified in the global MLST. (defun MODER ()    (repeat (length MLST)       (setvar (caar MLST) (cadar MLST))       (setq MLST (cdr MLST))    )  (princ "\nDone.                                                    ")  (princ) ) ) (Defun C:AdV () (C:advert)) ;end special functions******************************************************** (prin1);makes the loading look clean

               

[zamfy]

                  Acest program uneste 2 polilinii deschise, Este asemanator cu comanda "join", numai ca nu este necesar ca poliliniile sa aiba un punct comun, ci pot sa fie si la distanta una fata de cealalta. Utila atunci cand faci limita unui model 3D. Ruleaza cu comanda jl .

Code: (defun c:jl (/ l1 l2 fz) (setvar "CMDECHO" 0)   (setvar "PEDITACCEPT" 1)    (if     (and       (setq l1(entsel "\nSelecteaza prima polilinie: "))       (setq l2(entsel "\nSelecteaza cea de-a doua polilinie: "))       (setq fz(distance(cadr l1)(cadr l2)))       (vl-cmdf "_.pedit" "_m" (car l1)(car l2) "" "_j" "_j" "_b" fz "")     ); end and     (c:jl)     ); end if   (princ)   ); end c:jl

               

[zamfy]

                  Acest program schimba rotatia unui text, alegand unghiul dintre 2 puncte. Ruleaza cu comanda at .

Code: (defun c:at() (setvar "CMDECHO" 0) (setq string (car (entsel "\nSelecteaza textul pe care doriti sa il modificati: "))) (setq en (entget string)) (command "osnap" "endpoint") (setq p1 (getpoint "\nAlegeti primul punct: ")) (setq p2 (getpoint "\nAlegeti cel de-al doilea punct:")) (setq unghi (angle p1 p2)) (setq en (subst (cons 50 unghi) (assoc 50 en) en)) (entmod en) (prin1) )

               

[zamfy]

                  Acest program schimba punctul de start al unei polilinii. Ruleaza cu comanda sv .

Code: (defun c:sv (/ pt pl pobj plst) (setvar "CMDECHO" 0) (vl-load-com) (setq pt (getpoint "\nAlege punctul de start:")) ;;scanam poliliniile din desen (setq pl (car (nentselp pt)))  (setq pobj (vlax-ename->vla-object pl)) ;;verificam sensul poliliniei (vla-GetBoundingBox pobj 'MinP 'MaxP)   (setq       minp (vlax-safearray->list minp)       MaxP (vlax-safearray->list MaxP)       lst         (mapcar           (function           (lambda (x)           (vlax-curve-getParamAtPoint           pobj           (vlax-curve-getClosestPointTo pobj x)           ) ;_ vlax-curve-getParamAtPoint           ) ;_ lambda           ) ;_ function           (list minp                (list (car minp) (cadr MaxP))                 MaxP                (list (car MaxP) (cadr minp))                 ) ;_ list           ) ;_ mapcar       ) ;_ setq   (if     (or       (> (car lst) (cadr lst) (caddr lst) (cadddr lst))       (> (cadr lst) (caddr lst) (cadddr lst) (car lst))       (> (caddr lst) (cadddr lst) (car lst) (cadr lst))       (> (cadddr lst) (car lst) (cadr lst) (caddr lst))       ) (progn       (alert "Polilinia este in sens antiorar!") (defun do_light (pl / hdr tail list_new list_of_vert)    (foreach item (reverse (entget pl))       (cond          ((and (not hdr)(= (car item) 10))             (setq hdr item)          )          ((member (car item) '(10 40 41))             (setq list_of_vert (cons item list_of_vert))          )          ((= (car item) 42)             (setq list_of_vert (cons (cons 42 (- (cdr item))) list_of_vert))          )          ((= (car item) 210)             (setq tail item)          )          (T (setq list_new (cons item list_new)))       )    )    (if (entmod (append list_new (list hdr)(reverse list_of_vert)(list tail)))       (progn          (prompt " OK")          (entupd pl)       )       (prompt " failed!")    ) ) (do_light pl) ) ) ;;acum schimbam vertexul de inceput al poliliniei (setq plst (vlax-get pobj 'Coordinates)  norm (vlax-get pobj 'Normal)  pt (trans pt 1 0)  pa (vlax-curve-getParamAtPoint pobj pt)  nb (/ (length plst) 2)  n nb  )  (repeat n  (setq blst (cons (vla-getBulge pobj (setq n (1- n))) blst))  )  (if (= pa (fix pa))  (setq n (fix pa)  plst (append (sublist plst (* 2 n) nil)  (sublist plst 0 (* 2 n))  )  blst (append (sublist blst n nil) (sublist blst 0 n))  )  (setq n (1+ (fix pa))  d3 (vlax-curve-getDistAtParam pobj n)  d2 (- d3 (vlax-curve-getDistAtPoint pobj pt))  d3 (- d3 (vlax-curve-getDistAtParam pobj (1- n)))  d1 (- d3 d2)  pt (trans pt 0 (vlax-get pobj 'Normal))  plst (append (list (car pt) (cadr pt))  (sublist plst (* 2 n) nil)  (sublist plst 0 (* 2 n))  )  )  )  (vlax-put pobj 'coordinates plst)  (princ)  ) (defun sublist (lst start leng / n r)  (if (or (not leng) (< (- (length lst) start) leng))  (setq leng (- (length lst) start))  )  (setq n (+ start leng))  (repeat leng  (setq r (cons (nth (setq n (1- n)) lst) r))  )  )    (defun k*bulge (b k / a)  (setq a (atan b))  (/ (sin (* k a)) (cos (* k a)))  )

I-am facut o modificare, deoarece dadea o eroare, chiar daca functiona corect.

Modificat de zamfy (13-06-2012 08:24:14)


               

[zamfy]

                  Acest program "taie" obiectele fata de o margine. Ruleaza cu comanda ts . Este programul extrim din Express Tools, numai ca nu multa lume stie de comanda aceasta:

Code: (defun c:ts ( / na e1 p1 redraw_it lst n )   (acet-error-init (list                    (list   "cmdecho" 0                          "highlight" 0                          "regenmode" 1                             "osmode" 0                            "ucsicon" 0                         "offsetdist" 0                             "attreq" 0                           "plinewid" 0                          "plinetype" 1                           "gridmode" 0                            "celtype" "CONTINUOUS"                          "ucsfollow" 0                           "limcheck" 0                    )                    T     ;flag. True means use undo for error clean up.                    '(if redraw_it (redraw na 4))                   );list );acet-error-init     (princ "\nAlege o Polilinie, Linie, Cerc, Arc, Elipsa, Imagine sau Text pentru marginea de taiere...") (setq na (acet-ui-single-select '((-4 . "<OR")                            (0 . "CIRCLE")                            (0 . "ARC")                            (0 . "LINE")                            (0 . "ELLIPSE")                            (0 . "ATTDEF")                            (0 . "TEXT")                            (0 . "MTEXT")                            (0 . "IMAGE")                            (0 . "SPLINE")                            (0 . "INSERT")                            (0 . "SOLID")                            (0 . "3DFACE")                            (0 . "TRACE")                            (0 . "LWPOLYLINE")                            (-4 . "<AND")                             (0 . "POLYLINE")                             (-4 . "<NOT")                               (-4 . "&")                               (70 . 112)                             (-4 . "NOT>")                            (-4 . "AND>")                           (-4 . "OR>")                          )                          T          );acet-ui-single-select );setq (if na     (progn      (setq e1 (entget na));;setq      (if (or (equal "TEXT"   (cdr (assoc 0 e1)))              (equal "MTEXT"  (cdr (assoc 0 e1)))              (equal "ATTDEF" (cdr (assoc 0 e1)))              (equal "IMAGE"  (cdr (assoc 0 e1)))              (equal "INSERT" (cdr (assoc 0 e1)))              (equal "SOLID"  (cdr (assoc 0 e1)))              (equal "3DFACE" (cdr (assoc 0 e1)))              (equal "TRACE"  (cdr (assoc 0 e1)))          );or          (progn           (setq lst (acet-geom-object-point-list na nil))           (setq n 0)           (command "_.pline")           (repeat (length lst)           (command (nth n lst))           (setq n (+ n 1));setq           );repeat           (if (not (equal (car lst) (last lst) 0.0000001))               (command "_cl")               (command "")           );if           (setq na (entlast)                 e1 na           );setq          );progn then draw a temp pline to be the cutting edge.          (setq e1 nil)      );if      (redraw na 3)      (setq redraw_it T)        (setq p1 (getpoint "\nSpecifica partea unde se taie:"));setq      (redraw na 4)      (setq redraw_it nil)      (if p1 (etrim na p1));if      (if e1          (progn           (if (setq p1 (acet-layer-locked (getvar "clayer")))               (command "_.layer" "_un" (getvar "clayer") "")           );if           (entdel e1)           (if p1               (command "_.layer" "_lock" (getvar "clayer") "")           );if          );progn then      );if     );progn );if   (acet-error-restore) (princ) );defun c:extrim   ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ;Entity-TRIM function ;takes: na - entity name ;  a - a point, the side to trim on ;NOTE: This function does not allow for the possible miss of ;      non-continuous linetypes. ; (defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4                       x y z flag flag2 flag3 zlst vpna vplocked              )     (setq e1 (entget na));setq (if (or (setq flag (equal (acet-dxf 0 e1) "POLYLINE"))         (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))         (equal (acet-dxf 0 e1) "LINE")         (equal (acet-dxf 0 e1) "CIRCLE")         (equal (acet-dxf 0 e1) "ARC")         (equal (acet-dxf 0 e1) "ELLIPSE")         (equal (acet-dxf 0 e1) "TEXT")         (equal (acet-dxf 0 e1) "ATTDEF")         (equal (acet-dxf 0 e1) "MTEXT")         (equal (acet-dxf 0 e1) "SPLINE")     );or     (progn      (if (and flag               (equal 8 (logand 8 (acet-dxf 70 e1)))          );and          (setq flag nil)      );if      (setq     a (trans a 1 0)             vpna (acet-currentviewport-ename)      );setq      (acet-ucs-cmd (list "_View"))        (setq   lst (acet-geom-object-point-list na nil)  ;;;find extents of selected cutting edge object              lst (acet-geom-list-extents lst)                x (- (car (cadr lst)) (car (car lst)))                y (- (cadr (cadr lst)) (cadr (car lst)))                x (* 0.075 x)                y (* 0.075 y)                z (list x y)                x (list (+ (car (cadr lst)) (car z))                        (+ (cadr (cadr lst)) (cadr z))                  );list                y (list (- (car (car lst)) (car z))                        (- (cadr (car lst)) (cadr z))                  );list             zlst (zoom_2_object (list x y))      );setq      (if vpna          (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.      );if      (command "_.zoom" "_w" (car zlst) (cadr zlst))        (entupd na)                  ;;;update the ent. so it's curves display smoothly        (setq lst (acet-geom-object-point-list na                        (/ (acet-geom-pixel-unit) 2.0)                )      );setq      (if (or (not flag)              (not (acet-geom-self-intersect lst nil))          );or          (progn             ;then the object is valid and not a self intersecting polyline.           (if (and flag                    (equal (car lst) (last lst) 0.0001)               );and               (setq flag3 T);then the polyline could potentialy need a second offset           );if           (if (setq la (acet-layer-locked (getvar "clayer")))               (command "_.layer" "_unl" (getvar "clayer") "")           );if             (command "_.pline")           (setq b nil)           (setq n 0);setq           (repeat (length lst)            (setq d (nth n lst))            (if (not (equal d b 0.0001))               (progn                (command d)                (setq lst2 (append lst2 (list d)));setq                (setq b d);setq               );progn            );if            (setq n (+ n 1))           );repeat           (command "")           (setq  na2 (entlast)                   ss (ssadd)                   ss (ssadd na2 ss)                  lst nil           );setq           (acet-ss-visible ss 1)           (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq             (if la               (command "_.layer" "_lock" (getvar "clayer") "")           );if           (acet-ucs-cmd (list "_p"))           ;Move the ents to force a display update of the ents to avoid viewres problems.           (setvar "highlight" 0)           (if (setq ss (ssget "_f" (last lst2)))               (command "_.move" ss "" "0,0,0" "0,0,0")           );if           (if flag               (progn                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")                );if                (acet-ucs-set-z (acet-dxf 210 e1))                (command "_.copy" na "" "0,0,0" "0,0,0")                ;(entdel na)                (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.                                                     ;rk 12:01 PM 3/10/98                (setq na3 na                       na (entlast)                );setq                (command "_.pedit" na "_w" "0.0" "_x")                (acet-ucs-cmd (list "_p"))                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if               );progn           );if           (command "_.trim" na "")           (setq m (- (length lst2) 1));setq           (setq k 0)           (repeat (length lst2)            (setq lst (nth k lst2))            (setq a (trans (car lst) 0 1))            (setq n 1)            (repeat (- (length lst) 1) ;repeat each fence list             (setq b (trans (nth n lst) 0 1))             (if (equal a b 0.0001)                 (setq flag2 T)                 (setq flag2 nil)             );if             (setq na4 nil);setq             (setq j 0);setq             (while (not flag2)       ;repeat each segment of the fence until no new ents are created.              (setq na4 (entlast));setq              (command "_F" a b "")              (if (and (equal na4 (entlast))                       (or (not (equal k m))                           (> j 0)                       );or                  );and                  (setq flag2 T)              );if              (setq j (+ j 1));setq             );while             (setq a b);setq             (setq n (+ n 1));setq            );repeat              (setq k (+ k 1))           );repeat           (command "")             (if flag               (progn                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")                );if                (entdel na) ;get rid of the copy                  ;(entdel na3);bring back the original                (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original                                                       ;rk 12:01 PM 3/10/98                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if               );progn           );if          );progn          (progn           (acet-ucs-cmd (list "_p"))           (princ "\nSelf intersecting edges are not acceptable.")          );progn else invalid self intersecting polyline      );if      (command "_.zoom" "_p")      (if vplocked          (acet-viewport-lock-set vpna T) ;then re-lock the viewport      );if     );progn then it's a most likely a valid entity. );if );defun etrim   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)   (setq da1 (abs (- a2 a1)));setq (setq da2 (- (* b (max pl2 pl1))              (/ (* b (abs (- pl2 pl1)))                  2.0              )           ) );setq (if (> (abs (- da2 da1))        (* 0.01 (max a1 a2))     )     (progn        (acet-pline-make (list lst2))      (setq  na (entlast)            na2 (entlast)             ss (ssadd)             ss (ssadd na ss)      );setq      (acet-ss-visible ss 1)      (command "_.offset" b na2 a "")      (if (and (not (equal na (entlast)))               (setq lst3 (acet-geom-vertex-list (entlast)))               (setq lst3 (intersect_check lst2 lst3 lst4))          );and          (progn           (acet-ss-visible (ssadd (entlast) (ssadd)) 1)           (command "_.area" "_ob" (entlast))           (setq pl2 (getvar "perimeter")                  a2 (getvar "area")           );setq           (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq           (entdel (entlast));then offset was a success so delete the ent after getting it's info          );progn then          (if (not (equal na (entlast))) (entdel (entlast)));if else      );if      (entdel na2)     );progn then let's do that second offset );if   lst );defun another_offset   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n                                                    lst lst2 lst3 lst4 na                         )   (if flag     (progn      (setq lst2 (cdr lst2));setq      (repeat (fix (/ (length lst2) 2))       (setq lst2 (append (cdr lst2) (list (car lst2)));append       );setq      );repeat      (setq lst2 (append lst2 (list (car lst2))));setq      (command "_.area" "_ob" na2)      (setq pl1 (getvar "perimeter")             a1 (getvar "area")      );setq     );progn );if   (setq    a (trans a 0 1)          b (* (getvar "viewsize") 0.05);initial offset distance          n 3.0                         ;number of offsets          d (/ b (- n 1))               ;delta offset          c (acet-geom-pixel-unit)       lst4 (acet-geom-view-points) );setq   (while (> b c) (setq na (entlast)) (command "_.offset" b na2 a "") (if (and (not (equal na (entlast)))          (setq lst3 (acet-geom-vertex-list (entlast)))          (or (not plflag)              (setq lst3 (intersect_check lst2 lst3 lst4))          );or     );and     (progn      (setq lst3 (acet-geom-m-trans lst3 1 0))      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)      (if flag          (progn           (command "_.area" "_ob" (entlast))           (setq pl2 (getvar "perimeter")                  a2 (getvar "area")           );setq          );progn      );if      (setq lst (append lst (list lst3)));setq      (entdel (entlast))  ;delete the ent after getting it's vertex info      (if flag          (setq lst (append lst                            (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)                    );append          );setq      );if     );progn then offset was a success     (if (not (equal na (entlast))) (entdel (entlast)));if else );if (setq b (- b d));setq );while (setq na (entlast)) (command "_.offset" c na2 a "") (if (and (not (equal na (entlast)))          (setq lst3 (acet-geom-vertex-list (entlast)))          (or (not plflag)              (setq lst3 (intersect_check lst2 lst3 lst4))          );or     );and     (progn      (setq lst3 (acet-geom-m-trans lst3 1 0))      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)      (if flag          (progn           (command "_.area" "_ob" (entlast))           (setq pl2 (getvar "perimeter")                  a2 (getvar "area")           );setq          );progn      );if      (setq lst (append lst (list lst3)));setq      (entdel (entlast));then offset was a success so delete the ent after getting it's info      (if flag          (setq lst (append lst                            (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)                    );append          );setq      );if     );progn then     (if (not (equal na (entlast))) (entdel (entlast)));if else );if (entdel na2)   lst );defun get_fence_points   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;returns a list of points on screen if the first two lists do not ;contain segments that intersect each other. ; (defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2                                          a aa b bb c d n j)   (setq  len (length lst)       len2 (length lst2)          x (car (car lst3))         x2 (car (cadr lst3))          y (cadr (car lst3))         y2 (cadr (cadr lst3)) );setq   (setq n 0);setq (while (and (not flag)             (< (+ n 1) len2)        );and (setq   aa (nth n lst2)         bb (nth (+ n 1) lst2)          a (bns_truncate_2_view aa bb x y x2 y2)          b (bns_truncate_2_view bb aa x y x2 y2)       lst4 (append lst4 (list a)) );setq (if (or (not (equal a aa))         (not (equal b bb))     );or     (setq lst4 (append lst4 (list b))) );if (setq j 0);setq  (while (and (not flag)              (< (+ j 1) len)         );and  (setq    c (nth j lst)           d (nth (+ j 1) lst)        flag (inters a b c d)  );setq    (setq j (+ j 1));setq  );while   (setq n (+ n 1));setq );while (if (not (equal b (last lst4)))     (setq lst4 (append lst4 (list b)));setq );if (if (not flag)     (setq flag lst4)     (setq flag nil) );if flag );defun intersect_check   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2                              r1 r2 na e1 x w h dv1 dv2 x                      )    (setq  lst (acet-geom-m-trans lst 1 2)          p1 (acet-geom-m-trans (acet-geom-view-points) 1 2)    ;p1 and p2 are the viewpnts          p2 (cadr p1)          p1 (car p1)          p1 (list (car p1) (cadr p1))          p2 (list (car p2) (cadr p2))  );setq  (if lst      (progn       (setq   p5 (acet-geom-list-extents lst)              ;p5 and p6 are the geometry points               p6 (cadr p5)               p5 (car p5)               p5 (list (car p5) (cadr p5))               p6 (list (car p6) (cadr p6))               mp (acet-geom-midpoint p5 p6)           ;prepare to resize the geometry rectang to               dx (- (car p2) (car p1))    ;have the same dy/dx ratio as p1 p2.               dy (- (cadr p2) (cadr p1))              dx2 (- (car p6) (car p5))              dy2 (- (cadr p6) (cadr p5))       );setq       (if (equal dx 0.0)  (setq dx 0.000001))  ;just in case div by zero       (if (equal dx2 0.0) (setq dx2 0.000001))       (setq   r1 (/ dy dx)               r2 (/ dy2 dx2)       );setq       (if (< r2 r1)           (setq dy2 (* r1 dx2));then scale dy2 up           (progn            (if (equal r1 0.0)  (setq r1 0.000001))  ;just in case div by zero            (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up           );progn       );if       (setq p5 (list (- (car mp) (/ dx2 1.98))   ;1.98 is used instead of 2.0 to expand                      (- (cadr mp) (/ dy2 1.98))  ;the rectangle slightly                );list             p6 (list (+ (car mp) (/ dx2 1.98))                      (+ (cadr mp) (/ dy2 1.98))                );list       );setq      );progn then lst  );if  (if (and lst           (equal 0 (getvar "tilemode"))           (not (equal 1 (getvar "cvport")))           (setq na (acet-currentviewport-ename))      );and      (progn       (setq  e1 (entget na)               x (cdr (assoc 10 e1))               w (cdr (assoc 40 e1))               h (cdr (assoc 41 e1))              p3 (list (- (car x) (/ w 2.0))                       (- (cadr x) (/ h 2.0))                 );list              p4 (list (+ (car x) (/ w 2.0))                       (+ (cadr x) (/ h 2.0))                 );list              p3 (trans p3 3 2)      ;p3 and p4 are the viewport points              p4 (trans p4 3 2)             dv1 (acet-geom-delta-vector p1 p3)             dv2 (acet-geom-delta-vector p2 p4)               x (distance p1 p2)       );setq       (if (equal 0 x) (setq x 0.000001));just in case       (setq   x (/ (distance p5 p6)                    x                 )             dv1 (acet-geom-vector-scale dv1 x)             dv2 (acet-geom-vector-scale dv2 x)              p5 (acet-geom-vector-add p5 dv1)              p6 (acet-geom-vector-add p6 dv2)        );setq      );progn then  );if  (setq p1 (list (car p1) (cadr p1) 0.0)        p2 (list (car p2) (cadr p2) 0.0)        p5 (list (car p5) (cadr p5) 0.0)        p6 (list (car p6) (cadr p6) 0.0)  );setq  (if lst      (setq lst (list (trans p5 2 1)                      (trans p6 2 1)                );list      );setq      (setq lst nil)  );if    lst );defun zoom_2_object (princ)