Author Topic: ==={Challenge}=== Broken Pieces  (Read 17860 times)

0 Members and 1 Guest are viewing this topic.

pBe

  • Bull Frog
  • Posts: 402
Re: ==={Challenge}=== Broken Pieces
« Reply #30 on: June 19, 2013, 01:17:56 AM »

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.

Brilliant approach Lee ... i was "trying" to do the same thing on a counter clockwise direction [angles as basis] using last piece as reference for the next. then worry about the middle pieces later :lmao:

my version:
Code - Auto/Visual Lisp: [Select]
  1. (defun c:test (/ A A1 A2 B D L V V1)

Bravo! Very impressive EE.

Matching edges instead of vertices - good method Evgeniy  :)

Yes, if all the edges of different lengths

Now i need to re-write the whole thing and use this approach... [try that is]

Code - C#: [Select]
  1. [CommandMethod("TOGETHER")]
  2. public void cmd_together()....
The above will put together the shapes.-

I'll try this bit later LE.

Thank you all  :)

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: ==={Challenge}=== Broken Pieces
« Reply #31 on: June 19, 2013, 07:36:27 AM »
Here are my suggestions for optimisations for ElpanovEvgeniy's code:

Code - Auto/Visual Lisp: [Select]
  1. (defun c:test ( / a a1 a2 b d e i l s v v1 x y )
  2.     (if (setq s (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
  3.         (progn
  4.             (repeat (setq i (sslength s))
  5.                 (setq e (ssname s (setq i (1- i)))
  6.                       v (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget e)))
  7.                       l (cons (cons (vlax-ename->vla-object e) (mapcar 'list v (cons (last v) v))) l)
  8.                 )
  9.             )
  10.             (setq a (list (car l))
  11.                   l (cdr l)
  12.             )
  13.             (while (and (setq b (car a)) l)
  14.                 (setq v (mapcar '- (cadadr b) (caadr b)))
  15.                 (foreach c l
  16.                     (if (setq d (car (vl-member-if '(lambda ( x ) (equal v (mapcar '- (car x) (cadr x)) 1e-6)) (cdr c))))
  17.                         (progn
  18.                             (setq a2 (assoc (car c) l)
  19.                                   v1 (mapcar '- (cadr d) (caadr b))
  20.                                   a1 (cons (cons (car c) (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (mapcar '- y v1)) x)) (vl-remove d (cdr a2)))) a1)
  21.                                    l (vl-remove a2 l)
  22.                             )
  23.                             (vla-move (car c) (vlax-3D-point (cadr d)) (vlax-3D-point (caadr b)))
  24.                         )
  25.                     )
  26.                 )
  27.                 (setq a (append (if (cddar a) (cons (cons (car a) (cddar a)) (cdr a)) (cdr a)) a1)
  28.                       a1 nil
  29.                 )
  30.             )
  31.         )
  32.     )
  33.     (princ)
  34. )

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: ==={Challenge}=== Broken Pieces
« Reply #32 on: June 19, 2013, 07:54:50 AM »
Here are my suggestions for optimisations for ElpanovEvgeniy's code:

Great job!
The code was twice as long :)

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #33 on: June 19, 2013, 12:16:10 PM »
Code: [Select]
(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)
)

EDIT : Shortened version...
« Last Edit: June 20, 2013, 12:30:49 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #34 on: June 20, 2013, 06:30:37 AM »
Can someone see what's wrong with my above posted code - it has changed - now is bigger - I hardly put it in code tags around 20000 chr...

As I explained before, I was trying to solve tiles situation - see my posted before *-MR3.dwg... The main problem is that checks for entity when UCS is already rotated 180 degree returns nil... As I explained, lower-left pline is checked this way :
- width checking - checking for next angle and edge distance - two situations :
  - if next angle of next entity is 0.0 degree than this is correct entity and it's width is added consequently to be checked with total width
  - if next angle of next entity isn't 0.0 degree then this next angle is stored for next check entity - all until one next angle is 0.0 degree, that entity width is added consequently to be checked with total width
  - if summed width is equal to total width then last entity is stored into list from witch is later obtained for putting it as last entity in modified selection sets for next iteration (rotation of UCS)... This entity is then last candidate in next checking and therefore should be highlighted as next corner pline...
* if width check isn't correct than this candidate entity fails (note that in my case - tiles - each candidate should pass test for both width and length)

- length checking - checking for previous angle and edge distance - two situations :
  - if previous angle of previous entity is (* 1.5 pi) degree than this is correct entity and it's width is added consequently to be checked with total length
  - if previous angle of previous entity isn't (* 1.5 pi) degree then this previous angle is stored for next check entity - all until one previous angle is (* 1.5 pi) degree, that entity length is added consequently to be checked with total length

Please if you have some time see what you can do with this code... Now is failing after two UCS rotations by 90 degrees...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: ==={Challenge}=== Broken Pieces
« Reply #35 on: June 20, 2013, 06:39:40 AM »
Here are my suggestions for optimisations for ElpanovEvgeniy's code:

Great job!
The code was twice as long :)

Thank you!  8-)

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #36 on: June 20, 2013, 12:32:54 PM »
I have shortened my code, but still the same problems...

No one to help - even look... :|

Regards, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #37 on: June 21, 2013, 06:55:44 PM »
New solution... Works for tiles, but still can't be fully reliable... I don't know why...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:putmetogether ( / AssocOn LM:ListClockwise-p member-fuzz plvlst llchk prevang nextang suppang anglst dstlst mdpairs reversess dstangchk llwidchk lllenchk
  2.                            p1 p2 vec ss ssss ssss1 ssss2 ssss3 ssss4 wid len i pl vlst llpls llpl plnn plmm )
  3.  
  4.  
  5.   (defun AssocOn ( SearchTerm Lst func fuzz )
  6.     (car
  7.       (vl-member-if
  8.         (function
  9.           (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
  10.         )
  11.         lst
  12.       )
  13.     )
  14.   )
  15.  
  16.   (defun LM:ListClockwise-p ( lst )
  17.     (minusp
  18.       (apply '+
  19.         (mapcar
  20.           (function
  21.             (lambda ( a b )
  22.               (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  23.             )
  24.           ) lst (cons (last lst) lst)
  25.         )
  26.       )
  27.     )
  28.   )
  29.  
  30.   (defun member-fuzz ( expr lst fuzz )
  31.     (while (and lst (not (equal (car lst) expr fuzz)))
  32.       (setq lst (cdr lst))
  33.     )
  34.     lst
  35.   )
  36.  
  37.   (defun plvlst ( pl / vlst pt ptlst )
  38.     (setq vlst (vlax-safearray->list (vlax-variant-value (vla-get-coordinates (vlax-ename->vla-object pl)))))
  39.     (cond
  40.       ( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDbPolyline")
  41.         (repeat (/ (length vlst) 2)
  42.           (setq pt (list (car vlst) (cadr vlst)))
  43.           (setq vlst (cddr vlst))
  44.           (setq ptlst (cons pt ptlst))
  45.         )
  46.         (mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
  47.       )
  48.       ( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDb2dPolyline")
  49.         (repeat (/ (length vlst) 3)
  50.           (setq pt (list (car vlst) (cadr vlst)))
  51.           (setq vlst (cdddr vlst))
  52.           (setq ptlst (cons pt ptlst))
  53.         )
  54.         (mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
  55.       )
  56.     )
  57.   )
  58.  
  59.   (defun llchk ( lst / tst )
  60.     (mapcar '(lambda (a b c)
  61.                (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)))
  62.              )
  63.              lst
  64.              (append (cdr lst) (list (car lst)))
  65.              (append (list (last lst)) (reverse (cdr (reverse lst))))
  66.     )
  67.     (eval (cons 'or tst))
  68.   )
  69.  
  70.   (defun prevang ( ang lst / alst )
  71.     (setq alst (anglst lst))
  72.     (cond
  73.       ( (equal ang (car alst) 1e-6)
  74.         (last alst)
  75.       )
  76.       ( (equal ang (last alst) 1e-6)
  77.         (cadr (reverse alst))
  78.       )
  79.       ( (cadr (member-fuzz ang (reverse alst) 1e-6)) )
  80.     )
  81.   )
  82.  
  83.   (defun nextang ( ang lst / alst )
  84.     (setq alst (anglst lst))
  85.     (cond
  86.       ( (equal ang (car alst) 1e-6)
  87.         (cadr alst)
  88.       )
  89.       ( (equal ang (last alst) 1e-6)
  90.         (car alst)
  91.       )
  92.       ( (cadr (member-fuzz ang alst 1e-6)) )
  93.     )
  94.   )
  95.  
  96.   (defun suppang ( ang )
  97.     (cond
  98.       ( (< 0.0 ang pi)
  99.         (+ ang pi)
  100.       )
  101.       ( (< pi ang (* 2.0 pi))
  102.         (- ang pi)
  103.       )
  104.       ( (equal ang pi 1e-6)
  105.         0.0
  106.       )
  107.       ( (or (equal ang 0.0 1e-6) (equal ang (* 2.0 pi) 1e-6))
  108.         pi
  109.       )
  110.     )
  111.   )
  112.  
  113.   (defun anglst ( lst / alst )
  114.     (setq alst (mapcar '(lambda (a b) (angle a b)) lst (append (cdr lst) (list (car lst)))))
  115.   )
  116.  
  117.   (defun dstlst ( lst / dlst )
  118.     (setq dlst (mapcar '(lambda (a b) (distance a b)) lst (append (cdr lst) (list (car lst)))))
  119.   )
  120.  
  121.   (defun mdpairs ( lst1 lst2 )
  122.     (mapcar '(lambda (a b) (cons a b)) lst1 lst2)
  123.   )
  124.  
  125.   (defun reversess ( s / sx i ent )
  126.     (setq sx (ssadd))
  127.     (repeat (setq i (sslength s))
  128.       (setq ent (ssname s (setq i (1- i))))
  129.       (ssadd ent sx)
  130.     )
  131.     sx
  132.   )
  133.  
  134.   (defun dstangchk ( d a ss / i e pairs elst )
  135.     (setq i -1)
  136.     (while (setq e (ssname ss (setq i (1+ i))))
  137.       (setq pairs (mdpairs (anglst (plvlst e)) (dstlst (plvlst e))))
  138.       (if (equal d (cdr (assocon a pairs 'car 1e-6)) 1e-6)
  139.         (setq elst (cons e elst))
  140.       )
  141.     )
  142.     elst
  143.   )
  144.  
  145.   (defun llwidchk ( llpl sss wid / flag an sn dn )
  146.     (setq vlstw (plvlst llpl))
  147.     (setq alstw (anglst vlstw))
  148.     (if (not angn) (setq angn (nextang 0.0 vlstw)))
  149.     (if (not suppangn) (setq suppangn (suppang angn)))
  150.     (if (not llplwid) (setq llplwid (cdr (assocon 0.0 (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
  151.     (if (not lwid) (setq lwid llplwid))
  152.     (if (not dstnn) (setq dstnn (cdr (assocon angn (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
  153.     (setq plns (dstangchk dstnn suppangn sss))
  154.     (if plns
  155.       (progn
  156.         (foreach pln plns
  157.           (setq plnwid (cdr (assocon 0.0 (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6)))
  158.           (setq dstnn (cdr (assocon (nextang 0.0 (plvlst pln)) (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6)))
  159.           (if (nextang 0.0 (plvlst pln)) (setq angn (nextang 0.0 (plvlst pln))))
  160.           (if angn (setq suppangn (suppang angn)))
  161.           (if (and plnwid dstnn (not flag))
  162.             (setq lwid (+ lwid plnwid) npl pln an angn sn suppangn dn dstnn flag T)
  163.           )
  164.         )
  165.         (if (and an sn dn) (setq angn an suppangn sn dstnn dn))
  166.         (if (equal lwid wid 1e-6) (setq chk T plx npl)
  167.           (if (< lwid wid)
  168.             (progn
  169.               (if (not flag) (setq npl (car plns)))
  170.               (if (and npl flag)
  171.                 (llwidchk npl (ssdel npl sss) wid)
  172.                 (progn
  173.                   (setq suppangn (suppang (setq angn (nextang suppangn (plvlst npl)))))
  174.                   (setq dstnn (cdr (assocon angn (mdpairs (anglst (plvlst npl)) (dstlst (plvlst npl))) 'car 1e-6)))
  175.                   (llwidchk npl (ssdel npl sss) wid)
  176.                 )
  177.               )
  178.             )
  179.           )
  180.         )
  181.       )
  182.     )
  183.     (list chk plx)
  184.   )
  185.  
  186.   (defun lllenchk ( llpl sss len / flag ap sp dp )
  187.     (setq vlstl (plvlst llpl))
  188.     (setq alstl (anglst vlstl))
  189.     (if (not angp) (setq angp (prevang (* 1.5 pi) vlstl)))
  190.     (if (not suppangp) (setq suppangp (suppang angp)))
  191.     (if (not llpllen) (setq llpllen (cdr (assocon (* 1.5 pi) (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
  192.     (if (not llen) (setq llen llpllen))
  193.     (if (not dstpp) (setq dstpp (cdr (assocon angp (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
  194.     (setq plps (dstangchk dstpp suppangp sss))
  195.     (if plps
  196.       (progn
  197.         (foreach plp plps
  198.           (setq plplen (cdr (assocon (* 1.5 pi) (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6)))
  199.           (setq dstpp (cdr (assocon (prevang (* 1.5 pi) (plvlst plp)) (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6)))
  200.           (if (prevang (* 1.5 pi) (plvlst plp)) (setq angp (prevang (* 1.5 pi) (plvlst plp))))
  201.           (if angp (setq suppangp (suppang angp)))
  202.           (if (and plplen dstpp (not flag))
  203.             (setq llen (+ llen plplen) ppl plp ap angp sp suppangp dp dstpp flag T)
  204.           )
  205.         )
  206.         (if (and ap sp dp) (setq angp ap suppangp sp dstpp dp))
  207.         (if (equal llen len 1e-6) (setq chk T ply ppl)
  208.           (if (< llen len)
  209.             (progn
  210.               (if (not flag) (setq ppl (car plps)))
  211.               (if (and ppl flag)
  212.                 (lllenchk ppl (ssdel ppl sss) len)
  213.                 (progn
  214.                   (setq suppangp (suppang (setq angp (prevang suppangp (plvlst ppl)))))
  215.                   (setq dstpp (cdr (assocon angp (mdpairs (anglst (plvlst ppl)) (dstlst (plvlst ppl))) 'car 1e-6)))
  216.                   (lllenchk ppl (ssdel ppl sss) len)
  217.                 )
  218.               )
  219.             )
  220.           )
  221.         )
  222.       )
  223.     )
  224.     (list chk ply)
  225.   )
  226.  
  227.   (command "_.ucs" "w")
  228.   (setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "&=") (70 . 1))))
  229.   (setq p1 (getpoint "\nPick start corner : "))
  230.   (setq p2 (getcorner p1 "\nPick end corner : "))
  231.   (setq vec (mapcar '- p2 p1))
  232.   (setq wid (abs (car vec)))
  233.   (setq len (abs (cadr vec)))
  234.  
  235.   (setq ssss (ssadd))
  236.   (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  237.   (setq i -1)
  238.   (command "_.ucs" "w")
  239.   (while (setq pl (ssname ss (setq i (1+ i))))
  240.     (setq vlst (plvlst pl))
  241.     (if (LM:ListClockwise-p vlst)
  242.       (progn
  243.         (command "_.reverse" pl "")
  244.         (setq vlst (plvlst pl))
  245.       )
  246.     )
  247.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  248.     (ssadd pl ssss1)
  249.     (ssadd pl ssss2)
  250.     (ssadd pl ssss3)
  251.     (ssadd pl ssss4)
  252.   )
  253.   (foreach plll (reverse llpls)
  254.     (ssdel plll ssss1)
  255.     (ssdel plll ssss2)
  256.     (ssdel plll ssss3)
  257.     (ssdel plll ssss4)
  258.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  259.     (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  260.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  261.     (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  262.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  263.     (setq lchk1 (if (eq (car (setq plmm (lllenchk plll ssss3 len))) T) (progn (setq plmm (cadr plmm)) T) nil))
  264.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  265.     (setq lchk2 (if (eq (car (setq plmm (lllenchk plll (setq sss (reversess ssss4)) len))) T) (progn (setq plmm (cadr plmm)) T) nil))
  266.     (if (and
  267.           (or wchk1 wchk2)
  268.           (or lchk1 lchk2)
  269.         )
  270.         (setq llpl plll)
  271.     )
  272.     (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  273.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  274.     (setq i -1)
  275.     (while (setq pl (ssname ss (setq i (1+ i))))
  276.       (ssadd pl ssss1)
  277.       (ssadd pl ssss2)
  278.       (ssadd pl ssss3)
  279.       (ssadd pl ssss4)
  280.     )
  281.   )
  282.   (if plnn (ssdel plnn ssss1))
  283.   (if plnn (ssdel plnn ssss2))
  284.   (if plnn (ssdel plnn ssss3))
  285.   (if plnn (ssdel plnn ssss4))
  286.   (if plnn (ssadd plnn ssss1))
  287.   (if plnn (ssadd plnn ssss2))
  288.   (if plnn (ssadd plnn ssss3))
  289.   (if plnn (ssadd plnn ssss4))
  290.   (prompt "\nLower-left 2d polyline is highlighted - ENTER TO CONTINUE")
  291.   (ssadd llpl ssss)
  292.   (sssetfirst nil (ssadd llpl))
  293.   (setq llpls nil)
  294.   (command "\\")
  295.  
  296.   (setq i -1)
  297.   (command "_.ucs" "z" 90)
  298.   (while (setq pl (ssname ssss1 (setq i (1+ i))))
  299.     (setq vlst (plvlst pl))
  300.     (if (LM:ListClockwise-p vlst)
  301.       (progn
  302.         (command "_.reverse" pl "")
  303.         (setq vlst (plvlst pl))
  304.       )
  305.     )
  306.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  307.   )
  308.   (foreach plll (reverse llpls)
  309.     (ssdel plll ssss1)
  310.     (ssdel plll ssss2)
  311.     (ssdel plll ssss3)
  312.     (ssdel plll ssss4)
  313.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  314.     (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  315.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  316.     (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  317.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  318.     (setq lchk1 (if (eq (car (lllenchk plll ssss3 wid)) T) T nil))
  319.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  320.     (setq lchk2 (if (eq (car (lllenchk plll (setq sss (reversess ssss4)) wid)) T) T nil))
  321.     (if (and
  322.           (or wchk1 wchk2)
  323.           (or lchk1 lchk2)
  324.         )
  325.         (setq llpl plll)
  326.     )
  327.     (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  328.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  329.     (setq i -1)
  330.     (while (setq pl (ssname ss (setq i (1+ i))))
  331.       (ssadd pl ssss1)
  332.       (ssadd pl ssss2)
  333.       (ssadd pl ssss3)
  334.       (ssadd pl ssss4)
  335.     )
  336.   )
  337.   (if plnn (ssdel plnn ssss1))
  338.   (if plnn (ssdel plnn ssss2))
  339.   (if plnn (ssdel plnn ssss3))
  340.   (if plnn (ssdel plnn ssss4))
  341.   (if plnn (ssadd plnn ssss1))
  342.   (if plnn (ssadd plnn ssss2))
  343.   (if plnn (ssadd plnn ssss3))
  344.   (if plnn (ssadd plnn ssss4))
  345.   (prompt "\nLower-right 2d polyline is highlighted - ENTER TO CONTINUE")
  346.   (ssadd llpl ssss)
  347.   (sssetfirst nil (ssadd llpl))
  348.   (setq llpls nil)
  349.   (command "\\")
  350.  
  351.   (setq i -1)
  352.   (command "_.ucs" "z" 90)
  353.   (while (setq pl (ssname ssss1 (setq i (1+ i))))
  354.     (setq vlst (plvlst pl))
  355.     (if (LM:ListClockwise-p vlst)
  356.       (progn
  357.         (command "_.reverse" pl "")
  358.         (setq vlst (plvlst pl))
  359.       )
  360.     )
  361.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  362.   )
  363.   (foreach plll (reverse llpls)
  364.     (ssdel plll ssss1)
  365.     (ssdel plll ssss2)
  366.     (ssdel plll ssss3)
  367.     (ssdel plll ssss4)
  368.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  369.     (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  370.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  371.     (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  372.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  373.     (setq lchk1 (if (eq (car (lllenchk plll ssss3 len)) T) T nil))
  374.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  375.     (setq lchk2 (if (eq (car (lllenchk plll (setq sss (reversess ssss4)) len)) T) T nil))
  376.     (if (and
  377.           (or wchk1 wchk2)
  378.           (or lchk1 lchk2)
  379.         )
  380.         (setq llpl plll)
  381.     )
  382.     (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  383.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  384.     (setq i -1)
  385.     (while (setq pl (ssname ss (setq i (1+ i))))
  386.       (ssadd pl ssss1)
  387.       (ssadd pl ssss2)
  388.       (ssadd pl ssss3)
  389.       (ssadd pl ssss4)
  390.     )
  391.   )
  392.   (if plnn (ssdel plnn ssss1))
  393.   (if plnn (ssdel plnn ssss2))
  394.   (if plnn (ssdel plnn ssss3))
  395.   (if plnn (ssdel plnn ssss4))
  396.   (if plnn (ssadd plnn ssss1))
  397.   (if plnn (ssadd plnn ssss2))
  398.   (if plnn (ssadd plnn ssss3))
  399.   (if plnn (ssadd plnn ssss4))
  400.   (if plmm (ssdel plmm ssss1))
  401.   (if plmm (ssdel plmm ssss2))
  402.   (if plmm (ssdel plmm ssss3))
  403.   (if plmm (ssdel plmm ssss4))
  404.   (if plmm (ssadd plmm ssss1))
  405.   (if plmm (ssadd plmm ssss2))
  406.   (if plmm (ssadd plmm ssss3))
  407.   (if plmm (ssadd plmm ssss4))
  408.   (prompt "\nUpper-right 2d polyline is highlighted - ENTER TO CONTINUE")
  409.   (ssadd llpl ssss)
  410.   (sssetfirst nil (ssadd llpl))
  411.   (setq llpls nil)
  412.   (command "\\")
  413.  
  414.   (setq i -1)
  415.   (command "_.ucs" "z" 90)
  416.   (while (setq pl (ssname ssss1 (setq i (1+ i))))
  417.     (setq vlst (plvlst pl))
  418.     (if (LM:ListClockwise-p vlst)
  419.       (progn
  420.         (command "_.reverse" pl "")
  421.         (setq vlst (plvlst pl))
  422.       )
  423.     )
  424.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  425.   )
  426.   (foreach plll (reverse llpls)
  427.     (ssdel plll ssss1)
  428.     (ssdel plll ssss2)
  429.     (ssdel plll ssss3)
  430.     (ssdel plll ssss4)
  431.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  432.     (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  433.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  434.     (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  435.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  436.     (setq lchk1 (if (eq (car (lllenchk plll ssss3 wid)) T) T nil))
  437.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  438.     (setq lchk2 (if (eq (car (lllenchk plll (setq sss (reversess ssss4)) wid)) T) T nil))
  439.     (if (and
  440.           (or wchk1 wchk2)
  441.           (or lchk1 lchk2)
  442.         )
  443.         (setq llpl plll)
  444.     )
  445.     (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  446.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  447.     (setq i -1)
  448.     (while (setq pl (ssname ss (setq i (1+ i))))
  449.       (ssadd pl ssss1)
  450.       (ssadd pl ssss2)
  451.       (ssadd pl ssss3)
  452.       (ssadd pl ssss4)
  453.     )
  454.   )
  455.   (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  456.   (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  457.   (prompt "\nUpper-left 2d polyline is highlighted - ENTER TO CONTINUE")
  458.   (ssadd llpl ssss)
  459.   (sssetfirst nil (ssadd llpl))
  460.   (setq llpls nil)
  461.   (command "\\")
  462.  
  463.   (command "_.ucs" "w")
  464.   (prompt "\nAll corner 2d polylines are highlighted")
  465.   (sssetfirst nil ssss)
  466.  
  467.   (princ)
  468. )
  469.  

Regards, Marko Ribar
« Last Edit: June 22, 2013, 11:32:28 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #38 on: June 22, 2013, 10:02:12 AM »
Now almost work and with my *-MR4.dwg... See attachment... It fails to obtain 4th piece...

But I think the code is OK for now - think it can't be developed too much more...
 :? :-P :-)

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #39 on: June 22, 2013, 11:34:47 AM »
Now works and with *-MR4.dwg... I think that's all - no more intervention... In most cases if it can find first piece, then it should find all other as well...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #40 on: June 23, 2013, 01:40:00 PM »
My last modification - every piece has to be different shape straight 2d polyline... It works on my *-MR4.dwg... No more ENTER between UCS rotations... If it finds solution all 4 pieces - corners are highlighted... Each solution is obtained by iterating through entities that pass firstly check of lower-left angle of 90 degrees...

So may the God help you find solution on your own example...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:putmetogether ( / AssocOn LM:ListClockwise-p member-fuzz plvlst llchk prevang nextang suppang anglst dstlst mdpairs reversess dstangchk llwidchk lllenchk putme
  2.                            p1 p2 vec ss s sssss loop ssss1 ssss2 ssss3 ssss4 wid len i pl vlst llpls llplss plll llpl plnn plmm )
  3.  
  4.  
  5.   (defun AssocOn ( SearchTerm Lst func fuzz )
  6.     (car
  7.       (vl-member-if
  8.         (function
  9.           (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
  10.         )
  11.         lst
  12.       )
  13.     )
  14.   )
  15.  
  16.   (defun LM:ListClockwise-p ( lst )
  17.     (minusp
  18.       (apply '+
  19.         (mapcar
  20.           (function
  21.             (lambda ( a b )
  22.               (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  23.             )
  24.           ) lst (cons (last lst) lst)
  25.         )
  26.       )
  27.     )
  28.   )
  29.  
  30.   (defun member-fuzz ( expr lst fuzz )
  31.     (while (and lst (not (equal (car lst) expr fuzz)))
  32.       (setq lst (cdr lst))
  33.     )
  34.     lst
  35.   )
  36.  
  37.   (defun plvlst ( pl / vlst pt ptlst )
  38.     (setq vlst (vlax-safearray->list (vlax-variant-value (vla-get-coordinates (vlax-ename->vla-object pl)))))
  39.     (cond
  40.       ( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDbPolyline")
  41.         (repeat (/ (length vlst) 2)
  42.           (setq pt (list (car vlst) (cadr vlst)))
  43.           (setq vlst (cddr vlst))
  44.           (setq ptlst (cons pt ptlst))
  45.         )
  46.         (mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
  47.       )
  48.       ( (eq (vla-get-objectname (vlax-ename->vla-object pl)) "AcDb2dPolyline")
  49.         (repeat (/ (length vlst) 3)
  50.           (setq pt (list (car vlst) (cadr vlst)))
  51.           (setq vlst (cdddr vlst))
  52.           (setq ptlst (cons pt ptlst))
  53.         )
  54.         (mapcar '(lambda (x) (trans x 0 1)) (reverse ptlst))
  55.       )
  56.     )
  57.   )
  58.  
  59.   (defun llchk ( lst / tst )
  60.     (mapcar '(lambda (a b c)
  61.                (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)))
  62.              )
  63.              lst
  64.              (append (cdr lst) (list (car lst)))
  65.              (append (list (last lst)) (reverse (cdr (reverse lst))))
  66.     )
  67.     (eval (cons 'or tst))
  68.   )
  69.  
  70.   (defun prevang ( ang lst / alst )
  71.     (setq alst (anglst lst))
  72.     (cond
  73.       ( (equal ang (car alst) 1e-6)
  74.         (last alst)
  75.       )
  76.       ( (equal ang (last alst) 1e-6)
  77.         (cadr (reverse alst))
  78.       )
  79.       ( (cadr (member-fuzz ang (reverse alst) 1e-6)) )
  80.     )
  81.   )
  82.  
  83.   (defun nextang ( ang lst / alst )
  84.     (setq alst (anglst lst))
  85.     (cond
  86.       ( (equal ang (car alst) 1e-6)
  87.         (cadr alst)
  88.       )
  89.       ( (equal ang (last alst) 1e-6)
  90.         (car alst)
  91.       )
  92.       ( (cadr (member-fuzz ang alst 1e-6)) )
  93.     )
  94.   )
  95.  
  96.   (defun suppang ( ang )
  97.     (cond
  98.       ( (< 0.0 ang pi)
  99.         (+ ang pi)
  100.       )
  101.       ( (< pi ang (* 2.0 pi))
  102.         (- ang pi)
  103.       )
  104.       ( (equal ang pi 1e-6)
  105.         0.0
  106.       )
  107.       ( (or (equal ang 0.0 1e-6) (equal ang (* 2.0 pi) 1e-6))
  108.         pi
  109.       )
  110.     )
  111.   )
  112.  
  113.   (defun anglst ( lst / alst )
  114.     (setq alst (mapcar '(lambda (a b) (angle a b)) lst (append (cdr lst) (list (car lst)))))
  115.   )
  116.  
  117.   (defun dstlst ( lst / dlst )
  118.     (setq dlst (mapcar '(lambda (a b) (distance a b)) lst (append (cdr lst) (list (car lst)))))
  119.   )
  120.  
  121.   (defun mdpairs ( lst1 lst2 )
  122.     (mapcar '(lambda (a b) (cons a b)) lst1 lst2)
  123.   )
  124.  
  125.   (defun reversess ( s / sx i ent )
  126.     (setq sx (ssadd))
  127.     (repeat (setq i (sslength s))
  128.       (setq ent (ssname s (setq i (1- i))))
  129.       (ssadd ent sx)
  130.     )
  131.     sx
  132.   )
  133.  
  134.   (defun dstangchk ( d a ss / i e pairs elst )
  135.     (setq i -1)
  136.     (while (setq e (ssname ss (setq i (1+ i))))
  137.       (setq pairs (mdpairs (anglst (plvlst e)) (dstlst (plvlst e))))
  138.       (if (equal d (cdr (assocon a pairs 'car 1e-6)) 1e-6)
  139.         (setq elst (cons e elst))
  140.       )
  141.     )
  142.     elst
  143.   )
  144.  
  145.   (defun llwidchk ( llpl sss wid / flag an sn dn )
  146.     (setq vlstw (plvlst llpl))
  147.     (setq alstw (anglst vlstw))
  148.     (if (not angn) (setq angn (nextang 0.0 vlstw)))
  149.     (if (not suppangn) (setq suppangn (suppang angn)))
  150.     (if (not llplwid) (setq llplwid (cdr (assocon 0.0 (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
  151.     (if (not lwid) (setq lwid llplwid))
  152.     (if (not dstnn) (setq dstnn (cdr (assocon angn (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
  153.     (setq plns (dstangchk dstnn suppangn sss))
  154.     (if plns
  155.       (progn
  156.         (foreach pln plns
  157.           (setq plnwid (cdr (assocon 0.0 (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6)))
  158.           (setq dstnn (cdr (assocon (nextang 0.0 (plvlst pln)) (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6)))
  159.           (if (nextang 0.0 (plvlst pln)) (setq angn (nextang 0.0 (plvlst pln))))
  160.           (if angn (setq suppangn (suppang angn)))
  161.           (if (and plnwid dstnn (not flag))
  162.             (setq lwid (+ lwid plnwid) npl pln an angn sn suppangn dn dstnn flag T)
  163.           )
  164.         )
  165.         (if (and an sn dn) (setq angn an suppangn sn dstnn dn))
  166.         (if (equal lwid wid 1e-6) (setq chk T plx npl)
  167.           (if (< lwid wid)
  168.             (progn
  169.               (if (not flag) (setq npl (car plns)))
  170.               (if (and npl flag)
  171.                 (llwidchk npl (ssdel npl sss) wid)
  172.                 (progn
  173.                   (setq suppangn (suppang (setq angn (nextang suppangn (plvlst npl)))))
  174.                   (setq dstnn (cdr (assocon angn (mdpairs (anglst (plvlst npl)) (dstlst (plvlst npl))) 'car 1e-6)))
  175.                   (llwidchk npl (ssdel npl sss) wid)
  176.                 )
  177.               )
  178.             )
  179.           )
  180.         )
  181.       )
  182.     )
  183.     (list chk plx)
  184.   )
  185.  
  186.   (defun lllenchk ( llpl sss len / flag ap sp dp )
  187.     (setq vlstl (plvlst llpl))
  188.     (setq alstl (anglst vlstl))
  189.     (if (not angp) (setq angp (prevang (* 1.5 pi) vlstl)))
  190.     (if (not suppangp) (setq suppangp (suppang angp)))
  191.     (if (not llpllen) (setq llpllen (cdr (assocon (* 1.5 pi) (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
  192.     (if (not llen) (setq llen llpllen))
  193.     (if (not dstpp) (setq dstpp (cdr (assocon angp (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
  194.     (setq plps (dstangchk dstpp suppangp sss))
  195.     (if plps
  196.       (progn
  197.         (foreach plp plps
  198.           (setq plplen (cdr (assocon (* 1.5 pi) (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6)))
  199.           (setq dstpp (cdr (assocon (prevang (* 1.5 pi) (plvlst plp)) (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6)))
  200.           (if (prevang (* 1.5 pi) (plvlst plp)) (setq angp (prevang (* 1.5 pi) (plvlst plp))))
  201.           (if angp (setq suppangp (suppang angp)))
  202.           (if (and plplen dstpp (not flag))
  203.             (setq llen (+ llen plplen) ppl plp ap angp sp suppangp dp dstpp flag T)
  204.           )
  205.         )
  206.         (if (and ap sp dp) (setq angp ap suppangp sp dstpp dp))
  207.         (if (equal llen len 1e-6) (setq chk T ply ppl)
  208.           (if (< llen len)
  209.             (progn
  210.               (if (not flag) (setq ppl (car plps)))
  211.               (if (and ppl flag)
  212.                 (lllenchk ppl (ssdel ppl sss) len)
  213.                 (progn
  214.                   (setq suppangp (suppang (setq angp (prevang suppangp (plvlst ppl)))))
  215.                   (setq dstpp (cdr (assocon angp (mdpairs (anglst (plvlst ppl)) (dstlst (plvlst ppl))) 'car 1e-6)))
  216.                   (lllenchk ppl (ssdel ppl sss) len)
  217.                 )
  218.               )
  219.             )
  220.           )
  221.         )
  222.       )
  223.     )
  224.     (list chk ply)
  225.   )
  226.  
  227.   (defun putme ( plll ss / ssss )
  228.  
  229.     (command "_.ucs" "w")
  230.     (setq ssss (ssadd))
  231.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  232.     (setq i -1)
  233.     (while (setq pl (ssname ss (setq i (1+ i))))
  234.       (ssadd pl ssss1)
  235.       (ssadd pl ssss2)
  236.       (ssadd pl ssss3)
  237.       (ssadd pl ssss4)
  238.     )
  239.     (ssdel plll ssss1)
  240.     (ssdel plll ssss2)
  241.     (ssdel plll ssss3)
  242.     (ssdel plll ssss4)
  243.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  244.     (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  245.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  246.     (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  247.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  248.     (setq lchk1 (if (eq (car (setq plmm (lllenchk plll ssss3 len))) T) (progn (setq plmm (cadr plmm)) T) nil))
  249.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  250.     (setq lchk2 (if (eq (car (setq plmm (lllenchk plll (setq sss (reversess ssss4)) len))) T) (progn (setq plmm (cadr plmm)) T) nil))
  251.     (if (and
  252.           (or wchk1 wchk2)
  253.           (or lchk1 lchk2)
  254.         )
  255.         (setq llpl plll)
  256.     )
  257.     (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  258.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  259.     (setq i -1)
  260.     (while (setq pl (ssname ss (setq i (1+ i))))
  261.       (ssadd pl ssss1)
  262.       (ssadd pl ssss2)
  263.       (ssadd pl ssss3)
  264.       (ssadd pl ssss4)
  265.     )
  266.     (if plnn (ssdel plnn ssss1))
  267.     (if plnn (ssdel plnn ssss2))
  268.     (if plnn (ssdel plnn ssss3))
  269.     (if plnn (ssdel plnn ssss4))
  270.     (if plnn (ssadd plnn ssss1))
  271.     (if plnn (ssadd plnn ssss2))
  272.     (if plnn (ssadd plnn ssss3))
  273.     (if plnn (ssadd plnn ssss4))
  274.     (ssadd llpl ssss)
  275.     (sssetfirst nil (ssadd llpl))
  276.     (setq llpls nil)
  277.  
  278.     (setq i -1)
  279.     (command "_.ucs" "z" 90)
  280.     (while (setq pl (ssname ssss1 (setq i (1+ i))))
  281.       (setq vlst (plvlst pl))
  282.       (if (LM:ListClockwise-p vlst)
  283.         (progn
  284.           (command "_.reverse" pl "")
  285.           (setq vlst (plvlst pl))
  286.         )
  287.       )
  288.       (if (llchk vlst) (setq llpls (cons pl llpls)))
  289.     )
  290.     (foreach plll (reverse llpls)
  291.       (ssdel plll ssss1)
  292.       (ssdel plll ssss2)
  293.       (ssdel plll ssss3)
  294.       (ssdel plll ssss4)
  295.       (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  296.       (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  297.       (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  298.       (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  299.       (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  300.       (setq lchk1 (if (eq (car (lllenchk plll ssss3 wid)) T) T nil))
  301.       (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  302.       (setq lchk2 (if (eq (car (lllenchk plll (setq sss (reversess ssss4)) wid)) T) T nil))
  303.       (if (and
  304.             (or wchk1 wchk2)
  305.             (or lchk1 lchk2)
  306.           )
  307.           (setq llpl plll)
  308.       )
  309.       (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  310.       (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  311.       (setq i -1)
  312.       (while (setq pl (ssname ss (setq i (1+ i))))
  313.         (ssadd pl ssss1)
  314.         (ssadd pl ssss2)
  315.         (ssadd pl ssss3)
  316.         (ssadd pl ssss4)
  317.       )
  318.     )
  319.     (if plnn (ssdel plnn ssss1))
  320.     (if plnn (ssdel plnn ssss2))
  321.     (if plnn (ssdel plnn ssss3))
  322.     (if plnn (ssdel plnn ssss4))
  323.     (if plnn (ssadd plnn ssss1))
  324.     (if plnn (ssadd plnn ssss2))
  325.     (if plnn (ssadd plnn ssss3))
  326.     (if plnn (ssadd plnn ssss4))
  327.     (ssadd llpl ssss)
  328.     (sssetfirst nil (ssadd llpl))
  329.     (setq llpls nil)
  330.  
  331.     (setq i -1)
  332.     (command "_.ucs" "z" 90)
  333.     (while (setq pl (ssname ssss1 (setq i (1+ i))))
  334.       (setq vlst (plvlst pl))
  335.       (if (LM:ListClockwise-p vlst)
  336.         (progn
  337.           (command "_.reverse" pl "")
  338.           (setq vlst (plvlst pl))
  339.         )
  340.       )
  341.       (if (llchk vlst) (setq llpls (cons pl llpls)))
  342.     )
  343.     (foreach plll (reverse llpls)
  344.       (ssdel plll ssss1)
  345.       (ssdel plll ssss2)
  346.       (ssdel plll ssss3)
  347.       (ssdel plll ssss4)
  348.       (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  349.       (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  350.       (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  351.       (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) wid))) T) (progn (setq plnn (cadr plnn)) T) nil))
  352.       (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  353.       (setq lchk1 (if (eq (car (lllenchk plll ssss3 len)) T) T nil))
  354.       (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  355.       (setq lchk2 (if (eq (car (lllenchk plll (setq sss (reversess ssss4)) len)) T) T nil))
  356.       (if (and
  357.             (or wchk1 wchk2)
  358.             (or lchk1 lchk2)
  359.           )
  360.           (setq llpl plll)
  361.       )
  362.       (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  363.       (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  364.       (setq i -1)
  365.       (while (setq pl (ssname ss (setq i (1+ i))))
  366.         (ssadd pl ssss1)
  367.         (ssadd pl ssss2)
  368.         (ssadd pl ssss3)
  369.         (ssadd pl ssss4)
  370.       )
  371.     )
  372.     (if plnn (ssdel plnn ssss1))
  373.     (if plnn (ssdel plnn ssss2))
  374.     (if plnn (ssdel plnn ssss3))
  375.     (if plnn (ssdel plnn ssss4))
  376.     (if plnn (ssadd plnn ssss1))
  377.     (if plnn (ssadd plnn ssss2))
  378.     (if plnn (ssadd plnn ssss3))
  379.     (if plnn (ssadd plnn ssss4))
  380.     (if plmm (ssdel plmm ssss1))
  381.     (if plmm (ssdel plmm ssss2))
  382.     (if plmm (ssdel plmm ssss3))
  383.     (if plmm (ssdel plmm ssss4))
  384.     (if plmm (ssadd plmm ssss1))
  385.     (if plmm (ssadd plmm ssss2))
  386.     (if plmm (ssadd plmm ssss3))
  387.     (if plmm (ssadd plmm ssss4))
  388.     (ssadd llpl ssss)
  389.     (sssetfirst nil (ssadd llpl))
  390.     (setq llpls nil)
  391.  
  392.     (setq i -1)
  393.     (command "_.ucs" "z" 90)
  394.     (while (setq pl (ssname ssss1 (setq i (1+ i))))
  395.       (setq vlst (plvlst pl))
  396.       (if (LM:ListClockwise-p vlst)
  397.         (progn
  398.           (command "_.reverse" pl "")
  399.           (setq vlst (plvlst pl))
  400.         )
  401.       )
  402.       (if (llchk vlst) (setq llpls (cons pl llpls)))
  403.     )
  404.     (foreach plll (reverse llpls)
  405.       (ssdel plll ssss1)
  406.       (ssdel plll ssss2)
  407.       (ssdel plll ssss3)
  408.       (ssdel plll ssss4)
  409.       (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  410.       (setq wchk1 (if (eq (car (setq plnn (llwidchk plll ssss1 len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  411.       (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  412.       (setq wchk2 (if (eq (car (setq plnn (llwidchk plll (setq sss (reversess ssss2)) len))) T) (progn (setq plnn (cadr plnn)) T) nil))
  413.       (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  414.       (setq lchk1 (if (eq (car (lllenchk plll ssss3 wid)) T) T nil))
  415.       (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  416.       (setq lchk2 (if (eq (car (lllenchk plll (setq sss (reversess ssss4)) wid)) T) T nil))
  417.       (if (and
  418.             (or wchk1 wchk2)
  419.             (or lchk1 lchk2)
  420.           )
  421.           (setq llpl plll)
  422.       )
  423.       (setq wchk1 nil wchk2 nil lchk1 nil lchk2 nil)
  424.       (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  425.       (setq i -1)
  426.       (while (setq pl (ssname ss (setq i (1+ i))))
  427.         (ssadd pl ssss1)
  428.         (ssadd pl ssss2)
  429.         (ssadd pl ssss3)
  430.         (ssadd pl ssss4)
  431.       )
  432.     )
  433.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstnn nil plnwid nil plns nil npl nil chk nil plx nil)
  434.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstpp nil plplen nil plps nil ppl nil chk nil ply nil)
  435.     (ssadd llpl ssss)
  436.     (sssetfirst nil (ssadd llpl))
  437.     (setq llpls nil)
  438.  
  439.     ssss
  440.   )
  441.  
  442.   (command "_.ucs" "w")
  443.   (setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "&=") (70 . 1))))
  444.   (setq p1 (getpoint "\nPick start corner : "))
  445.   (setq p2 (getcorner p1 "\nPick end corner : "))
  446.   (setq vec (mapcar '- p2 p1))
  447.   (setq wid (abs (car vec)))
  448.   (setq len (abs (cadr vec)))
  449.  
  450.   (command "_.ucs" "w")
  451.   (setq i -1)
  452.   (while (setq pl (ssname ss (setq i (1+ i))))
  453.     (setq vlst (plvlst pl))
  454.     (if (LM:ListClockwise-p vlst)
  455.       (progn
  456.         (command "_.reverse" pl "")
  457.         (setq vlst (plvlst pl))
  458.       )
  459.     )
  460.     (if (llchk vlst) (setq llplss (cons pl llplss)))
  461.   )
  462.   (setq loop T)
  463.   (while (and (setq plll (car llplss)) loop)
  464.     (if (eq (vl-catch-all-apply 'sslength (list (setq s (vl-catch-all-apply 'putme (list plll ss))))) 4)
  465.       (progn
  466.         (setq sssss (ssadd))
  467.         (ssadd (ssname s 0) sssss)
  468.         (ssadd (ssname s 1) sssss)
  469.         (ssadd (ssname s 2) sssss)
  470.         (ssadd (ssname s 3) sssss)
  471.       )
  472.       (setq sssss (ssadd))
  473.     )
  474.     (sssetfirst nil sssss)
  475.     (if (eq (getstring "\nENTER TO CONTINUE (NEXT SOLUTION) - A KEY+ENTER TO EXIT AND KEEP SOLUTION : ") "")
  476.       (setq llplss (cdr llplss))
  477.       (setq loop nil)
  478.     )
  479.   )
  480.   (command "_.ucs" "w")
  481.   (if sssss (sssetfirst nil sssss))
  482.  
  483.   (princ)
  484. )
  485.  

M.R.
« Last Edit: June 23, 2013, 04:38:03 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #41 on: June 23, 2013, 04:42:46 PM »
My last code is modified to be applicable for all candidate entities that passes check of lower-left angle of 90 degrees... It is now iterating through list of all these entities... When desired solution is found, you have option to keep selected entities...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #42 on: June 24, 2013, 09:41:08 AM »
Although I suggest that you use my last code, here are 2 lisps developed further more, but with many lacks...

Picking version is correct, but it is totally unnecessary, as you can pick entities and you'll have them griped and without routine...
Pick version is longest developed, it asks for starting lower-left piece, result correct and for *-MR5.dwg...

Both codes are time consuming, but who likes it to see them testing here they are... See attachment...

M.R.
« Last Edit: June 24, 2013, 02:24:13 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #43 on: June 24, 2013, 02:26:04 PM »
Finally modified my attached lisp - pick version to be applicable and for case like *-MR5.dwg - see attachment...

Regards, yours M.R.
 8-) 8-) 8-)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube