Topic: How deletes the repetition vertex position, Rearranges the vertex ?

[hunterxyz]

How deletes the repetition apex position reto arrange the apex ?

I am with the network translation narration,
if has is not clear I tobe able again to make the explanation.

Requests fellow masters to be allowed to help to solve ~
to thank ~

Code: [Select]

;;;+++++++++++++++++++++++++++++++++
(DEFUN AR-GET-PL-VERTEX2 (ENAME / N I PTL)
(SETQ VLST (xd-getplvertex ENAME))
(IF (EQUAL (CAR VLST) (LAST VLST) 0.01)
(PROGN
(VLA-PUT-CLOSED (LA-TO-VLA ENAME) :VLAX-TRUE)
(SETQ ANS (LIST T (LIST (REVERSE(CDR(REVERSE VLST))))) )
)
(SETQ ANS (LIST NIL (LIST VLST)) )
)
ANS
)

;;;+++++++++++++++++++++++++++++++++
;; Whether in on-line
;; BY FSXM
(DEFUN PT-ON-LINE (PT LP1 LP2)
  (EQUAL (+ (DISTANCE PT LP1) (DISTANCE PT LP2))
(DISTANCE LP1 LP2)
  )
)

;;;+++++++++++++++++++++++++++++++++
;; Rereorganizes in series
(DEFUN RES_LSTPT_2 (V-LST1 V-LST2 / )
(SETQ BV-LST1 V-LST1)
(SETQ BV-LST2 V-LST2)
(IF (NOT (EQUAL (CAR V-LST1) (LAST V-LST1) 0.01))
(SETQ V-LST1 (APPEND V-LST1 (LIST (CAR V-LST1))))
)

(IF (NOT (EQUAL (CAR V-LST2) (LAST V-LST2) 0.01))
(SETQ V-LST2 (APPEND V-LST2 (LIST (CAR V-LST2))))
)

(PROGN
(SETQ LSTDS NIL)
(SETQ I -1)
(REPEAT (1- (LENGTH V-LST1))
(SETQ I (1+ I))
(SETQ P1 (NTH I V-LST1))
(SETQ P2 (NTH (1+ I) V-LST1))
 
(SETQ TDS NIL)
(SETQ X -1)
(REPEAT (1- (LENGTH V-LST2))
(SETQ X (1+ X))
(SETQ PT (NTH X V-LST2))
 
(COND
 ((SETQ LPT (PT-ON-LINE PT P1 P2))
  (SETQ TDS (CONS (LIST X (DISTANCE P1 PT)) TDS))
  )
 
 ((EQUAL P1 PT 0.01)
  (SETQ TDS (CONS (LIST X (DISTANCE P1 PT)) TDS))
  )
 )
)

(IF TDS
(SETQ LSTDS (APPEND (LIST (LIST I (REVERSE TDS)) ) LSTDS))
)
)
)
(SETQ LSTDSDX (LAST LSTDS))
(SETQ L_A (CAR LSTDSDX))
(SETQ L_B (CADR LSTDSDX))
(SETQ L_MIN (APPLY 'MIN (MAPCAR '(lambda (X) (CADR X)) L_B)))
(MAPCAR '(lambda (X) (IF (= (CADR X) L_MIN)
     (SETQ BNBX (CAR X))
     ) ) L_B)
(SETQ NEWLST (RT_LSTNB BV-LST2 BNBX))
NEWLST
)

;;;+++++++++++++++++++++++++++++++++
;; Assigns in series project, the arrangement to become foregoing
(DEFUN RT_LSTNB (LSTP N / LSTPN I LSTPX)
(SETQ LSTPN NIL)
(SETQ I -1)
(REPEAT N
(SETQ I (1+ I))
(SETQ LSTPX (CAR LSTP))
(SETQ LSTP (CDR LSTP))
(SETQ LSTP (APPEND LSTP (LIST LSTPX)))
)
LSTP
)

