..............................
(defun c:jigsaw ( / ang ent idx itm lst pcs sel tmp vtx )
(defun vertices ( ent )
(mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent)))
)
(if (setq sel (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
(progn
(repeat (setq idx (sslength sel))
(setq ent (ssname sel (setq idx (1- idx)))
vtx (vertices ent)
ang (mapcar 'LM:getleftangle (cons (last vtx) vtx) vtx (append (cdr vtx) (list (car vtx))))
)
(if (< (apply '+ (setq tmp (mapcar '(lambda ( x ) (- (+ pi pi) x)) ang))) (apply '+ ang))
(setq ang tmp)
)
(setq lst (cons (cons ent (mapcar 'cons ang vtx)) lst))
)
(setq pcs (cdar lst)
lst (cdr lst)
tmp nil
)
(while
(progn
(foreach itm lst
(if
(not
(vl-some
(function
(lambda ( a )
(vl-some
(function
(lambda ( b / x )
(setq x (rem (+ (car a) (car b)) pi))
(if (or (equal x 0.0 1e-8) (equal x pi 1e-8))
(progn
(vl-cmdf "_.move" (car itm) "" "_non" (cdr a) "_non" (cdr b))
(setq pcs (append (mapcar '(lambda ( a b ) (cons (car a) b)) (cdr itm) (vertices (car itm))) pcs))
)
)
)
)
pcs
)
)
)
(cdr itm)
)
)
(setq tmp (cons itm tmp))
)
)
tmp
)
(setq pcs (cdar tmp)
lst (cdr tmp)
tmp nil
)
)
)
)
(princ)
)
;; Get Left Angle - Lee Mac
;; Returns the angle swept by rotating the vector (p2,p1) clockwise to (p2,p3)
(defun LM:getleftangle ( p1 p2 p3 )
(rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi))
)
(vl-load-com) (princ)
Cheers pBe 8)Cool. oops. I shouldn't be reading this till i finish my own routine . :lmao:
The key to the challenge is to first calculate the interior angles.........
My current program follows this method, however, only comparing pairs of pieces.
(defun c:putmetogether ( / AssocOn LM:ListClockwise-p member-fuzz plvlst llchk prevang nextang suppang anglst dstlst mdpairs reversess llwidchk lllenchk
p1 p2 vec ss ssss1 ssss2 ssss3 ssss4 ssss5 wid len i pl vlst llpls llpl )
(vl-load-com)
(defun AssocOn ( SearchTerm Lst func fuzz )
(car
(vl-member-if
(function
(lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
)
lst
)
)
)
(defun LM:ListClockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
) lst (cons (last lst) lst)
)
)
)
)
(defun member-fuzz ( expr lst fuzz )
(while (and lst (not (equal (car lst) expr fuzz)))
(setq lst (cdr lst))
)
lst
)
(defun plvlst ( pl / vlst pt ptlst )
(setq vlst (vlax-safearray->list (vlax-variant-value (vla-get-coordinates (vlax-ename->vla-object pl)))))
(cond
( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDbPolyline")
(repeat (/ (length vlst) 2)
(setq pt (list (car vlst) (cadr vlst)))
(setq vlst (cddr vlst))
(setq ptlst (cons pt ptlst))
)
(mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
)
( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDb2dPolyline")
(repeat (/ (length vlst) 3)
(setq pt (list (car vlst) (cadr vlst)))
(setq vlst (cdddr vlst))
(setq ptlst (cons pt ptlst))
)
(mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
)
)
)
(defun llchk ( lst / tst )
(mapcar '(lambda (a b c)
(if (and (equal (angle a b) 0.0 1e-6) (equal (angle c a) (* 1.5 pi) 1e-6)) (setq tst (cons T tst)) (setq tst (cons nil tst)))
)
lst
(append (cdr lst) (list (car lst)))
(append (list (last lst)) (reverse (cdr (reverse lst))))
)
(eval (cons 'or tst))
)
(defun prevang ( ang lst / alst )
(setq alst (anglst lst))
(cond
( (equal ang (car alst) 1e-6)
(last alst)
)
( (equal ang (last alst) 1e-6)
(cadr (reverse alst))
)
( (cadr (member-fuzz ang (reverse alst) 1e-6)) )
)
)
(defun nextang ( ang lst / alst )
(setq alst (anglst lst))
(cond
( (equal ang (car alst) 1e-6)
(cadr alst)
)
( (equal ang (last alst) 1e-6)
(car alst)
)
( (cadr (member-fuzz ang alst 1e-6)) )
)
)
(defun suppang ( ang )
(cond
( (< 0.0 ang pi)
(+ ang pi)
)
( (< pi ang (* 2.0 pi))
(- ang pi)
)
( (equal ang pi 1e-8)
0.0
)
( (or (equal ang 0.0 1e-8) (equal ang (* 2.0 pi) 1e-8))
pi
)
)
)
(defun anglst ( lst / alst )
(setq alst (mapcar '(lambda (a b) (angle a b)) lst (append (cdr lst) (list (car lst)))))
)
(defun dstlst ( lst / dlst )
(setq dlst (mapcar '(lambda (a b) (distance a b)) lst (append (cdr lst) (list (car lst)))))
)
(defun mdpairs ( lst1 lst2 )
(mapcar '(lambda (a b) (cons a b)) lst1 lst2)
)
(defun reversess ( s / sssss i ent )
(gc)
(setq sssss (ssadd))
(repeat (setq i (sslength s))
(setq ent (ssname s (setq i (1- i))))
(ssadd ent sssss)
)
sssss
)
(defun llwidchk ( llpl sss wid / loop i plin pln plnwid )
(if (not vlstw) (setq vlstw (plvlst llpl)))
(if (not alstw) (setq alstw (anglst vlstw)))
(if (not angn) (setq angn (nextang 0.0 vlstw)))
(if (not suppangn) (setq suppangn (suppang angn)))
(if (not llplwid) (setq llplwid (cdr (assocon 0.0 (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
(if (not lwid) (setq lwid llplwid))
(if (not dstchk1) (setq dstchk1 (cdr (assocon angn (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
(setq i -1)
(setq loop T)
(if (equal lwid wid 1e-6) (setq chk T loop nil))
(while (and (setq plin (if sss (ssname sss (setq i (1+ i))) nil)) loop)
(if (member-fuzz suppangn (anglst (plvlst plin)) 1e-6)
(setq pln plin)
)
(if pln
(progn
(setq plnwid (cdr (assocon 0.0 (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6))
dstchk2 (cdr (assocon suppangn (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6))
)
(setq vlstw (plvlst pln) alstw (anglst vlstw) angn (if (not (equal (nextang suppangn vlstw) 0.0 1e-6)) (nextang suppangn vlstw) (nextang 0.0 vlstw)))
(if (equal dstchk1 dstchk2 1e-6)
(setq suppangn (suppang angn) dstchk1 (cdr (assocon angn (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6)))
(setq plnwid nil)
)
)
)
(if plnwid
(progn
(setq lwid (+ lwid plnwid))
(cond
( (equal lwid wid 1e-6)
(setq chk T loop nil)
)
( (< lwid wid)
(llwidchk nil (ssdel pln sss) wid)
(if (equal lwid wid 1e-6) (setq chk T loop nil))
)
( (> lwid wid)
(setq chk nil loop nil)
)
)
)
(if (and pln (< lwid wid))
(progn
(llwidchk nil (ssdel pln sss) wid)
(if (equal lwid wid 1e-6) (setq chk T loop nil))
)
(cond
( (equal lwid wid 1e-6)
(setq chk T loop nil)
)
( (> lwid wid)
(setq chk nil loop nil)
)
)
)
)
)
chk
)
(defun lllenchk ( llpl sss len / loop i plin plp plplen )
(if (not vlstl) (setq vlstl (plvlst llpl)))
(if (not alstl) (setq alstl (anglst vlstl)))
(if (not angp) (setq angp (prevang (* 1.5 pi) vlstl)))
(if (not suppangp) (setq suppangp (suppang angp)))
(if (not llpllen) (setq llpllen (cdr (assocon (* 1.5 pi) (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
(if (not llen) (setq llen llpllen))
(if (not dstchk1) (setq dstchk1 (cdr (assocon angp (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
(setq i -1)
(setq loop T)
(if (equal llen len 1e-6) (setq chk T loop nil))
(while (and (setq plin (if sss (ssname sss (setq i (1+ i))) nil)) loop)
(if (member-fuzz suppangp (anglst (plvlst plin)) 1e-6)
(setq plp plin)
)
(if plp
(progn
(setq plplen (cdr (assocon (* 1.5 pi) (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6))
dstchk2 (cdr (assocon suppangp (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6))
)
(setq vlstl (plvlst plp) alstl (anglst vlstl) angp (if (not (equal (prevang suppangp vlstl) (* 1.5 pi) 1e-6)) (prevang suppangp vlstl) (prevang (* 1.5 pi) vlstl)))
(if (equal dstchk1 dstchk2 1e-6)
(setq suppangp (suppang angp) dstchk1 (cdr (assocon angp (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6)))
(setq plplen nil)
)
)
)
(if plplen
(progn
(setq llen (+ llen plplen))
(cond
( (equal llen len 1e-6)
(setq chk T loop nil)
)
( (< llen len)
(lllenchk nil (ssdel plp sss) len)
(if (equal llen len 1e-6) (setq chk T loop nil))
)
( (> llen len)
(setq chk nil loop nil)
)
)
)
(if (and plp (< llen len))
(progn
(lllenchk nil (ssdel plp sss) len)
(if (equal llen len 1e-6) (setq chk T loop nil))
)
(cond
( (equal llen len 1e-6)
(setq chk T loop nil)
)
( (> llen len)
(setq chk nil loop nil)
)
)
)
)
)
chk
)
(setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "&=") (70 . 1))))
(setq p1 (getpoint "\nPick start corner : "))
(setq p2 (getcorner p1 "\nPick end corner : "))
(setq vec (mapcar '- p2 p1))
(setq wid (abs (car vec)))
(setq len (abs (cadr vec)))
(setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd) ssss5 (ssadd))
(setq i -1)
(while (setq pl (ssname ss (setq i (1+ i))))
(setq vlst (plvlst pl))
(if (LM:ListClockwise-p vlst)
(progn
(command "_.reverse" pl "")
(setq vlst (plvlst pl))
)
)
(if (llchk vlst) (setq llpls (cons pl llpls)))
(ssadd pl ssss1)
(ssadd pl ssss2)
(ssadd pl ssss3)
(ssadd pl ssss4)
(ssadd pl ssss5)
)
(foreach plll llpls
(setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
(setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
(ssdel plll ssss1)
(ssdel plll ssss2)
(ssdel plll ssss3)
(ssdel plll ssss4)
(if (and
(or (llwidchk plll ssss1 wid) (llwidchk plll (reversess ssss2) wid))
(or (lllenchk plll ssss3 len) (lllenchk plll (reversess ssss4) len))
)
(setq llpl plll)
)
(setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
(setq i -1)
(while (setq pl (ssname ssss5 (setq i (1+ i))))
(ssadd pl ssss1)
(ssadd pl ssss2)
(ssadd pl ssss3)
(ssadd pl ssss4)
)
)
(setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
(setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
(prompt "\nLower-left 2d polyline is highlighted")
(sssetfirst nil (ssadd llpl))
(princ)
)
:cry:
Like i said "regular" jigsaw puzzles doesn't have "EDGE-LIKE" piece on the middle part of the board.
You are taking this challenge to another level :lmao: .
There too many common angles and UCS and all.
And that tile thingy? butted against each other? yeahh.. you know what i mean MR.
BTW: Are you going to modify your code to actually solve the jigsaw?
Lee. I finally got the chance to try your code, I'm still at awe how were you able to write the code with very few lines. [how did you manage that?]
I notice there are four pieces although connected to each other did not position itself correctly on the board. or is it just me.
my version:Code - Auto/Visual Lisp: [Select]
Wonderful, it works!!! In most cases it's truly correct...
Thanks, EEA...
:-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-)
Matching edges instead of vertices - good method Evgeniy :-)
And that tile thingy? butted against each other? yeahh.. you know what i mean MR.
Matching edges instead of vertices - good method Evgeniy :-)
Yes, if all the edges of different lengths
my version:Code - Auto/Visual Lisp: [Select]
<...> )
Indeed, it is not a complete solution since I am only comparing the interior angles of pairs of pieces, and not groups of 3, 4, 5,...,n pieces. The ambiguity in the position of the last four pieces arises because I am comparing the outer angles of the edge pieces (i.e. testing for summation to pi radians, rather than 2pi), and several positions will pass this test.
my version:Code - Auto/Visual Lisp: [Select]
Matching edges instead of vertices - good method Evgeniy :)
Yes, if all the edges of different lengths
Code - C#: [Select]The above will put together the shapes.-
[CommandMethod("TOGETHER")] public void cmd_together()....
Here are my suggestions for optimisations for ElpanovEvgeniy's code:
(defun c:putmetogether ( / AssocOn LM:ListClockwise-p member-fuzz plvlst llchk prevang nextang suppang anglst dstlst mdpairs reversess llwidchk lllenchk
p1 p2 vec ss ssss ssss1 ssss2 ssss3 ssss4 ssss5 plnn plx wid len i pl vlst llpls llpl )
(vl-load-com)
(defun AssocOn ( SearchTerm Lst func fuzz )
(car
(vl-member-if
(function
(lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
)
lst
)
)
)
(defun LM:ListClockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
) lst (cons (last lst) lst)
)
)
)
)
(defun member-fuzz ( expr lst fuzz )
(while (and lst (not (equal (car lst) expr fuzz)))
(setq lst (cdr lst))
)
lst
)
(defun plvlst ( pl / vlst pt ptlst )
(setq vlst (vlax-safearray->list (vlax-variant-value (vla-get-coordinates (vlax-ename->vla-object pl)))))
(cond
( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDbPolyline")
(repeat (/ (length vlst) 2)
(setq pt (list (car vlst) (cadr vlst)))
(setq vlst (cddr vlst))
(setq ptlst (cons pt ptlst))
)
(mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
)
( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDb2dPolyline")
(repeat (/ (length vlst) 3)
(setq pt (list (car vlst) (cadr vlst)))
(setq vlst (cdddr vlst))
(setq ptlst (cons pt ptlst))
)
(mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
)
)
)
(defun llchk ( lst / tst )
(mapcar '(lambda (a b c)
(if (and (equal (angle a b) 0.0 1e-6) (equal (angle c a) (* 1.5 pi) 1e-6)) (setq tst (cons T tst)) (setq tst (cons nil tst)))
)
lst
(append (cdr lst) (list (car lst)))
(append (list (last lst)) (reverse (cdr (reverse lst))))
)
(eval (cons 'or tst))
)
(defun prevang ( ang lst / alst )
(setq alst (anglst lst))
(cond
( (equal ang (car alst) 1e-6)
(last alst)
)
( (equal ang (last alst) 1e-6)
(cadr (reverse alst))
)
( (cadr (member-fuzz ang (reverse alst) 1e-6)) )
)
)
(defun nextang ( ang lst / alst )
(setq alst (anglst lst))
(cond
( (equal ang (car alst) 1e-6)
(cadr alst)
)
( (equal ang (last alst) 1e-6)
(car alst)
)
( (cadr (member-fuzz ang alst 1e-6)) )
)
)
(defun suppang ( ang )
(cond
( (< 0.0 ang pi)
(+ ang pi)
)
( (< pi ang (* 2.0 pi))
(- ang pi)
)
( (equal ang pi 1e-6)
0.0
)
( (or (equal ang 0.0 1e-6) (equal ang (* 2.0 pi) 1e-6))
pi
)
)
)
(defun anglst ( lst / alst )
(setq alst (mapcar '(lambda (a b) (angle a b)) lst (append (cdr lst) (list (car lst)))))
)
(defun dstlst ( lst / dlst )
(setq dlst (mapcar '(lambda (a b) (distance a b)) lst (append (cdr lst) (list (car lst)))))
)
(defun mdpairs ( lst1 lst2 )
(mapcar '(lambda (a b) (cons a b)) lst1 lst2)
)
(defun reversess ( s / sx i ent )
(setq sx (ssadd))
(repeat (setq i (sslength s))
(setq ent (ssname s (setq i (1- i))))
(ssadd ent sx)
)
sx
)
(defun llwidchk ( llpl sss wid / plnchk plnchkk loop i plin pln plnwid )
(defun plnchk ( pln sss wid )
(cond
( (equal lwid wid 1e-6)
(setq chk T loop nil plx pln)
)
( (< lwid wid)
(plnchkk pln sss wid)
)
( (> lwid wid)
(plnchkk pln sss wid)
)
)
)
(defun plnchkk ( pln sss wid / e r )
(if (not sssr)
(progn
(setq sssr (ssadd))
(repeat (setq r (sslength sss))
(setq e (ssname sss (setq r (1- r))))
(ssadd e sssr)
)
)
)
(cond
( (and pln (not q))
(llwidchk nil (ssdel pln sss) wid)
(if (equal lwid wid 1e-6) (setq chk T loop nil))
(setq q T)
)
( pln
(llwidchk nil (ssdel pln sssr) wid)
(if (equal lwid wid 1e-6) (setq chk T loop nil))
(setq sssr nil q nil lw nil suppw nil)
)
)
)
(if (not vlstw) (setq vlstw (plvlst llpl)))
(if (not alstw) (setq alstw (anglst vlstw)))
(if (not angn) (setq angn (nextang 0.0 vlstw)))
(if (not suppangn) (setq suppangn (suppang angn)))
(if (not llplwid) (setq llplwid (cdr (assocon 0.0 (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
(if (not lwid) (setq lwid llplwid))
(if (not dstchk1) (setq dstchk1 (cdr (assocon angn (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
(setq i -1)
(setq loop T)
(if (equal lwid wid 1e-6) (setq chk T loop nil))
(while (and (setq plin (if sss (ssname sss (setq i (1+ i))) nil)) loop)
(if (not lw) (setq lw lwid))
(if (not suppw) (setq suppw suppangn))
(if q (setq suppangn suppw lwid lw))
(if (member-fuzz suppangn (anglst (plvlst plin)) 1e-6)
(setq pln plin)
(setq pln nil)
)
(if pln
(progn
(setq plnwid (cdr (assocon 0.0 (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6))
dstchk2 (cdr (assocon suppangn (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6))
)
(setq vlstw (plvlst pln) alstw (anglst vlstw) angn (if (not (equal (nextang suppangn vlstw) 0.0 1e-6)) (nextang suppangn vlstw) (nextang 0.0 vlstw)))
(if (equal dstchk1 dstchk2 1e-6)
(setq suppangn (suppang angn) dstchk1 (cdr (assocon angn (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6)))
(setq plnwid nil)
)
)
)
(if plnwid
(progn
(setq lwid (+ lwid plnwid))
(plnchk pln sss wid)
)
(if pln (plnchk pln sss wid))
)
)
(list chk plx)
)
(defun lllenchk ( llpl sss len / plpchk plpchkk loop i plin plp plplen )
(defun plpchk ( plp sss len )
(cond
( (equal llen len 1e-6)
(setq chk T loop nil)
)
( (< llen len)
(plpchkk plp sss len)
)
( (> llen len)
(plpchkk plp sss len)
)
)
)
(defun plpchkk ( plp sss len / e r )
(if (not sssr)
(progn
(setq sssr (ssadd))
(repeat (setq r (sslength sss))
(setq e (ssname sss (setq r (1- r))))
(ssadd e sssr)
)
)
)
(cond
( (and (not q) plp)
(lllenchk nil (ssdel plp sss) len)
(if (equal llen len 1e-6) (setq chk T loop nil))
(setq q T)
)
( plp
(lllenchk nil (ssdel plp sssr) len)
(if (equal llen len 1e-6) (setq chk T loop nil))
(setq sssr nil q nil ll nil suppl nil)
)
)
)
(if (not vlstl) (setq vlstl (plvlst llpl)))
(if (not alstl) (setq alstl (anglst vlstl)))
(if (not angp) (setq angp (prevang (* 1.5 pi) vlstl)))
(if (not suppangp) (setq suppangp (suppang angp)))
(if (not llpllen) (setq llpllen (cdr (assocon (* 1.5 pi) (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
(if (not llen) (setq llen llpllen))
(if (not dstchk1) (setq dstchk1 (cdr (assocon angp (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
(setq i -1)
(setq loop T)
(if (equal llen len 1e-6) (setq chk T loop nil))
(while (and (setq plin (if sss (ssname sss (setq i (1+ i))) nil)) loop)
(if (not ll) (setq ll llen))
(if (not suppl) (setq suppl suppangp))
(if q (setq suppangp suppl llen ll))
(if (member-fuzz suppangp (anglst (plvlst plin)) 1e-6)
(setq plp plin)
(setq plp nil)
)
(if plp
(progn
(setq plplen (cdr (assocon (* 1.5 pi) (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6))
dstchk2 (cdr (assocon suppangp (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6))
)
(setq vlstl (plvlst plp) alstl (anglst vlstl) angp (if (not (equal (prevang suppangp vlstl) (* 1.5 pi) 1e-6)) (prevang suppangp vlstl) (prevang (* 1.5 pi) vlstl)))
(if (equal dstchk1 dstchk2 1e-6)
(setq suppangp (suppang angp) dstchk1 (cdr (assocon angp (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6)))
(setq plplen nil)
)
)
)
(if plplen
(progn
(setq llen (+ llen plplen))
(plpchk plp sss len)
)
(if plp (plpchk plp sss len))
)
)
chk
)
(command "_.ucs" "w")
(setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "&=") (70 . 1))))
(setq p1 (getpoint "\nPick start corner : "))
(setq p2 (getcorner p1 "\nPick end corner : "))
(setq vec (mapcar '- p2 p1))
(setq wid (abs (car vec)))
(setq len (abs (cadr vec)))
(setq ssss (ssadd))
(setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd) ssss5 (ssadd))
(setq i -1)
(command "_.ucs" "w")
(while (setq pl (ssname ss (setq i (1+ i))))
(setq vlst (plvlst pl))
(if (LM:ListClockwise-p vlst)
(progn
(command "_.reverse" pl "")
(setq vlst (plvlst pl))
)
)
(if (llchk vlst) (setq llpls (cons pl llpls)))
(ssadd pl ssss1)
(ssadd pl ssss2)
(ssadd pl ssss3)
(ssadd pl ssss4)
(ssadd pl ssss5)
)
(foreach plll (reverse llpls)
(ssdel plll ssss1)
(ssdel plll ssss2)
(ssdel plll ssss3)
(ssdel plll ssss4)
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk1 (lllenchk plll ssss3 len))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk2 (lllenchk plll (setq sss (reversess ssss4)) len))
(if (and
(or wchk1 wchk2)
(or lchk1 lchk2)
)
(setq llpl plll)
)
(setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
(setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
(setq i -1)
(while (setq pl (ssname ssss5 (setq i (1+ i))))
(ssadd pl ssss1)
(ssadd pl ssss2)
(ssadd pl ssss3)
(ssadd pl ssss4)
)
)
(ssdel plnn ssss1)
(ssdel plnn ssss2)
(ssdel plnn ssss3)
(ssdel plnn ssss4)
(ssadd plnn ssss1)
(ssadd plnn ssss2)
(ssadd plnn ssss3)
(ssadd plnn ssss4)
(prompt "\nLower-left 2d polyline is highlighted - ENTER TO CONTINUE")
(ssadd llpl ssss)
(sssetfirst nil (ssadd llpl))
(setq llpls nil)
(command "\\")
(setq i -1)
(command "_.ucs" "z" 90)
(while (setq pl (ssname ssss1 (setq i (1+ i))))
(setq vlst (plvlst pl))
(if (LM:ListClockwise-p vlst)
(progn
(command "_.reverse" pl "")
(setq vlst (plvlst pl))
)
)
(if (llchk vlst) (setq llpls (cons pl llpls)))
)
(foreach plll (reverse llpls)
(ssdel plll ssss1)
(ssdel plll ssss2)
(ssdel plll ssss3)
(ssdel plll ssss4)
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 len))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) len))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk1 (lllenchk plll ssss3 wid))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk2 (lllenchk plll (setq sss (reversess ssss4)) wid))
(if (and
(or wchk1 wchk2)
(or lchk1 lchk2)
)
(setq llpl plll)
)
(setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
(setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
(setq i -1)
(while (setq pl (ssname ssss5 (setq i (1+ i))))
(ssadd pl ssss1)
(ssadd pl ssss2)
(ssadd pl ssss3)
(ssadd pl ssss4)
)
)
(ssdel plnn ssss1)
(ssdel plnn ssss2)
(ssdel plnn ssss3)
(ssdel plnn ssss4)
(ssadd plnn ssss1)
(ssadd plnn ssss2)
(ssadd plnn ssss3)
(ssadd plnn ssss4)
(prompt "\nLower-right 2d polyline is highlighted - ENTER TO CONTINUE")
(ssadd llpl ssss)
(sssetfirst nil (ssadd llpl))
(setq llpls nil)
(command "\\")
(setq i -1)
(command "_.ucs" "z" 90)
(while (setq pl (ssname ssss1 (setq i (1+ i))))
(setq vlst (plvlst pl))
(if (LM:ListClockwise-p vlst)
(progn
(command "_.reverse" pl "")
(setq vlst (plvlst pl))
)
)
(if (llchk vlst) (setq llpls (cons pl llpls)))
)
(foreach plll (reverse llpls)
(ssdel plll ssss1)
(ssdel plll ssss2)
(ssdel plll ssss3)
(ssdel plll ssss4)
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk1 (lllenchk plll ssss3 len))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk2 (lllenchk plll (setq sss (reversess ssss4)) len))
(if (and
(or wchk1 wchk2)
(or lchk1 lchk2)
)
(setq llpl plll)
)
(setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
(setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
(setq i -1)
(while (setq pl (ssname ssss5 (setq i (1+ i))))
(ssadd pl ssss1)
(ssadd pl ssss2)
(ssadd pl ssss3)
(ssadd pl ssss4)
)
)
(ssdel plnn ssss1)
(ssdel plnn ssss2)
(ssdel plnn ssss3)
(ssdel plnn ssss4)
(ssadd plnn ssss1)
(ssadd plnn ssss2)
(ssadd plnn ssss3)
(ssadd plnn ssss4)
(prompt "\nUpper-right 2d polyline is highlighted - ENTER TO CONTINUE")
(ssadd llpl ssss)
(sssetfirst nil (ssadd llpl))
(setq llpls nil)
(command "\\")
(setq i -1)
(command "_.ucs" "z" 90)
(while (setq pl (ssname ssss1 (setq i (1+ i))))
(setq vlst (plvlst pl))
(if (LM:ListClockwise-p vlst)
(progn
(command "_.reverse" pl "")
(setq vlst (plvlst pl))
)
)
(if (llchk vlst) (setq llpls (cons pl llpls)))
)
(foreach plll (reverse llpls)
(ssdel plll ssss1)
(ssdel plll ssss2)
(ssdel plll ssss3)
(ssdel plll ssss4)
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 len))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) len))) T) (progn (setq plnn (cadr plnn)) T) nil))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk1 (lllenchk plll ssss3 wid))
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq lchk2 (lllenchk plll (setq sss (reversess ssss4)) wid))
(if (and
(or wchk1 wchk2)
(or lchk1 lchk2)
)
(setq llpl plll)
)
(setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
(setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
(setq i -1)
(while (setq pl (ssname ssss5 (setq i (1+ i))))
(ssadd pl ssss1)
(ssadd pl ssss2)
(ssadd pl ssss3)
(ssadd pl ssss4)
)
)
(ssdel plnn ssss1)
(ssdel plnn ssss2)
(ssdel plnn ssss3)
(ssdel plnn ssss4)
(ssadd plnn ssss1)
(ssadd plnn ssss2)
(ssadd plnn ssss3)
(ssadd plnn ssss4)
(setq vlstw nil alstw nil angn nil suppangn nil suppw nil lw nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil q nil)
(setq vlstl nil alstl nil angp nil suppangp nil suppl nil ll nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil q nil)
(prompt "\nUpper-left 2d polyline is highlighted - ENTER TO CONTINUE")
(ssadd llpl ssss)
(sssetfirst nil (ssadd llpl))
(setq llpls nil)
(command "\\")
(command "_.ucs" "w")
(prompt "\nAll corner 2d polylines are highlighted")
(sssetfirst nil ssss)
(princ)
)
Here are my suggestions for optimisations for ElpanovEvgeniy's code:
Great job!
The code was twice as long :)
Thanks LE, it's working good through A2010-14
The above will put together the shapes.-
There is no need to reverse & modify the source objects; this should suffice:Code - Auto/Visual Lisp: [Select]
The issue is due to multiple pieces having edges of the same length - this is an obvious restriction of the algorithm implemented in both Evgeniy's & my code and was stated earlier in the thread (http://www.theswamp.org/index.php?topic=44783.msg500184#msg500184).
Even if all LWPolylines have the same direction, the method used by the program still has the potential to return incorrect results if more than two edges have the same 'edge' vector, hence your proposed modifcations will also fail for these cases.
The issue is due to multiple pieces having edges of the same length - this is an obvious restriction of the algorithm implemented in both Evgeniy's & my code and was stated earlier in the thread (http://www.theswamp.org/index.php?topic=44783.msg500184#msg500184).
Even if all LWPolylines have the same direction, the method used by the program still has the potential to return incorrect results if more than two edges have the same 'edge' vector, hence your proposed modifcations will also fail for these cases.
I know limitations ab distances and equal vectors, but why then on my attached dwg, my version works fine, and your fails?
Thanks LE, it's working good through A2010-14I am glad you tried - Thanks Oleg !
with small changes per release
Regards,