;;;+++++++++++++++++++++++++++++++++
;; Function : Find the direction of the polygon (if Cw or CCw)
;; BY www.4d-technologies.com
(defun GE_WhatPoly (ptlist / nverts cnt area tmp pt1 pt2)
(setq cnt 0
      nverts (length ptlist)
      area 0.0
)

(while (< cnt (1- nverts))
(setq   pt1 (nth cnt ptlist)
pt2 (nth (1+ cnt) ptlist)
area (+ area (* (cadr pt1) (car pt2)))
cnt (1+ cnt)
)
)

(setq   pt1 (nth (1- nverts) ptlist)
pt2 (nth 0 ptlist)
area (+ area (* (cadr pt1) (car pt2)))
cnt 0
tmp 0.0
)
    
(while (< cnt (1- nverts))
(setq pt1 (nth cnt ptlist)
pt2 (nth (1+ cnt) ptlist)
tmp (+ tmp (* (cadr pt2) (car pt1)))
cnt (1+ cnt)
)
)

(setq pt1 (nth 0 ptlist)
pt2 (nth (1- nverts) ptlist)
tmp (+ tmp (* (cadr pt1) (car pt2)))
area (* 0.5 (- area tmp))
)

(cond ((< area 0.0) (setq area -1) )
((> area 0.0) (setq area  1) )
(T (setq area 0) )
)
area
)

;;;+++++++++++++++++++++++++++++++++
;; Processing joins another group of in series grid references data
(DEFUN JTHWA_SUBIPT (LST LST_NB LSTDT / ANS )
(SETQ ANS NIL)
(SETQ I -1)
(REPEAT (LENGTH LST)
(SETQ I (1+ I))
(SETQ GET (NTH I LST))
(IF (= I LST_NB)
(SETQ ANS (APPEND ANS (LIST GET) LSTDT  ))
(SETQ ANS (APPEND ANS (LIST GET) ))
)
)
ANS
)

;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



;;TEST

(DEFUN C:TF ( / )
(SETQ EN1 (CAR (ENTSEL "\nSELECT PLINE 1:")))
(SETQ VLST1 (AR-GET-PL-VERTEX2 EN1))
(SETQ V-LST1 (CAR (CADR VLST1)))

(SETQ EN2 (CAR (ENTSEL "\nSELECT PLINE 2:")))
(SETQ VLST2 (AR-GET-PL-VERTEX2 EN2))
(SETQ V-LST2 (CAR (CADR VLST2)))
(SETQ V-LST2 (RES_LSTPT_2 V-LST1 V-LST2))
 
;;===============================================
(IF (= (GE_WhatPoly V-LST1) 1)
 (PROGN
  (IF (NOT (EQUAL (CAR V-LST1) (LAST V-LST1) 0.01))
   (PROGN
    (SETQ V-LST1X V-LST1)
    (SETQ V-LST1X (APPEND (LIST (CAR V-LST1X))
                          (REVERSE (CDR V-LST1X))
                          )
          )
    (SETQ V-LST1 V-LST2X)
    )
   (SETQ V-LST1 (REVERSE V-LST1))
   )
  )
 )

;;===============================================
(IF (= (GE_WhatPoly V-LST2) 1)
 (PROGN
  (IF (NOT (EQUAL (CAR V-LST2) (LAST V-LST2) 0.01))
   (PROGN
    (SETQ V-LST2X V-LST2)
    (SETQ V-LST2X (APPEND (LIST (CAR V-LST2X))
                          (REVERSE (CDR V-LST2X))
                          )
          )
    (SETQ V-LST2 V-LST2X)
    )
   (SETQ V-LST2 (REVERSE V-LST2))
   )
  )
 )

;;===============================================
(SETQ LST1 V-LST1)
(SETQ LST2 V-LST2)
 
;;===============================================
(SETQ PT_LST_NB NIL)
(SETQ PT_LST NIL)
(SETQ I -1)
(REPEAT (LENGTH V-LST1)
(SETQ I (1+ I))
(SETQ PTA (NTH I V-LST1))
(SETQ LST2X V-LST2)
(SETQ GET_V-LST2_TK NIL)
(SETQ V-LST2_TK NIL)
(SETQ PR_DELX NIL)
(SETQ XT T)

(IF LST2X
(WHILE (= XT T)
(SETQ PTB (CAR LST2X))
(SETQ LST2X (CDR LST2X))
 
(IF (EQUAL PTA PTB 0.01)
(PROGN
(SETQ PR_DELX T)
(SETQ XT NIL)

(IF LST2X
(PROGN
(IF V-LST2_TK
(SETQ GET_V-LST2_TK T)
)))
)

(PROGN
(SETQ V-LST2_TK (APPEND V-LST2_TK (LIST PTB)))
(SETQ XT T)
)
)
 
(IF (= (LENGTH LST2X) 0)
(SETQ XT NIL)
)
)
)


;;===============================================
(IF (= PR_DELX T)
 (IF GET_V-LST2_TK
  (SETQ PT_LST    (APPEND PT_LST V-LST2_TK)
        V-LST2    LST2X

        PT_LST_NB (LENGTH PT_LST)

        )
  (SETQ V-LST2 LST2X)
  )
 (PROGN
  (SETQ PT_LST (APPEND PT_LST (LIST PTA)))
  (IF (= (LENGTH V-LST2) (LENGTH V-LST2_TK))
   (SETQ V-LST2 V-LST2_TK)
   )
  )
 )
)

;;===============================================
;; Wrong place
(IF (AND V-LST2 PT_LST_NB)
(SETQ PT_LST (JTHWA_SUBIPT PT_LST (1- PT_LST_NB) V-LST2))
)

(PRINT PT_LST)
PT_LST
) ;_ DEFUN


[MP]

Hi Hunterxyz .

It is difficult to understand your question.

Do you have a friend that can translate to English for you?

Thank you.


喜hunterxyz 。

这是很难理解你的问题。

你有一个朋友，可以翻译成英语最适合你？

谢谢。

[CAB]

I'm not sure but it looks like a pline subtract of sorts.
Comparing pline1 with pline2, subtract pline2 from pline1.
Some rules are needed before code can be created.

[hunterxyz]

How deletes the repetition vertex position, Rearranges the vertex ?

Let the coordinate of pline1 vertex decrease the coordinate of pline2 vertex,
but only decrease the repeat vertex and increase the coordinate of unrepeated vertex to

the coordinate of pline1 vertex as sequence, the result is as “target” of picture1.

Unfortunately, when I run the program,
the result is as picture2, the “missing vertex” is gone.
Please teach me how to solve the problem as above, thank you.

[VVA]

How about this

Code: [Select]

(defun C:PLSUBT ( / pl1 stat pl2 ss doc *error* )
(vl-load-com)
(defun *error* (msg)(princ msg)(vla-endundomark doc))
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc) 
(setvar "cmdecho" 0)(setvar "expert" 5)
(if 
(and
  (princ "\nSelect polyline to subtract from ... ")
  (setq ss nil ss (ssget "_:L:S:E" '((0 . "LWPOLYLINE"))))
  (setq pl1 (ssname ss 0))
  (setq stat (mapcar '(lambda (x)(vlax-get-property (vlax-ename->vla-object pl1)  x))
     '(Layer Linetype LineWeight Color Closed)))
  (princ "\nSelect polyline to subtract ")
  (setq ss nil ss (ssget "_:L:S:E" '((0 . "LWPOLYLINE"))))
  (setq pl2 (ssname ss 0))
  (not (equal pl1 pl2))
  (or (vla-put-Closed (vlax-ename->vla-object pl1) :vlax-true) t)
  (or (vla-put-Closed (vlax-ename->vla-object pl2) :vlax-true) t)
 
  )
(progn
    (vl-cmdf "_.Region" pl1 "")(setq pl1 (entlast))
    (vl-cmdf "_.Region" pl2 "")(setq pl2 (entlast))
    (vl-cmdf "_subtract" pl1 "" pl2 "")
    (setq pl2 (entlast) ss nil ss (ssadd))
    (foreach item (vlax-invoke (vlax-ename->vla-object pl2) 'Explode)
      (ssadd (vlax-vla-object->ename item) ss))
    (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
    (vl-cmdf "_pedit" "_Multiple" ss "" "_Join" 0 "")
    (vl-cmdf "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 ""))
  (mapcar '(lambda (x y) (vlax-put-property (vlax-ename->vla-object (entlast)) x y))
   '(Layer Linetype LineWeight Color Closed)
          stat)
  )
)
(vla-Endundomark doc) 
  (princ)
  )

First select blue polyline, than select red polyline

[hunterxyz]

THANK YOU VVA
But, I so long as with the vertex material operation,
do not use "Region" to operate

[VVA]

Region - an intermediate stage. As a result we receive polylines

[VVA]

Try this my qwick write lisp. Some comment in Russia. My translate programm is crash. If need, I'll post some comment tomorrow.

Code: [Select]

(defun rebild-list (pt lst / p1 buf)
        (while
          (setq p1 (car lst))
          (if (equal p1 pt 1e-6)
            (setq buf (append (list p1)(cdr lst) buf) lst nil)
            (setq buf (append buf (list p1)) lst (cdr lst))
            )
          )
        buf
  )
;;; lwpl - ename of polyline
;;; Return t - clockwise (CW) nil - not (CCW)
(defun pl:is-lwpoly-clockwise (lwpl / pnts angl)
    (setq pnts (mapcar (function cdr)
                       (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget lwpl))
               )
          angl (mapcar (function angle) (cons (last pnts) pnts) pnts)
    )
    (minusp (apply (function +)
                   (mapcar (function (lambda (b)
                                       (cond ((< (abs b) pi) b)
                                             ((minusp b) (+ (* 2 pi) b))
                                             (t (+ (* -2 pi) b))
                                       )
                                     )
                           )
                           (mapcar (function -) angl (cons (last angl) angl))
                   )
            )
    )
  )
  (defun c:test ()
  (if (and (setq pl1 (car (entsel "\n Select polyline to subtract from ...  ")))
           (setq epl1 (entget pl1))
           (equal (assoc 0 epl1) '(0 . "LWPOLYLINE"))
           (setq pl2 (car (entsel "\n Select polyline to subtract ")))
           (setq epl2 (entget pl2))
           (equal (assoc 0 epl1) '(0 . "LWPOLYLINE"))
      )
    (progn
      (setq ret nil)
      (if (> (length (setq lst10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) epl1)))) 2)
        (progn
           ;;; lst10 - coord list pl1
           ;;; epl2 -  coord list pl2
          (setq epl2  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) epl2)))
          (setq n 1 ret nil newpt nil)
          ;;; Add missing point pl2 to pl1. Point must be on segment pl1
          (foreach pt lst10
            (if (and
                  (setq pt1 (nth n lst10))
                  (setq dist (distance pt pt1))
                  (or
                  (mapcar '(lambda(x)(if (and
                                           (not (equal pt x 1e-6))
                                           (not (equal pt1 x 1e-6))
                                           (equal (+ (distance pt x)(distance x pt1)) dist 1e-6)
                                              )
                                       (setq newpt (append newpt (list x)))
                                       )
                                       ) epl2)
                  t)
                  newpt
                  )
              (progn
                (setq newpt (vl-sort newpt '(lambda (x y)(< (distance pt x)(distance pt y)))))
                (setq ret (append ret (list pt) newpt))
                )
              (progn
                 (setq ret (append ret (list pt)))
                )
              )
            (setq newpt nil n (1+ n))
            );_foreach
          (setq lst10 ret)

          ;;Reverse point Pl1 to clockwise
          (if (not (pl:is-lwpoly-clockwise pl1)) ;_Make pline CW
            (setq lst10 (reverse lst10)))
          ;;Reverse point Pl2 to counter clockwise
          (if (pl:is-lwpoly-clockwise pl2)       ;_Make pline CCW
            (setq epl2 (reverse epl2)))
         
        ;;Общие точки lst10 и epl2
        ;;Common points lst10 and epl2
        (setq newpt (vl-remove-if-not '(lambda(x)(apply 'or (mapcar '(lambda(y)(equal x y 1e-6)) lst10))) epl2))
        ;;Начало точка не принадлежащая newpt
        ;;First point lst10 not member newpt
        (setq pt1 (car (vl-remove-if '(lambda(x)(apply 'or (mapcar '(lambda(y)(equal x y 1e-6)) epl2))) lst10)))
        (if pt1 (setq lst10 (rebild-list pt1 lst10)))
        (setq ret nil n 0)
        (while (< n (length lst10))
          (setq pt (nth n lst10))
          (if (vl-position pt newpt)
            (progn
              (setq ret (append ret (list pt)))
              (setq tmp (cdr(rebild-list pt epl2)))
              (while (and tmp
                       (null (vl-position (setq pt1 (car tmp)) newpt))
                         )
                  (setq ret (append ret (list pt1)) tmp (cdr tmp))
                );_while
              (if (setq pt (vl-position (car tmp) lst10))
                (setq ret (append ret (list (car tmp)))
                 n pt
                      )
                )
              )
            (setq ret (append ret (list pt)))
            )
          (setq n (1+ n))
          );_while
       
       
      );_progn
    );_if
(if ret  ;_Final point list !!!
  (progn
  (command "_PLINE" "_none" (car ret))
  (foreach xx (cdr ret)(command "_none" xx))
  (command "")
  )
  )
)
    )
    )


[hunterxyz]

THANK YOU VVA