TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: pBe on June 15, 2013, 12:32:39 PM

Title: ==={Challenge}=== Broken Pieces
Post by: pBe on June 15, 2013, 12:32:39 PM
Try to put me back together: [jigsaw--<< straight segments>>--]
EDIT: Guess to make it easier. the four corner points should be defined...... or Width and Length is given....
Also note that none of the pieces are rotated. now thats one less thing to worry about  :)


Re-writing code..... 19June2013
Code: [Select]
..............................
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 16, 2013, 03:53:14 AM
PSEUDO CODE:

Select objects:
Get Length and Width ;<--- still not sure...  Get LL and UR [getpoint/getcorner] to determine coordinates for corners + L and W.
Extract object coordinates
Extract Boundingbox
Build upper left and lower right points
Determine object direction [C/CCW]
Capture objects for 4 corners starting with LL clockwise direction
Remove captured pieces from list
Iterate thru remaining pieces to determine matching piece from lower left corner clockwise direction
Starting with objects with segments at angle 90, 0, 270 and 180 respectively
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac on June 16, 2013, 11:08:10 AM
A difficult challenge...  :evil:

This is terrible coding, but should get somewhere near:
Code: [Select]
(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)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 16, 2013, 12:12:05 PM
First Entry is from Lee Mac.
I honestly have not tried your code yet LM . I'll post mine later or tomrw. i hit a snag on the last piece. Makes me wonder how difficult it will be if there are more pieces located on the middle of the jigsaw.
Thank you for the submission LM.
Cheers  :)
 
 
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac on June 16, 2013, 12:36:52 PM
Cheers pBe  8-)

The key to the challenge is to first calculate the interior angles for every vertex of every piece, and then compare every group of two, three, four, ... ,n vertices (where n is the number of pieces) to find those groups of angles which sum to either 2π (or π radians for edge pieces). If such a group is found, move the pieces such that the vertices contributing to the angle sum coincide.

The pieces that have been moved would then need to be collected in a separate set to ensure that pieces in the candidate set are moved to form the jigsaw and tesselating pieces are unaltered.

My current program follows this method, however, only comparing pairs of pieces.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 16, 2013, 12:53:22 PM
Cheers pBe  8)

The key to the challenge is to first calculate the interior angles.........
My current program follows this method, however, only comparing pairs of pieces.
Cool. oops. I shouldn't be reading this till i finish my own routine .  :lmao: 

I'll keep that in mind....

Cheers
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 16, 2013, 01:20:06 PM
I only want to locate lower-left polyline, but there is some bug in my code... Please, if you know how to debug it correctly... By my research incrementation isn't working in my 2 last subfunctions...

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 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:
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 17, 2013, 03:55:55 AM
I have successfully debugged my code in certain measure... Now pBe's *dwg example is working, but my example below isn't... Please, see attached *.dwg

M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 17, 2013, 07:05:00 AM
Updated and finally debugged code to be applicable for both cases... Still not tested in who knows what situation - it may fail...

Regards, M.R.
 :lol:
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 17, 2013, 07:07:42 AM
Cool. another entry, Am still working on mine  ;D .

Thank you Marko. I'll try it later. Don't want someones else's idea influence the code im working on.

Cheers
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 17, 2013, 03:51:41 PM
Also, this should be working, but if you manipulate with objects (rotate or similar) - it may fail... Also note that on scattered pieces on the left side it's working almost as it should - 3 corners are highlighted, and on the right side where are all pieces combined into one rectangle it's highlighting only one corner... I believe that this also has something to do with inaccurate calculations of (trans pt 0 1)... Fuzz factors seems are not the issue - I've checked this also...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:putmetogether ( / AssocOn LM:ListClockwise-p member-fuzz plvlst llchk prevang nextang suppang anglst dstlst mdpairs reversess llwidchk lllenchk
  2.                            p1 p2 vec ss ssss ssss1 ssss2 ssss3 ssss4 ssss5 wid len i pl vlst llpls llpl )
  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 / sssss i ent )
  126.     (gc)
  127.     (setq sssss (ssadd))
  128.     (repeat (setq i (sslength s))
  129.       (setq ent (ssname s (setq i (1- i))))
  130.       (ssadd ent sssss)
  131.     )
  132.     sssss
  133.   )
  134.  
  135.   (defun llwidchk ( llpl sss wid / loop i plin pln plnwid )
  136.     (if (not vlstw) (setq vlstw (plvlst llpl)))
  137.     (if (not alstw) (setq alstw (anglst vlstw)))
  138.     (if (not angn) (setq angn (nextang 0.0 vlstw)))
  139.     (if (not suppangn) (setq suppangn (suppang angn)))
  140.     (if (not llplwid) (setq llplwid (cdr (assocon 0.0 (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
  141.     (if (not lwid) (setq lwid llplwid))
  142.     (if (not dstchk1) (setq dstchk1 (cdr (assocon angn (mdpairs alstw (dstlst vlstw)) 'car 1e-6))))
  143.     (setq i -1)
  144.     (setq loop T)
  145.     (if (equal lwid wid 1e-6) (setq chk T loop nil))
  146.     (while (and (setq plin (if sss (ssname sss (setq i (1+ i))) nil)) loop)
  147.       (if (member-fuzz suppangn (anglst (plvlst plin)) 1e-6)
  148.         (setq pln plin)
  149.       )
  150.       (if pln
  151.         (progn
  152.           (setq plnwid (cdr (assocon 0.0 (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6))
  153.                 dstchk2 (cdr (assocon suppangn (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6))
  154.           )
  155.           (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)))
  156.           (if (equal dstchk1 dstchk2 1e-6)
  157.             (setq suppangn (suppang angn) dstchk1 (cdr (assocon angn (mdpairs (anglst (plvlst pln)) (dstlst (plvlst pln))) 'car 1e-6)))
  158.             (setq plnwid nil)
  159.           )
  160.         )
  161.       )
  162.       (if plnwid
  163.         (progn
  164.           (setq lwid (+ lwid plnwid))
  165.           (cond
  166.             ( (equal lwid wid 1e-6)
  167.               (setq chk T loop nil)
  168.             )
  169.             ( (< lwid wid)
  170.               (llwidchk nil (ssdel pln sss) wid)
  171.               (if (equal lwid wid 1e-6) (setq chk T loop nil))
  172.             )
  173.             ( (> lwid wid)
  174.               (setq chk nil loop nil)
  175.             )
  176.           )
  177.         )
  178.         (if (and pln (< lwid wid))
  179.           (progn
  180.             (llwidchk nil (ssdel pln sss) wid)
  181.             (if (equal lwid wid 1e-6) (setq chk T loop nil))
  182.           )
  183.           (cond
  184.             ( (equal lwid wid 1e-6)
  185.               (setq chk T loop nil)
  186.             )
  187.             ( (> lwid wid)
  188.               (setq chk nil loop nil)
  189.             )
  190.           )
  191.         )
  192.       )
  193.     )
  194.     chk
  195.   )
  196.  
  197.   (defun lllenchk ( llpl sss len / loop i plin plp plplen )
  198.     (if (not vlstl) (setq vlstl (plvlst llpl)))
  199.     (if (not alstl) (setq alstl (anglst vlstl)))
  200.     (if (not angp) (setq angp (prevang (* 1.5 pi) vlstl)))
  201.     (if (not suppangp) (setq suppangp (suppang angp)))
  202.     (if (not llpllen) (setq llpllen (cdr (assocon (* 1.5 pi) (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
  203.     (if (not llen) (setq llen llpllen))
  204.     (if (not dstchk1) (setq dstchk1 (cdr (assocon angp (mdpairs alstl (dstlst vlstl)) 'car 1e-6))))
  205.     (setq i -1)
  206.     (setq loop T)
  207.     (if (equal llen len 1e-6) (setq chk T loop nil))
  208.     (while (and (setq plin (if sss (ssname sss (setq i (1+ i))) nil)) loop)
  209.       (if (member-fuzz suppangp (anglst (plvlst plin)) 1e-6)
  210.         (setq plp plin)
  211.       )
  212.       (if plp
  213.         (progn
  214.           (setq plplen (cdr (assocon (* 1.5 pi) (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6))
  215.                 dstchk2 (cdr (assocon suppangp (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6))
  216.           )
  217.           (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)))
  218.           (if (equal dstchk1 dstchk2 1e-6)
  219.             (setq suppangp (suppang angp) dstchk1 (cdr (assocon angp (mdpairs (anglst (plvlst plp)) (dstlst (plvlst plp))) 'car 1e-6)))
  220.             (setq plplen nil)
  221.           )
  222.         )
  223.       )
  224.       (if plplen
  225.         (progn
  226.           (setq llen (+ llen plplen))
  227.           (cond
  228.             ( (equal llen len 1e-6)
  229.               (setq chk T loop nil)
  230.             )
  231.             ( (< llen len)
  232.               (lllenchk nil (ssdel plp sss) len)
  233.               (if (equal llen len 1e-6) (setq chk T loop nil))
  234.             )
  235.             ( (> llen len)
  236.               (setq chk nil loop nil)
  237.             )
  238.           )
  239.         )
  240.         (if (and plp (< llen len))
  241.           (progn
  242.             (lllenchk nil (ssdel plp sss) len)
  243.             (if (equal llen len 1e-6) (setq chk T loop nil))
  244.           )
  245.           (cond
  246.             ( (equal llen len 1e-6)
  247.               (setq chk T loop nil)
  248.             )
  249.             ( (> llen len)
  250.               (setq chk nil loop nil)
  251.             )
  252.           )
  253.         )
  254.       )
  255.     )
  256.     chk
  257.   )
  258.  
  259.   (command "_.ucs" "w")
  260.   (setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "&=") (70 . 1))))
  261.   (setq p1 (getpoint "\nPick start corner : "))
  262.   (setq p2 (getcorner p1 "\nPick end corner : "))
  263.   (setq vec (mapcar '- p2 p1))
  264.   (setq wid (abs (car vec)))
  265.   (setq len (abs (cadr vec)))
  266.  
  267.   (setq ssss (ssadd))
  268.   (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd) ssss5 (ssadd))
  269.   (setq i -1)
  270.   (command "_.ucs" "w")
  271.   (while (setq pl (ssname ss (setq i (1+ i))))
  272.     (setq vlst (plvlst pl))
  273.     (if (LM:ListClockwise-p vlst)
  274.       (progn
  275.         (command "_.reverse" pl "")
  276.         (setq vlst (plvlst pl))
  277.       )
  278.     )
  279.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  280.     (ssadd pl ssss1)
  281.     (ssadd pl ssss2)
  282.     (ssadd pl ssss3)
  283.     (ssadd pl ssss4)
  284.     (ssadd pl ssss5)
  285.   )
  286.   (foreach plll llpls
  287.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  288.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  289.     (ssdel plll ssss1)
  290.     (ssdel plll ssss2)
  291.     (ssdel plll ssss3)
  292.     (ssdel plll ssss4)
  293.     (if (and
  294.           (or (llwidchk plll ssss1 wid) (llwidchk plll (setq sss (reversess ssss2)) wid))
  295.           (or (lllenchk plll ssss3 len) (lllenchk plll (setq sss (reversess ssss4)) len))
  296.         )
  297.         (setq llpl plll)
  298.     )
  299.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  300.     (setq i -1)
  301.     (while (setq pl (ssname ssss5 (setq i (1+ i))))
  302.       (ssadd pl ssss1)
  303.       (ssadd pl ssss2)
  304.       (ssadd pl ssss3)
  305.       (ssadd pl ssss4)
  306.     )
  307.   )
  308.   (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  309.   (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  310.   (prompt "\nLower-left 2d polyline is highlighted - ENTER TO CONTINUE")
  311.   (ssadd llpl ssss)
  312.   (sssetfirst nil (ssadd llpl))
  313.   (setq llpls nil)
  314.   (gc)
  315.   (command "\\")
  316.  
  317.   (setq i -1)
  318.   (command "_.ucs" "z" 90)
  319.   (while (setq pl (ssname ss (setq i (1+ i))))
  320.     (setq vlst (plvlst pl))
  321.     (if (LM:ListClockwise-p vlst)
  322.       (progn
  323.         (command "_.reverse" pl "")
  324.         (setq vlst (plvlst pl))
  325.       )
  326.     )
  327.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  328.   )
  329.   (foreach plll llpls
  330.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  331.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  332.     (ssdel plll ssss1)
  333.     (ssdel plll ssss2)
  334.     (ssdel plll ssss3)
  335.     (ssdel plll ssss4)
  336.     (if (and
  337.           (or (llwidchk plll ssss1 len) (llwidchk plll (setq sss (reversess ssss2)) len))
  338.           (or (lllenchk plll ssss3 wid) (lllenchk plll (setq sss (reversess ssss4)) wid))
  339.         )
  340.         (setq llpl plll)
  341.     )
  342.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  343.     (setq i -1)
  344.     (while (setq pl (ssname ssss5 (setq i (1+ i))))
  345.       (ssadd pl ssss1)
  346.       (ssadd pl ssss2)
  347.       (ssadd pl ssss3)
  348.       (ssadd pl ssss4)
  349.     )
  350.   )
  351.   (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  352.   (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  353.   (prompt "\nLower-right 2d polyline is highlighted - ENTER TO CONTINUE")
  354.   (ssadd llpl ssss)
  355.   (sssetfirst nil (ssadd llpl))
  356.   (setq llpls nil)
  357.   (gc)
  358.   (command "\\")
  359.  
  360.   (setq i -1)
  361.   (command "_.ucs" "z" 90)
  362.   (while (setq pl (ssname ss (setq i (1+ i))))
  363.     (setq vlst (plvlst pl))
  364.     (if (LM:ListClockwise-p vlst)
  365.       (progn
  366.         (command "_.reverse" pl "")
  367.         (setq vlst (plvlst pl))
  368.       )
  369.     )
  370.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  371.   )
  372.   (foreach plll llpls
  373.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  374.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  375.     (ssdel plll ssss1)
  376.     (ssdel plll ssss2)
  377.     (ssdel plll ssss3)
  378.     (ssdel plll ssss4)
  379.     (if (and
  380.           (or (llwidchk plll ssss1 wid) (llwidchk plll (setq sss (reversess ssss2)) wid))
  381.           (or (lllenchk plll ssss3 len) (lllenchk plll (setq sss (reversess ssss4)) len))
  382.         )
  383.         (setq llpl plll)
  384.     )
  385.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  386.     (setq i -1)
  387.     (while (setq pl (ssname ssss5 (setq i (1+ i))))
  388.       (ssadd pl ssss1)
  389.       (ssadd pl ssss2)
  390.       (ssadd pl ssss3)
  391.       (ssadd pl ssss4)
  392.     )
  393.   )
  394.   (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  395.   (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  396.   (prompt "\nUpper-right 2d polyline is highlighted - ENTER TO CONTINUE")
  397.   (ssadd llpl ssss)
  398.   (sssetfirst nil (ssadd llpl))
  399.   (setq llpls nil)
  400.   (gc)
  401.   (command "\\")
  402.  
  403.   (setq i -1)
  404.   (command "_.ucs" "z" 90)
  405.   (while (setq pl (ssname ss (setq i (1+ i))))
  406.     (setq vlst (plvlst pl))
  407.     (if (LM:ListClockwise-p vlst)
  408.       (progn
  409.         (command "_.reverse" pl "")
  410.         (setq vlst (plvlst pl))
  411.       )
  412.     )
  413.     (if (llchk vlst) (setq llpls (cons pl llpls)))
  414.   )
  415.   (foreach plll llpls
  416.     (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  417.     (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  418.     (ssdel plll ssss1)
  419.     (ssdel plll ssss2)
  420.     (ssdel plll ssss3)
  421.     (ssdel plll ssss4)
  422.     (if (and
  423.           (or (llwidchk plll ssss1 len) (llwidchk plll (setq sss (reversess ssss2)) len))
  424.           (or (lllenchk plll ssss3 wid) (lllenchk plll (setq sss (reversess ssss4)) wid))
  425.         )
  426.         (setq llpl plll)
  427.     )
  428.     (setq ssss1 (ssadd) ssss2 (ssadd) ssss3 (ssadd) ssss4 (ssadd))
  429.     (setq i -1)
  430.     (while (setq pl (ssname ssss5 (setq i (1+ i))))
  431.       (ssadd pl ssss1)
  432.       (ssadd pl ssss2)
  433.       (ssadd pl ssss3)
  434.       (ssadd pl ssss4)
  435.     )
  436.   )
  437.   (setq vlstw nil alstw nil angn nil suppangn nil llplwid nil lwid nil dstchk1 nil dstchk2 nil chk nil)
  438.   (setq vlstl nil alstl nil angp nil suppangp nil llpllen nil llen nil dstchk1 nil dstchk2 nil chk nil)
  439.   (prompt "\nUpper-left 2d polyline is highlighted - ENTER TO CONTINUE")
  440.   (ssadd llpl ssss)
  441.   (sssetfirst nil (ssadd llpl))
  442.   (setq llpls nil)
  443.   (gc)
  444.   (command "\\")
  445.  
  446.   (command "_.ucs" "w")
  447.   (prompt "\nAll corner 2d polylines are highlighted")
  448.   (sssetfirst nil ssss)
  449.  
  450.   (princ)
  451. )
  452.  

M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 18, 2013, 01:49:45 AM
Posted an incomplete code at post #1..
I proceeded to follow the pseudo code on post # 2 just i could put together a working solution [not that its complete  :lmao: ]

Like a person would normally solve a jigsaw puzzle, Start with corners. do the edge and the middle last.
I will try to shorten the code as soon as i done.

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.
Still dissecting your code as of this writing..... [and you call it terrible coding.  ;D  that would make  mine  as Horrible then

Marko.
I didn't realized or read your fist post thoroughly, but it appears that code only highlight the corner pieces but doesn't really placed it on the board
Based on the number of lines on your code I'm sure you have something up your sleeve and the code is just a tease :)

My code and LMs' code might work on your drawing attachment if there are no other straight [Vertical/Horizontal] lines inside your jigsaw board.

You know like an ordinary jigsaw puzzle you buy on wall-mart.

Cheers
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 18, 2013, 02:03:42 AM
I have an idea.... what about playing "pick up where i left off" kind game.
Any takers?

Note: THIS IS NOT A DESPERATE ATTEMPT TO COMPLETE MY CODE [Though it looks like it]  :lmao:  <seriously its not>
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 18, 2013, 04:57:36 AM
My code is changed slightly to accept this case - note that edges intersect just in the center of rectangle and there are by 2 pieces with the same length of edge (crossing line is divided on half), so I had to add checking case with reversed order of selection set... One more (defun)... See attached example if you don't understand what I've explained...

Still - 4th corner can't be found - I just don't know why - everything is correctly written...

M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 18, 2013, 05:28:28 AM
Also note that these cases aren't working at all with my code...

M.R. (see attached)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 18, 2013, 05:55:27 AM
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?
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 18, 2013, 06:53:35 AM
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?

This puzzle is too complicated for my mind... I was just trying to dissect problem to basics (finding corners), but now as CAD isn't calculating correctly 4th corner with rotated UCS for checking upper-left piece, I am starting to loose patience... Still I am not good prepared for jigsaw challenge... If you can use my research, go ahead, you're welcome - this was my intention in the first place, but now I am seeing to many possibilities for this kind of task... And if I knew how to write jigsaw, still I think it wouldn't be totally applicable for all kind of situations... Still congratulate to all who even tries this challenge...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe on June 18, 2013, 06:59:52 AM
No worries Marko. just curious is all.


Thank you for your input MR.
Cheers

Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac on June 18, 2013, 07:20:36 AM
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.

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.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ElpanovEvgeniy on June 18, 2013, 11:49:00 AM
my version:
Code - Auto/Visual Lisp: [Select]
  1. (defun c:test (/ A A1 A2 B D L V V1)
  2.   (setq a1 (ssget)
  3.         l  (mapcar (function (lambda (b)
  4.                                (mapcar (function list)
  5.                                        (mapcar (function (lambda (a) (car b))) (cdr b))
  6.                                        (cdr b)
  7.                                        (cons (last b) (cdr b))
  8.                                )
  9.                              )
  10.                    )
  11.                    (mapcar (function (lambda (b)
  12.                                        (cons b
  13.                                              (vl-remove nil
  14.                                                         (mapcar (function (lambda (a)
  15.                                                                             (if (= (car a) 10)
  16.                                                                               (cdr a)
  17.                                                                             )
  18.                                                                           )
  19.                                                                 )
  20.                                                                 (entget b)
  21.                                                         )
  22.                                              )
  23.                                        )
  24.                                      )
  25.                            )
  26.                            (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex a1)))
  27.                    )
  28.            )
  29.         a1 nil
  30.         a2 nil
  31.         a  (car l)
  32.         l  (cdr l)
  33.   )
  34.   (while (and a l)
  35.     (progn
  36.       (setq b (car a)
  37.             v (mapcar (function -) (caddr b) (cadr b))
  38.       )
  39.       (foreach c l
  40.         (if (setq d (car (vl-member-if
  41.                            (function (lambda (d)
  42.                                        (equal v (mapcar (function -) (cadr d) (caddr d)) 1e-6)
  43.                                      )
  44.                            )
  45.                            c
  46.                          )
  47.                     )
  48.             )
  49.           (progn
  50.             (setq a2 (car (vl-remove-if-not (function (lambda (a) (assoc (car d) a))) l))
  51.                   v1 (mapcar (function -) (caddr d) (cadr b))
  52.                   a1 (vl-remove d
  53.                                 (append a1
  54.                                         (mapcar (function
  55.                                                   (lambda (a)
  56.                                                     (list (car a) (mapcar (function -) (cadr a) v1) (mapcar (function -) (caddr a) v1))
  57.                                                   )
  58.                                                 )
  59.                                                 a2
  60.                                         )
  61.                                 )
  62.                      )
  63.             )
  64.             (vla-move (vlax-ename->vla-object (car d)) (vlax-3d-point (caddr d)) (vlax-3d-point (cadr b)))
  65.             (setq l (vl-remove a2 l))
  66.           )
  67.         )
  68.       )
  69.       (if a1
  70.         (setq a  (append (cdr a) a1)
  71.               a1 nil
  72.         )
  73.         (setq a (cdr a))
  74.       )
  75.     )
  76.   )
  77. )
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 18, 2013, 12:06:16 PM
I've updated my codes - in my last version I used (ssdel) function consequently and didn't realize that I have to do (ssadd) after to preserve selection set as it was... This is why it hadn't highlighted 4th piece (upper-left)...

I apologize for this inconvenience...

Marko R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 18, 2013, 12:24:43 PM
my version:
Code - Auto/Visual Lisp: [Select]
  1. (defun c:test (/ A A1 A2 B D L V V1)
  2.   (setq a1 (ssget)
  3.         l  (mapcar (function (lambda (b)
  4.                                (mapcar (function list)
  5.                                        (mapcar (function (lambda (a) (car b))) (cdr b))
  6.                                        (cdr b)
  7.                                        (cons (last b) (cdr b))
  8.                                )
  9.                              )
  10.                    )
  11.                    (mapcar (function (lambda (b)
  12.                                        (cons b
  13.                                              (vl-remove nil
  14.                                                         (mapcar (function (lambda (a)
  15.                                                                             (if (= (car a) 10)
  16.                                                                               (cdr a)
  17.                                                                             )
  18.                                                                           )
  19.                                                                 )
  20.                                                                 (entget b)
  21.                                                         )
  22.                                              )
  23.                                        )
  24.                                      )
  25.                            )
  26.                            (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex a1)))
  27.                    )
  28.            )
  29.         a1 nil
  30.         a2 nil
  31.         a  (car l)
  32.         l  (cdr l)
  33.   )
  34.   (while (and a l)
  35.     (progn
  36.       (setq b (car a)
  37.             v (mapcar (function -) (caddr b) (cadr b))
  38.       )
  39.       (foreach c l
  40.         (if (setq d (car (vl-member-if
  41.                            (function (lambda (d)
  42.                                        (equal v (mapcar (function -) (cadr d) (caddr d)) 1e-6)
  43.                                      )
  44.                            )
  45.                            c
  46.                          )
  47.                     )
  48.             )
  49.           (progn
  50.             (setq a2 (car (vl-remove-if-not (function (lambda (a) (assoc (car d) a))) l))
  51.                   v1 (mapcar (function -) (caddr d) (cadr b))
  52.                   a1 (vl-remove d
  53.                                 (append a1
  54.                                         (mapcar (function
  55.                                                   (lambda (a)
  56.                                                     (list (car a) (mapcar (function -) (cadr a) v1) (mapcar (function -) (caddr a) v1))
  57.                                                   )
  58.                                                 )
  59.                                                 a2
  60.                                         )
  61.                                 )
  62.                      )
  63.             )
  64.             (vla-move (vlax-ename->vla-object (car d)) (vlax-3d-point (caddr d)) (vlax-3d-point (cadr b)))
  65.             (setq l (vl-remove a2 l))
  66.           )
  67.         )
  68.       )
  69.       (if a1
  70.         (setq a  (append (cdr a) a1)
  71.               a1 nil
  72.         )
  73.         (setq a (cdr a))
  74.       )
  75.     )
  76.   )
  77. )

Wonderful, it works!!! In most cases it's truly correct...

Thanks, EEA...
 :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ElpanovEvgeniy on June 18, 2013, 01:39:27 PM
Wonderful, it works!!! In most cases it's truly correct...

Thanks, EEA...
 :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-) :-)

Thank you!
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac on June 18, 2013, 01:58:11 PM
Matching edges instead of vertices - good method Evgeniy  :-)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ElpanovEvgeniy on June 18, 2013, 02:03:19 PM
Matching edges instead of vertices - good method Evgeniy  :-)

Yes, if all the edges of different lengths
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 18, 2013, 03:02:46 PM
And that tile thingy? butted against each other? yeahh.. you know what i mean MR.

So sel. sets were the problem with my codes...
Except this case pBe, at least and if it find wrong piece it won't break now...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: dgorsman on June 18, 2013, 03:31:03 PM
Matching edges instead of vertices - good method Evgeniy  :-)

Yes, if all the edges of different lengths

That was my initial thought of attack as well.  Could probably extend that to handle adjoining edges, which would reduce the possibilities to a very low numbers.  If its pattern-broken like a jigsaw puzzle cutter I'm thinking it would be very difficult to get everything back together without some other qualifier.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on June 18, 2013, 06:05:14 PM
My codes on page 1 finally updated...

Regards, M.R. :-) :-) :-)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: LE3 on June 18, 2013, 10:42:28 PM
Code - C#: [Select]
  1. [CommandMethod("TOGETHER")]
  2. public void cmd_together()
  3. {
  4.     var e = AcadApp.DocumentManager.MdiActiveDocument.Editor;
  5.     var tv = new TypedValue[] { new TypedValue((int)DxfCode.Start, "LWPOLYLINE") };
  6.     var filter = new SelectionFilter(tv);
  7.     var options = new PromptSelectionOptions();
  8.     options.MessageForAdding = "\nAdd PolyLine(s) to selection";
  9.     options.MessageForRemoval = "\nRemove PolyLine(s) from selection";
  10.     options.AllowDuplicates = false;
  11.     options.RejectObjectsFromNonCurrentSpace = true;
  12.     var psr = e.GetSelection(options, filter);
  13.     if (psr.Status != PromptStatus.OK) return;
  14.     double delta = 0.0000001;
  15.     using (var tr = e.Document.Database.TransactionManager.StartTransaction())
  16.     {
  17.         var ids = psr.Value.GetObjectIds();
  18.         foreach (var id in ids)
  19.         {
  20.             var polyline = (Polyline)tr.GetObject(id, OpenMode.ForWrite, false);
  21.             for (int i = 0; i < polyline.NumberOfVertices; i++)
  22.             {
  23.                 var line = polyline.GetLineSegmentAt(i);
  24.                 var found = false;
  25.                 foreach (var _id in ids)
  26.                 {
  27.                     var _polyline = (Polyline)tr.GetObject(_id, OpenMode.ForWrite, false);
  28.                     if (_polyline == polyline) continue;
  29.                     for (int ii = 0; ii < _polyline.NumberOfVertices; ii++)
  30.                     {
  31.                         var _line = _polyline.GetLineSegmentAt(ii);
  32.                         if (Math.Abs(line.Length - _line.Length) < delta)
  33.                         {
  34.                             var m = Matrix3d.Displacement(line.MidPoint - _line.MidPoint);
  35.                             _polyline.TransformBy(m);
  36.                             found = true;
  37.                             break;
  38.                         }
  39.                     }
  40.                     if (found) break;
  41.                 }
  42.             }
  43.         }
  44.         tr.Commit();
  45.     }
  46. }
The above will put together the shapes.-
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Kerry on June 18, 2013, 11:50:29 PM
my version:
Code - Auto/Visual Lisp: [Select]
  1. (defun c:test (/ A A1 A2 B D L V V1)
  2.   <...>
  3.  
  4. )

Smart bit of code Evgeniy :)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: pBe 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  :)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac 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. )
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ElpanovEvgeniy 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 :)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac 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-)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm 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-)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on July 06, 2013, 10:33:49 AM
This site allows posting of too large codes...

http://www.autolisp.com/forum/threads/831-putmetogether-pick-lsp-from-theswamp-org-checking-length-of-post?p=3087#post3087

M.R.
 :-) :-) :-)
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on July 06, 2013, 11:26:15 AM
Also, if I may put remark... Evgeniy and Lee's intervention to the code didn't include the case in witch plines are drawn in reverse direction, so if all distances and edges are different this should work in any situation :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:jigsaw ( / LM:ListClockwise-p a a1 a2 b d e i l s v v1 x y )
  2.  
  3.     (vl-load-com)
  4.  
  5.     (defun LM:ListClockwise-p ( lst )
  6.       (minusp
  7.         (apply '+
  8.           (mapcar
  9.             (function
  10.               (lambda ( a b )
  11.                 (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  12.               )
  13.             ) lst (cons (last lst) lst)
  14.           )
  15.         )
  16.       )
  17.     )
  18.  
  19.     (if (setq s (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
  20.        (progn
  21.            (repeat (setq i (sslength s))
  22.                (setq e (ssname s (setq i (1- i)))
  23.                      v (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget e)))
  24.                )
  25.                (if (LM:ListClockwise-p v)
  26.                    (progn
  27.                       (command "_.reverse" e "")
  28.                       (setq v (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget e))))
  29.                    )
  30.                )
  31.                (setq l (cons (cons (vlax-ename->vla-object e) (mapcar 'list v (cons (last v) v))) l))
  32.            )
  33.            (setq a (list (car l))
  34.                  l (cdr l)
  35.            )
  36.            (while (and (setq b (car a)) l)
  37.                (setq v (mapcar '- (cadadr b) (caadr b)))
  38.                (foreach c l
  39.                    (if (setq d (car (vl-member-if '(lambda ( x ) (equal v (mapcar '- (car x) (cadr x)) 1e-6)) (cdr c))))
  40.                        (progn
  41.                            (setq a2 (assoc (car c) l)
  42.                                  v1 (mapcar '- (cadr d) (caadr b))
  43.                                  a1 (cons (cons (car c) (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (mapcar '- y v1)) x)) (vl-remove d (cdr a2)))) a1)
  44.                                   l (vl-remove a2 l)
  45.                            )
  46.                            (vla-move (car c) (vlax-3D-point (cadr d)) (vlax-3D-point (caadr b)))
  47.                        )
  48.                    )
  49.                )
  50.                (setq a (append (if (cddar a) (cons (cons (car a) (cddar a)) (cdr a)) (cdr a)) a1)
  51.                      a1 nil
  52.                )
  53.            )
  54.        )
  55.    )
  56.    (princ)
  57. )
  58.  

Regards, M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac on July 06, 2013, 12:51:31 PM
There is no need to reverse & modify the source objects; this should suffice:

Code - Auto/Visual Lisp: [Select]
  1. (defun c:test ( / a a1 a2 b d e i l p s v w 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
  17.                             (vl-member-if
  18.                                '(lambda ( x )
  19.                                     (cond ((equal v (mapcar '- (car x) (cadr x)) 1e-6) (setq p (cadr x)))
  20.                                           ((equal v (mapcar '- (cadr x) (car x)) 1e-6) (setq p (car  x)))
  21.                                     )
  22.                                 )
  23.                                 (cdr c)
  24.                             )
  25.                         )
  26.                         (progn
  27.                             (setq a2 (assoc (car c) l)
  28.                                    w (mapcar '- p (caadr b))
  29.                                   a1 (cons (cons (car c) (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (mapcar '- y w)) x)) (vl-remove d (cdr a2)))) a1)
  30.                                    l (vl-remove a2 l)
  31.                             )
  32.                             (vla-move (car c) (vlax-3D-point p) (vlax-3D-point (caadr b)))
  33.                         )
  34.                     )
  35.                 )
  36.                 (setq a (append (if (cddar a) (cons (cons (car a) (cddar a)) (cdr a)) (cdr a)) a1)
  37.                       a1 nil
  38.                 )
  39.             )
  40.         )
  41.     )
  42.     (princ)
  43. )
Title: Re: ==={Challenge}=== Broken Pieces
Post by: fixo on July 06, 2013, 01:17:02 PM

The above will put together the shapes.-
Thanks LE, it's working good through A2010-14
with small changes per release
Regards,
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on July 06, 2013, 05:02:45 PM
There is no need to reverse & modify the source objects; this should suffice:

Code - Auto/Visual Lisp: [Select]
  1. (defun c:test ( / a a1 a2 b d e i l p s v w x y )

Look Lee, I see that you really want to solve this code to be as short as possible, but test it on attached example... Your previous code was correct, only necessity was reversing of plines... In case CAD doesn't support (command "_.reverse"), Evgeniy solved this for LWPOLYLINE in sub-function (rlw)... Your new code fails here, and in case of preserving reversion, we can always build list of entities that were reversed and in the end reverse them back as they were before execution of routine...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:jigsaw ( / LM:ListClockwise-p rlw el a a1 a2 b d e i l s v v1 x y )
  2.  
  3.     (vl-load-com)
  4.  
  5.     (defun LM:ListClockwise-p ( lst )
  6.       (minusp
  7.         (apply '+
  8.           (mapcar
  9.             (function
  10.               (lambda ( a b )
  11.                 (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  12.               )
  13.             ) lst (cons (last lst) lst)
  14.           )
  15.         )
  16.       )
  17.     )
  18.  
  19.     (defun rlw ( LW / E X1 X2 X3 X4 X5 X6 )
  20.         ;; by ElpanovEvgeniy
  21.         ;; reverse lwpolyline
  22.         (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
  23.             (progn
  24.                 (foreach a1 e
  25.                     (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
  26.                           ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
  27.                           ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
  28.                           ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
  29.                           ((= (car a1) 210) (setq x6 (cons a1 x6)))
  30.                           (t (setq x1 (cons a1 x1)))
  31.                     )
  32.                 )
  33.                 (entmod
  34.                     (append
  35.                         (reverse x1)
  36.                             (append
  37.                                 (apply
  38.                                     (function append)
  39.                                         (apply
  40.                                             (function mapcar)
  41.                                                 (cons 'list
  42.                                                     (list x2
  43.                                                         (cdr (reverse (cons (car x3) (reverse x3))))
  44.                                                         (cdr (reverse (cons (car x4) (reverse x4))))
  45.                                                         (cdr (reverse (cons (car x5) (reverse x5))))
  46.                                                     )
  47.                                                 )
  48.                                         )
  49.                                 )
  50.                                 x6
  51.                             )
  52.                     )
  53.                 )
  54.                 (entupd lw)
  55.             )
  56.         )
  57.     )
  58.  
  59.     (if (setq s (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
  60.         (progn
  61.             (repeat (setq i (sslength s))
  62.                 (setq e (ssname s (setq i (1- i)))
  63.                       v (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget e)))
  64.                 )
  65.                 (if (LM:ListClockwise-p v)
  66.                     (progn
  67.                        (rlw e)
  68.                        (setq el (cons e el))
  69.                        (setq v (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget e))))
  70.                     )
  71.                 )
  72.                 (setq l (cons (cons (vlax-ename->vla-object e) (mapcar 'list v (cons (last v) v))) l))
  73.             )
  74.             (setq a (list (car l))
  75.                   l (cdr l)
  76.             )
  77.             (while (and (setq b (car a)) l)
  78.                 (setq v (mapcar '- (cadadr b) (caadr b)))
  79.                 (foreach c l
  80.                     (if (setq d (car (vl-member-if '(lambda ( x ) (equal v (mapcar '- (car x) (cadr x)) 1e-6)) (cdr c))))
  81.                         (progn
  82.                             (setq a2 (assoc (car c) l)
  83.                                   v1 (mapcar '- (cadr d) (caadr b))
  84.                                   a1 (cons (cons (car c) (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (mapcar '- y v1)) x)) (vl-remove d (cdr a2)))) a1)
  85.                                    l (vl-remove a2 l)
  86.                             )
  87.                             (vla-move (car c) (vlax-3D-point (cadr d)) (vlax-3D-point (caadr b)))
  88.                         )
  89.                     )
  90.                 )
  91.                 (setq a (append (if (cddar a) (cons (cons (car a) (cddar a)) (cdr a)) (cdr a)) a1)
  92.                       a1 nil
  93.                 )
  94.             )
  95.         )
  96.     )
  97.    
  98.     (foreach e el
  99.         (rlw e)
  100.     )
  101.    
  102.     (princ)
  103. )
  104.  

M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: Lee Mac on July 07, 2013, 06:39:05 AM
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.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on July 07, 2013, 08:51:47 AM
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?
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on July 07, 2013, 09:03:11 AM
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?

Yes, Lee, I suppose you're right... My example has 2 edges that are the same distance and angle as 2 edges of next two pieces and 2 edges of pieces that should compose rectangle with different pieces... So this is really bad example... Never mind, I suppose both versions should work in other situation where all edges are different...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: LE3 on July 07, 2013, 03:17:19 PM
Thanks LE, it's working good through A2010-14
with small changes per release
Regards,
I am glad you tried - Thanks Oleg !
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on February 13, 2023, 08:07:24 AM
I want to revive this topic as I've coded something likewise jigsaw... Still, not 100% sure it would be bullet proof, but here is it...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:jigsaw-ortho ( / *error* listclockwise-p rlw jigsaw s ss i lws orth chk )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if (= 8 (logand 8 (getvar (quote undoctl))))
  6.       (if command-s
  7.         (command-s "_.UNDO" "_E")
  8.         (vl-cmdf "_.UNDO" "_E")
  9.       )
  10.     )
  11.     (if m
  12.       (prompt m)
  13.     )
  14.     (princ)
  15.   )
  16.  
  17.   (defun listclockwise-p ( lst )
  18.     ;; by Lee Mac
  19.     (minusp
  20.       (apply (function +)
  21.         (mapcar
  22.           (function (lambda ( a b )
  23.             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  24.           ))
  25.           lst
  26.           (cons (last lst) lst)
  27.         )
  28.       )
  29.     )
  30.   )
  31.  
  32.   (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
  33.     ;; by Elpanov Evgeniy
  34.     (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
  35.       (progn
  36.         (foreach a1 e
  37.           (cond
  38.             ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
  39.             ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
  40.             ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
  41.             ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
  42.             ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
  43.             ( t (setq x1 (cons a1 x1)) )
  44.           )
  45.         )
  46.         (entmod
  47.           (append
  48.             (reverse x1)
  49.             (append
  50.               (apply (function append)
  51.                 (apply (function mapcar)
  52.                   (cons (function list)
  53.                     (list
  54.                       x2
  55.                       (cdr (reverse (cons (car x3) (reverse x3))))
  56.                       (cdr (reverse (cons (car x4) (reverse x4))))
  57.                       (cdr (reverse (cons (car x5) (reverse x5))))
  58.                     )
  59.                   )
  60.                 )
  61.               )
  62.               x6
  63.             )
  64.           )
  65.         )
  66.         (entupd lw)
  67.       )
  68.     )
  69.   )
  70.  
  71.   (defun jigsaw ( lws orth chk / unique inspectlw process lw lww lwww lwso lwss lwd lwdd lwwd q f )
  72.  
  73.     (defun unique ( lwd )
  74.       (if lwd
  75.         (cons
  76.           (car lwd)
  77.           (unique
  78.             (vl-remove-if
  79.               (function (lambda ( x )
  80.                 (and
  81.                   (equal (distance (caar lwd) (caddar lwd)) (distance (car x) (caddr x)) 1e-6)
  82.                   (or
  83.                     (equal (cadar lwd) (cadr x) 1e-6)
  84.                     (equal (rem (+ (cadar lwd) pi pi) (+ pi pi)) (rem (+ (cadr x) pi) (+ pi pi)) 1e-6)
  85.                     (equal (rem (+ (cadar lwd) pi) (+ pi pi)) (rem (+ (cadr x) pi pi) (+ pi pi)) 1e-6)
  86.                   )
  87.                 )
  88.               ))
  89.               (cdr lwd)
  90.             )
  91.           )
  92.         )
  93.       )
  94.     )
  95.  
  96.     (defun inspectlw ( lw / lwx pts p0 angs edgs )
  97.       (setq lwx (entget lw))
  98.       (setq pts (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))
  99.       (setq p0 (car pts))
  100.       (foreach p1 (cdr pts)
  101.         (if
  102.           (or
  103.             (< (cadr p1) (cadr p0))
  104.             (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  105.           )
  106.           (setq p0 p1)
  107.         )
  108.       )
  109.       (setq pts (append (member p0 pts) (reverse (cdr (member p0 (reverse pts))))))
  110.       (setq angs (mapcar (function (lambda ( a b ) (angle a b))) pts (append (cdr pts) (list (car pts)))))
  111.       (setq edgs (mapcar (function (lambda ( p1 a p2 ) (list p1 a p2))) pts angs (append (cdr pts) (list (car pts)))))
  112.     )
  113.  
  114.     (defun process ( lws n lwd orth chk )
  115.       (if (and (setq lw (car lws)) (not lwd))
  116.         (setq lws (cdr lws) lwd (inspectlw lw))
  117.       )
  118.       (while (> n 1)
  119.         (foreach lww lws
  120.           (if lww
  121.             (setq lwwd (inspectlw lww))
  122.           )
  123.           (vl-some
  124.             (function (lambda ( edg1 )
  125.               (vl-some
  126.                 (function (lambda ( edg2 )
  127.                   (if
  128.                     (and
  129.                       (equal (distance (car edg1) (caddr edg1)) (distance (car edg2) (caddr edg2)) 1e-6)
  130.                       (if (not orth)
  131.                         (if
  132.                           (and
  133.                             (not (equal (cadr edg1) 0.0 1e-6))
  134.                             (not (equal (cadr edg2) 0.0 1e-6))
  135.                             (not (equal (cadr edg1) (* 0.5 pi) 1e-6))
  136.                             (not (equal (cadr edg2) (* 0.5 pi) 1e-6))
  137.                             (not (equal (cadr edg1) pi 1e-6))
  138.                             (not (equal (cadr edg2) pi 1e-6))
  139.                             (not (equal (cadr edg1) (* 1.5 pi) 1e-6))
  140.                             (not (equal (cadr edg2) (* 1.5 pi) 1e-6))
  141.                             (not (equal (cadr edg1) (* 2.0 pi) 1e-6))
  142.                             (not (equal (cadr edg2) (* 2.0 pi) 1e-6))
  143.                           )
  144.                           t
  145.                         )
  146.                         (if chk
  147.                           (vl-some
  148.                             (function (lambda ( edg3 )
  149.                               (vl-some
  150.                                 (function (lambda ( edg4 )
  151.                                   (and
  152.                                     (equal (distance (car edg3) (caddr edg3)) (distance (car edg4) (caddr edg4)) 1e-6)
  153.                                     (or
  154.                                       (equal (cadr edg3) (cadr edg4) 1e-6)
  155.                                       (equal (rem (+ (cadr edg3) pi) (+ pi pi)) (rem (+ (cadr edg4) pi pi) (+ pi pi)) 1e-6)
  156.                                       (equal (rem (+ (cadr edg3) pi pi) (+ pi pi)) (rem (+ (cadr edg4) pi) (+ pi pi)) 1e-6)
  157.                                     )
  158.                                   )
  159.                                 ))
  160.                                 (vl-remove edg2 lwwd)
  161.                               )
  162.                             ))
  163.                             (vl-remove edg1 lwd)
  164.                           )
  165.                           t
  166.                         )
  167.                       )
  168.                       (or
  169.                         (equal (cadr edg1) (cadr edg2) 1e-6)
  170.                         (equal (rem (+ (cadr edg1) pi) (+ pi pi)) (rem (+ (cadr edg2) pi pi) (+ pi pi)) 1e-6)
  171.                         (equal (rem (+ (cadr edg1) pi pi) (+ pi pi)) (rem (+ (cadr edg2) pi) (+ pi pi)) 1e-6)
  172.                       )
  173.                     )
  174.                     (progn
  175.                       (setq lws (vl-remove lww lws) n (1- n))
  176.                       (if (and edg3 edg4)
  177.                         (cond
  178.                           ( (and (equal (cadr edg3) (cadr edg4) 1e-6) (equal (car edg1) (car edg3) 1e-6) (equal (car edg2) (car edg4) 1e-6))
  179.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (car edg4)) (vlax-3d-point (car edg3)))
  180.                             (foreach x lwwd
  181.                               (if (not (equal edg4 x 1e-6))
  182.                                 (progn
  183.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (car edg4)) (car x)) (car x) x))
  184.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (car edg4)) (caddr xx)) (caddr xx) xx))
  185.                                   (setq lwd (cons xx lwd))
  186.                                 )
  187.                               )
  188.                             )
  189.                             (setq lwd (vl-remove edg3 lwd))
  190.                             (setq lwd (unique lwd))
  191.                           )
  192.                           ( (and
  193.                               (or
  194.                                 (equal (rem (+ (cadr edg3) pi) (+ pi pi)) (rem (+ (cadr edg4) pi pi) (+ pi pi)) 1e-6)
  195.                                 (equal (rem (+ (cadr edg3) pi pi) (+ pi pi)) (rem (+ (cadr edg4) pi) (+ pi pi)) 1e-6)
  196.                               )
  197.                               (equal (car edg1) (car edg3) 1e-6)
  198.                               (equal (car edg2) (car edg4) 1e-6)
  199.                             )
  200.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (caddr edg4)) (vlax-3d-point (car edg3)))
  201.                             (foreach x lwwd
  202.                               (if (not (equal edg4 x 1e-6))
  203.                                 (progn
  204.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (caddr edg4)) (car x)) (car x) x))
  205.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (caddr edg4)) (caddr xx)) (caddr xx) xx))
  206.                                   (setq lwd (cons xx lwd))
  207.                                 )
  208.                               )
  209.                             )
  210.                             (setq lwd (vl-remove edg3 lwd))
  211.                             (setq lwd (unique lwd))
  212.                           )
  213.                         )
  214.                         (cond
  215.                           ( (equal (cadr edg1) (cadr edg2) 1e-6)
  216.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (car edg2)) (vlax-3d-point (car edg1)))
  217.                             (foreach x lwwd
  218.                               (if (not (equal edg2 x 1e-6))
  219.                                 (progn
  220.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (car edg2)) (car x)) (car x) x))
  221.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (car edg2)) (caddr xx)) (caddr xx) xx))
  222.                                   (setq lwd (cons xx lwd))
  223.                                 )
  224.                               )
  225.                             )
  226.                             (setq lwd (vl-remove edg1 lwd))
  227.                             (setq lwd (unique lwd))
  228.                           )
  229.                           ( (or
  230.                               (equal (rem (+ (cadr edg1) pi) (+ pi pi)) (rem (+ (cadr edg2) pi pi) (+ pi pi)) 1e-6)
  231.                               (equal (rem (+ (cadr edg1) pi pi) (+ pi pi)) (rem (+ (cadr edg2) pi) (+ pi pi)) 1e-6)
  232.                             )
  233.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (caddr edg2)) (vlax-3d-point (car edg1)))
  234.                             (foreach x lwwd
  235.                               (if (not (equal edg2 x 1e-6))
  236.                                 (progn
  237.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (caddr edg2)) (car x)) (car x) x))
  238.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (caddr edg2)) (caddr xx)) (caddr xx) xx))
  239.                                   (setq lwd (cons xx lwd))
  240.                                 )
  241.                               )
  242.                             )
  243.                             (setq lwd (vl-remove edg1 lwd))
  244.                             (setq lwd (unique lwd))
  245.                           )
  246.                         )
  247.                       )
  248.                     )
  249.                   )
  250.                 ))
  251.                 lwwd
  252.               )
  253.             ))
  254.             lwd
  255.           )
  256.         )
  257.       )
  258.       lwd
  259.     )
  260.  
  261.     (foreach lw lws
  262.       (if lw
  263.         (setq lwdd (inspectlw lw))
  264.       )
  265.       (cond
  266.         ( (and
  267.             orth
  268.             (vl-every
  269.               (function (lambda ( w )
  270.                 (or
  271.                   (equal (cadr w) 0.0 1e-6)
  272.                   (equal (cadr w) (* 0.5 pi) 1e-6)
  273.                   (equal (cadr w) pi 1e-6)
  274.                   (equal (cadr w) (* 1.5 pi) 1e-6)
  275.                   (equal (cadr w) (* 2 pi) 1e-6)
  276.                 )
  277.               ))
  278.               lwdd
  279.             )
  280.           )
  281.           (setq lws (vl-remove lw lws) lwso (cons lw lwso))
  282.         )
  283.         ( (and
  284.             (not orth)
  285.             (vl-every
  286.               (function (lambda ( w )
  287.                 (or
  288.                   (equal (cadr w) 0.0 1e-6)
  289.                   (equal (cadr w) (* 0.5 pi) 1e-6)
  290.                   (equal (cadr w) pi 1e-6)
  291.                   (equal (cadr w) (* 1.5 pi) 1e-6)
  292.                   (equal (cadr w) (* 2 pi) 1e-6)
  293.                 )
  294.               ))
  295.               lwdd
  296.             )
  297.           )
  298.           (setq lws (vl-remove lw lws))
  299.         )
  300.       )
  301.     )
  302.     (setq lwd (process lws (length lws) nil orth (not chk)))
  303.     (if orth
  304.       (progn
  305.         (setq lwd (process (list (setq q (car (vl-sort lwso (function (lambda ( a b ) (< (vlax-curve-getarea a) (vlax-curve-getarea b)))))))) 2 lwd orth (not chk)))
  306.         (setq lwso (vl-remove q lwso))
  307.         (while
  308.           (or
  309.             (setq lwww (vl-some (function (lambda ( z / xx ) (if (and (setq xx (vl-some (function (lambda ( a ) (vl-some (function (lambda ( x ) (if (equal (distance (car a) (caddr a)) (distance (car x) (caddr x)) 1e-6) (list x a)))) (apply (function append) (mapcar (function inspectlw) lws))))) (apply (function append) (mapcar (function inspectlw) lwso)))) (vl-some (function (lambda ( b ) (vl-some (function (lambda ( y ) (and (not (equal b (car xx) 1e-6)) (not (equal b (cadr xx) 1e-6)) (not (equal y (car xx) 1e-6)) (not (equal y (cadr xx) 1e-6)) (equal (distance (car b) (caddr b)) (distance (car y) (caddr y)) 1e-6)))) (apply (function append) (mapcar (function inspectlw) lws))))) (apply (function append) (mapcar (function inspectlw) lwso)))) z))) (mapcar (function inspectlw) lwso)))
  310.             (car lwso)
  311.           )
  312.           (if (cdr lwso)
  313.             (foreach w lwso
  314.               (if (equal (inspectlw w) lwww 1e-6)
  315.                 (progn
  316.                   (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget w))))
  317.                     (setq lwd (process (list w) 2 (if (not f) (progn (setq f t) (reverse lwd)) lwd) orth (not chk)))
  318.                     (setq lwd (process (list w) 2 lwd orth (not chk)))
  319.                   )
  320.                   (setq lwso (vl-remove w lwso))
  321.                 )
  322.               )
  323.             )
  324.             (progn
  325.               (process (list (car lwso)) 2 lwd orth chk)
  326.               (setq lwso nil)
  327.             )
  328.           )
  329.         )
  330.       )
  331.     )
  332.   )
  333.  
  334.   (if (= 8 (logand 8 (getvar (quote undoctl))))
  335.     (if command-s
  336.       (command-s "_.UNDO" "_E")
  337.       (vl-cmdf "_.UNDO" "_E")
  338.     )
  339.   )
  340.   (if command-s
  341.     (command-s "_.UNDO" "_M")
  342.     (vl-cmdf "_.UNDO" "_M")
  343.   )
  344.   (initget "Yes No")
  345.   (setq orth (cond ( (getkword "\nEnable ortho or not [Yes / No] <Yes> : ") ) ( "Yes" ) ))
  346.   (if (= orth "Yes")
  347.     (setq orth t)
  348.     (setq orth nil)
  349.   )
  350.   (initget "Yes No")
  351.   (setq chk (cond ( (getkword "\nChoose check for ortho - if it stals chose \"No\" next time [Yes / No] <Yes> : ") ) ( "Yes" ) ))
  352.   (if (= chk "Yes")
  353.     (setq chk t)
  354.     (setq chk nil)
  355.   )
  356.   (prompt "\nSelect polygons you want CW - non orthogonal <ENTER - CONTINUE> : ")
  357.   (if (setq s (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  358.     (foreach lw (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
  359.       (if (not (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  360.         (rlw lw)
  361.       )
  362.     )
  363.   )
  364.   (prompt "\nSelect polygons you want CCW - orthogonal <ENTER - CONTINUE> : ")
  365.   (if (setq s (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  366.     (foreach lw (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
  367.       (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  368.         (rlw lw)
  369.       )
  370.     )
  371.   )
  372.   (prompt "\nSelect polygonal LWPOLYLINE(s) on unlocked Layer(s)...")
  373.   (if (setq ss (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  374.     (progn
  375.       (repeat (setq i (sslength ss))
  376.         (setq lws (cons (ssname ss (setq i (1- i))) lws))
  377.       )
  378.       (jigsaw lws orth chk)
  379.     )
  380.   )
  381.   (*error* nil)
  382. )
  383.  

I am waiting to see if we'll get some comment...
Regards, M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on March 30, 2023, 11:01:15 AM
Can someone solve jigsaw for orthogonal pieces... I am attaching *.DWG for testing purposes... For now I've updated my last input, but nevertheless it is not working with orthogonal pieces - rectangles... I am waiting to see if someone will jump in...

Thanks, M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on April 01, 2023, 02:12:37 AM
I've updated code from here : https://www.theswamp.org/index.php?topic=44783.msg613184#msg613184
But I still think that it's very hard to solve it correctly - added option for turning some polygons clockWise / Counterclockwise...

If you have a spare time, it's just for fun to check, as I think it can't be programmed well upon choosing various options...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on April 01, 2023, 08:01:36 AM
I've coded for that one example, but just for this case... Now how can we manage to find general solution, and this is 3 steps selection + twice ENTER...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:jigsaw-ortho ( / *error* listclockwise-p rlw jigsaw s ss i lws orth chk )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if (= 8 (logand 8 (getvar (quote undoctl))))
  6.       (if command-s
  7.         (command-s "_.UNDO" "_E")
  8.         (vl-cmdf "_.UNDO" "_E")
  9.       )
  10.     )
  11.     (if m
  12.       (prompt m)
  13.     )
  14.     (princ)
  15.   )
  16.  
  17.   (defun listclockwise-p ( lst )
  18.     ;; by Lee Mac
  19.     (minusp
  20.       (apply (function +)
  21.         (mapcar
  22.           (function (lambda ( a b )
  23.             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  24.           ))
  25.           lst
  26.           (cons (last lst) lst)
  27.         )
  28.       )
  29.     )
  30.   )
  31.  
  32.   (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
  33.     ;; by Elpanov Evgeniy
  34.     (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
  35.       (progn
  36.         (foreach a1 e
  37.           (cond
  38.             ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
  39.             ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
  40.             ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
  41.             ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
  42.             ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
  43.             ( t (setq x1 (cons a1 x1)) )
  44.           )
  45.         )
  46.         (entmod
  47.           (append
  48.             (reverse x1)
  49.             (append
  50.               (apply (function append)
  51.                 (apply (function mapcar)
  52.                   (cons (function list)
  53.                     (list
  54.                       x2
  55.                       (cdr (reverse (cons (car x3) (reverse x3))))
  56.                       (cdr (reverse (cons (car x4) (reverse x4))))
  57.                       (cdr (reverse (cons (car x5) (reverse x5))))
  58.                     )
  59.                   )
  60.                 )
  61.               )
  62.               x6
  63.             )
  64.           )
  65.         )
  66.         (entupd lw)
  67.       )
  68.     )
  69.   )
  70.  
  71.   (defun jigsaw ( lws orth chk / unique inspectlw process lw lww lwww lwso lwss lwd lwdd lwwd lwds q )
  72.  
  73.     (defun unique ( lwd )
  74.       (if lwd
  75.         (cons
  76.           (car lwd)
  77.           (unique
  78.             (vl-remove-if
  79.               (function (lambda ( x )
  80.                 (and
  81.                   (equal (distance (caar lwd) (caddar lwd)) (distance (car x) (caddr x)) 1e-6)
  82.                   (or
  83.                     (equal (cadar lwd) (cadr x) 1e-6)
  84.                     (equal (rem (+ (cadar lwd) pi pi) (+ pi pi)) (rem (+ (cadr x) pi) (+ pi pi)) 1e-6)
  85.                     (equal (rem (+ (cadar lwd) pi) (+ pi pi)) (rem (+ (cadr x) pi pi) (+ pi pi)) 1e-6)
  86.                   )
  87.                 )
  88.               ))
  89.               (cdr lwd)
  90.             )
  91.           )
  92.         )
  93.       )
  94.     )
  95.  
  96.     (defun inspectlw ( lw / lwx pts p0 angs edgs )
  97.       (setq lwx (entget lw))
  98.       (setq pts (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))
  99.       (setq p0 (car pts))
  100.       (foreach p1 (cdr pts)
  101.         (if
  102.           (or
  103.             (< (cadr p1) (cadr p0))
  104.             (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  105.           )
  106.           (setq p0 p1)
  107.         )
  108.       )
  109.       (setq pts (append (member p0 pts) (reverse (cdr (member p0 (reverse pts))))))
  110.       (setq angs (mapcar (function (lambda ( a b ) (angle a b))) pts (append (cdr pts) (list (car pts)))))
  111.       (setq edgs (mapcar (function (lambda ( p1 a p2 ) (list p1 a p2))) pts angs (append (cdr pts) (list (car pts)))))
  112.     )
  113.  
  114.     (defun process ( lws n lwd orth chk )
  115.       (if (and (setq lw (car lws)) (not lwd))
  116.         (setq lws (cdr lws) lwd (inspectlw lw))
  117.       )
  118.       (while (> n 1)
  119.         (foreach lww lws
  120.           (if lww
  121.             (setq lwwd (inspectlw lww))
  122.           )
  123.           (vl-some
  124.             (function (lambda ( edg1 )
  125.               (vl-some
  126.                 (function (lambda ( edg2 )
  127.                   (if
  128.                     (and
  129.                       (equal (distance (car edg1) (caddr edg1)) (distance (car edg2) (caddr edg2)) 1e-6)
  130.                       (if (not orth)
  131.                         (if
  132.                           (and
  133.                             (not (equal (cadr edg1) 0.0 1e-6))
  134.                             (not (equal (cadr edg2) 0.0 1e-6))
  135.                             (not (equal (cadr edg1) (* 0.5 pi) 1e-6))
  136.                             (not (equal (cadr edg2) (* 0.5 pi) 1e-6))
  137.                             (not (equal (cadr edg1) pi 1e-6))
  138.                             (not (equal (cadr edg2) pi 1e-6))
  139.                             (not (equal (cadr edg1) (* 1.5 pi) 1e-6))
  140.                             (not (equal (cadr edg2) (* 1.5 pi) 1e-6))
  141.                             (not (equal (cadr edg1) (* 2.0 pi) 1e-6))
  142.                             (not (equal (cadr edg2) (* 2.0 pi) 1e-6))
  143.                           )
  144.                           t
  145.                         )
  146.                         (if chk
  147.                           (vl-some
  148.                             (function (lambda ( edg3 )
  149.                               (vl-some
  150.                                 (function (lambda ( edg4 )
  151.                                   (and
  152.                                     (equal (distance (car edg3) (caddr edg3)) (distance (car edg4) (caddr edg4)) 1e-6)
  153.                                     (or
  154.                                       (equal (cadr edg3) (cadr edg4) 1e-6)
  155.                                       (equal (rem (+ (cadr edg3) pi) (+ pi pi)) (rem (+ (cadr edg4) pi pi) (+ pi pi)) 1e-6)
  156.                                       (equal (rem (+ (cadr edg3) pi pi) (+ pi pi)) (rem (+ (cadr edg4) pi) (+ pi pi)) 1e-6)
  157.                                     )
  158.                                   )
  159.                                 ))
  160.                                 (vl-remove edg2 lwwd)
  161.                               )
  162.                             ))
  163.                             (vl-remove edg1 lwd)
  164.                           )
  165.                           t
  166.                         )
  167.                       )
  168.                       (or
  169.                         (equal (cadr edg1) (cadr edg2) 1e-6)
  170.                         (equal (rem (+ (cadr edg1) pi) (+ pi pi)) (rem (+ (cadr edg2) pi pi) (+ pi pi)) 1e-6)
  171.                         (equal (rem (+ (cadr edg1) pi pi) (+ pi pi)) (rem (+ (cadr edg2) pi) (+ pi pi)) 1e-6)
  172.                       )
  173.                     )
  174.                     (progn
  175.                       (setq lws (vl-remove lww lws) n (1- n))
  176.                       (if (and edg3 edg4)
  177.                         (cond
  178.                           ( (and (equal (cadr edg3) (cadr edg4) 1e-6) (equal (car edg1) (car edg3) 1e-6) (equal (car edg2) (car edg4) 1e-6))
  179.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (car edg4)) (vlax-3d-point (car edg3)))
  180.                             (foreach x lwwd
  181.                               (if (not (equal edg4 x 1e-6))
  182.                                 (progn
  183.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (car edg4)) (car x)) (car x) x))
  184.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (car edg4)) (caddr xx)) (caddr xx) xx))
  185.                                   (setq lwd (cons xx lwd))
  186.                                 )
  187.                               )
  188.                             )
  189.                             (setq lwd (vl-remove edg3 lwd))
  190.                             ;(setq lwd (unique lwd))
  191.                           )
  192.                           ( (and
  193.                               (or
  194.                                 (equal (rem (+ (cadr edg3) pi) (+ pi pi)) (rem (+ (cadr edg4) pi pi) (+ pi pi)) 1e-6)
  195.                                 (equal (rem (+ (cadr edg3) pi pi) (+ pi pi)) (rem (+ (cadr edg4) pi) (+ pi pi)) 1e-6)
  196.                               )
  197.                               (equal (car edg1) (car edg3) 1e-6)
  198.                               (equal (car edg2) (car edg4) 1e-6)
  199.                             )
  200.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (caddr edg4)) (vlax-3d-point (car edg3)))
  201.                             (foreach x lwwd
  202.                               (if (not (equal edg4 x 1e-6))
  203.                                 (progn
  204.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (caddr edg4)) (car x)) (car x) x))
  205.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg3) (caddr edg4)) (caddr xx)) (caddr xx) xx))
  206.                                   (setq lwd (cons xx lwd))
  207.                                 )
  208.                               )
  209.                             )
  210.                             (setq lwd (vl-remove edg3 lwd))
  211.                             ;(setq lwd (unique lwd))
  212.                           )
  213.                         )
  214.                         (cond
  215.                           ( (equal (cadr edg1) (cadr edg2) 1e-6)
  216.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (car edg2)) (vlax-3d-point (car edg1)))
  217.                             (foreach x lwwd
  218.                               (if (not (equal edg2 x 1e-6))
  219.                                 (progn
  220.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (car edg2)) (car x)) (car x) x))
  221.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (car edg2)) (caddr xx)) (caddr xx) xx))
  222.                                   (setq lwd (cons xx lwd))
  223.                                 )
  224.                               )
  225.                             )
  226.                             (setq lwd (vl-remove edg1 lwd))
  227.                             ;(setq lwd (unique lwd))
  228.                           )
  229.                           ( (or
  230.                               (equal (rem (+ (cadr edg1) pi) (+ pi pi)) (rem (+ (cadr edg2) pi pi) (+ pi pi)) 1e-6)
  231.                               (equal (rem (+ (cadr edg1) pi pi) (+ pi pi)) (rem (+ (cadr edg2) pi) (+ pi pi)) 1e-6)
  232.                             )
  233.                             (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (caddr edg2)) (vlax-3d-point (car edg1)))
  234.                             (foreach x lwwd
  235.                               (if (not (equal edg2 x 1e-6))
  236.                                 (progn
  237.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (caddr edg2)) (car x)) (car x) x))
  238.                                   (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (caddr edg2)) (caddr xx)) (caddr xx) xx))
  239.                                   (setq lwd (cons xx lwd))
  240.                                 )
  241.                               )
  242.                             )
  243.                             (setq lwd (vl-remove edg1 lwd))
  244.                             ;(setq lwd (unique lwd))
  245.                           )
  246.                         )
  247.                       )
  248.                     )
  249.                   )
  250.                 ))
  251.                 lwwd
  252.               )
  253.             ))
  254.             lwd
  255.           )
  256.         )
  257.       )
  258.       lwd
  259.     )
  260.  
  261.     (foreach lw lws
  262.       (if lw
  263.         (setq lwdd (inspectlw lw))
  264.       )
  265.       (cond
  266.         ( (and
  267.             orth
  268.             (vl-every
  269.               (function (lambda ( w )
  270.                 (or
  271.                   (equal (cadr w) 0.0 1e-6)
  272.                   (equal (cadr w) (* 0.5 pi) 1e-6)
  273.                   (equal (cadr w) pi 1e-6)
  274.                   (equal (cadr w) (* 1.5 pi) 1e-6)
  275.                   (equal (cadr w) (* 2 pi) 1e-6)
  276.                 )
  277.               ))
  278.               lwdd
  279.             )
  280.           )
  281.           (setq lws (vl-remove lw lws) lwso (cons lw lwso))
  282.         )
  283.         ( (and
  284.             (not orth)
  285.             (vl-every
  286.               (function (lambda ( w )
  287.                 (or
  288.                   (equal (cadr w) 0.0 1e-6)
  289.                   (equal (cadr w) (* 0.5 pi) 1e-6)
  290.                   (equal (cadr w) pi 1e-6)
  291.                   (equal (cadr w) (* 1.5 pi) 1e-6)
  292.                   (equal (cadr w) (* 2 pi) 1e-6)
  293.                 )
  294.               ))
  295.               lwdd
  296.             )
  297.           )
  298.           (setq lws (vl-remove lw lws))
  299.         )
  300.       )
  301.     )
  302.     (setq lwd (process lws (length lws) nil orth (not chk)))
  303.     (if orth
  304.       (progn
  305.         (setq lwd (process (list (setq q (car (vl-sort lwso (function (lambda ( a b ) (< (vlax-curve-getarea a) (vlax-curve-getarea b)))))))) 2 lwd orth (not chk)))
  306.         (setq lwds (caddr lwd))
  307.         (setq lwso (vl-remove q lwso))
  308.         (while
  309.           (or
  310.             (setq lwww (vl-some (function (lambda ( z / xx ) (if (and (setq xx (vl-some (function (lambda ( a ) (vl-some (function (lambda ( x ) (if (equal (distance (car a) (caddr a)) (distance (car x) (caddr x)) 1e-6) (list x a)))) (apply (function append) (mapcar (function inspectlw) lws))))) (apply (function append) (mapcar (function inspectlw) lwso)))) (vl-some (function (lambda ( b ) (vl-some (function (lambda ( y ) (and (not (equal b (car xx) 1e-6)) (not (equal b (cadr xx) 1e-6)) (not (equal y (car xx) 1e-6)) (not (equal y (cadr xx) 1e-6)) (equal (distance (car b) (caddr b)) (distance (car y) (caddr y)) 1e-6)))) (apply (function append) (mapcar (function inspectlw) lws))))) (apply (function append) (mapcar (function inspectlw) lwso)))) z))) (mapcar (function inspectlw) lwso)))
  311.             (car lwso)
  312.           )
  313.           (if (cdr lwso)
  314.             (foreach w lwso
  315.               (if (equal (inspectlw w) lwww 1e-6)
  316.                 (progn
  317.                   (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget w))))
  318.                     (setq lwd (process (list w) 2 (cons lwds lwd) orth (not chk)))
  319.                     (setq lwd (process (list w) 2 lwd orth (not chk)))
  320.                   )
  321.                   (setq lwso (vl-remove w lwso))
  322.                 )
  323.               )
  324.             )
  325.             (progn
  326.               (process (list (car lwso)) 2 lwd orth chk)
  327.               (setq lwso nil)
  328.             )
  329.           )
  330.         )
  331.       )
  332.     )
  333.   )
  334.  
  335.   (if (= 8 (logand 8 (getvar (quote undoctl))))
  336.     (if command-s
  337.       (command-s "_.UNDO" "_E")
  338.       (vl-cmdf "_.UNDO" "_E")
  339.     )
  340.   )
  341.   (if command-s
  342.     (command-s "_.UNDO" "_M")
  343.     (vl-cmdf "_.UNDO" "_M")
  344.   )
  345.   (initget "Yes No")
  346.   (setq orth (cond ( (getkword "\nEnable ortho or not [Yes / No] <Yes> : ") ) ( "Yes" ) ))
  347.   (if (= orth "Yes")
  348.     (setq orth t)
  349.     (setq orth nil)
  350.   )
  351.   (initget "Yes No")
  352.   (setq chk (cond ( (getkword "\nChoose check for ortho - if it stals choose \"No\" next time [Yes / No] <Yes> : ") ) ( "Yes" ) ))
  353.   (if (= chk "Yes")
  354.     (setq chk t)
  355.     (setq chk nil)
  356.   )
  357.   (prompt "\nSelect polygons you want CW - orthogonal - right side <ENTER - CONTINUE> : ")
  358.   (if (setq s (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  359.     (foreach lw (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
  360.       (if (not (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  361.         (rlw lw)
  362.       )
  363.     )
  364.   )
  365.   (prompt "\nSelect polygons you want CCW - non orthogonal + upper side orthogonal <ENTER - CONTINUE> : ")
  366.   (if (setq s (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  367.     (foreach lw (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
  368.       (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  369.         (rlw lw)
  370.       )
  371.     )
  372.   )
  373.   (prompt "\nSelect polygonal LWPOLYLINE(s) on unlocked Layer(s)...")
  374.   (if (setq ss (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  375.     (progn
  376.       (repeat (setq i (sslength ss))
  377.         (setq lws (cons (ssname ss (setq i (1- i))) lws))
  378.       )
  379.       (jigsaw lws orth chk)
  380.     )
  381.   )
  382.   (*error* nil)
  383. )
  384.  

M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on April 01, 2023, 10:52:09 AM
I am attaching relevant *.dwg for you to see how it is working... The code was altered many times, but now it's just the way it was thought to be...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:jigsaw-ortho ( / *error* listclockwise-p rlw bb jigsaw s ss i lws lwss orth base cent c lll qqq qqqlr qqqul ddd )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if (= 8 (logand 8 (getvar (quote undoctl))))
  6.       (if command-s
  7.         (command-s "_.UNDO" "_E")
  8.         (vl-cmdf "_.UNDO" "_E")
  9.       )
  10.     )
  11.     (if m
  12.       (prompt m)
  13.     )
  14.     (princ)
  15.   )
  16.  
  17.   (defun listclockwise-p ( lst )
  18.     ;; by Lee Mac
  19.     (minusp
  20.       (apply (function +)
  21.         (mapcar
  22.           (function (lambda ( a b )
  23.             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  24.           ))
  25.           lst
  26.           (cons (last lst) lst)
  27.         )
  28.       )
  29.     )
  30.   )
  31.  
  32.   (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
  33.     ;; by Elpanov Evgeniy
  34.     (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
  35.       (progn
  36.         (foreach a1 e
  37.           (cond
  38.             ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
  39.             ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
  40.             ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
  41.             ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
  42.             ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
  43.             ( t (setq x1 (cons a1 x1)) )
  44.           )
  45.         )
  46.         (entmod
  47.           (append
  48.             (reverse x1)
  49.             (append
  50.               (apply (function append)
  51.                 (apply (function mapcar)
  52.                   (cons (function list)
  53.                     (list
  54.                       x2
  55.                       (cdr (reverse (cons (car x3) (reverse x3))))
  56.                       (cdr (reverse (cons (car x4) (reverse x4))))
  57.                       (cdr (reverse (cons (car x5) (reverse x5))))
  58.                     )
  59.                   )
  60.                 )
  61.               )
  62.               x6
  63.             )
  64.           )
  65.         )
  66.         (entupd lw)
  67.       )
  68.     )
  69.   )
  70.  
  71.   (defun bb ( ptlst )
  72.     (list
  73.       (list (apply (function min) (mapcar (function car) ptlst)) (apply (function min) (mapcar (function cadr) ptlst)))
  74.       (list (apply (function max) (mapcar (function car) ptlst)) (apply (function min) (mapcar (function cadr) ptlst)))
  75.       (list (apply (function max) (mapcar (function car) ptlst)) (apply (function max) (mapcar (function cadr) ptlst)))
  76.       (list (apply (function min) (mapcar (function car) ptlst)) (apply (function max) (mapcar (function cadr) ptlst)))
  77.     )
  78.   )
  79.  
  80.   (defun jigsaw ( lws orth / inspectlw process lw lww lwww lwso lwd lwdd lwwd lwds q )
  81.  
  82.     (defun inspectlw ( lw base / lwx pts p0 angs edgs )
  83.       (setq lwx (entget lw))
  84.       (setq pts (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))
  85.       (setq p0 (car pts))
  86.       (foreach p1 (cdr pts)
  87.         (cond
  88.           ( (= base "ll")
  89.             (if
  90.               (or
  91.                 (< (cadr p1) (cadr p0))
  92.                 (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  93.               )
  94.               (setq p0 p1)
  95.             )
  96.           )
  97.           ( (= base "lr")
  98.             (if
  99.               (or
  100.                 (< (cadr p1) (cadr p0))
  101.                 (and (= (cadr p1) (cadr p0)) (> (car p1) (car p0)))
  102.               )
  103.               (setq p0 p1)
  104.             )
  105.           )
  106.           ( (= base "ur")
  107.             (if
  108.               (or
  109.                 (> (cadr p1) (cadr p0))
  110.                 (and (= (cadr p1) (cadr p0)) (> (car p1) (car p0)))
  111.               )
  112.               (setq p0 p1)
  113.             )
  114.           )
  115.           ( (= base "ul")
  116.             (if
  117.               (or
  118.                 (> (cadr p1) (cadr p0))
  119.                 (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
  120.               )
  121.               (setq p0 p1)
  122.             )
  123.           )
  124.         )
  125.       )
  126.       (setq pts (append (member p0 pts) (reverse (cdr (member p0 (reverse pts))))))
  127.       (setq angs (mapcar (function (lambda ( a b ) (angle a b))) pts (append (cdr pts) (list (car pts)))))
  128.       (setq edgs (mapcar (function (lambda ( p1 a p2 ) (list p1 a p2))) pts angs (append (cdr pts) (list (car pts)))))
  129.     )
  130.  
  131.     (defun process ( lws n lwd )
  132.       (cond
  133.         ( (and (setq lw (if (= c "Yes") cent (if qqq (car qqq) (car lws)))) (not lwd))
  134.           (setq lws (vl-remove lw lws) lwd (inspectlw lw base))
  135.         )
  136.         ( (and lwd (= c "Yes"))
  137.           (setq lll (inspectlw cent base))
  138.           (setq lwd (append (inspectlw (rlw cent) base) (vl-remove-if (function (lambda ( x ) (vl-some (function (lambda ( y ) (equal x y 1e-6))) lll))) lwd)))
  139.         )
  140.       )
  141.       (while (> n 1)
  142.         (foreach lww lws
  143.           (if lww
  144.             (setq lwwd (inspectlw lww base))
  145.           )
  146.           (if ddd
  147.             (setq lwd (append ddd (vl-remove-if (function (lambda ( x ) (vl-some (function (lambda ( y ) (equal x y 1e-6))) ddd))) lwd)))
  148.           )
  149.           (vl-some
  150.             (function (lambda ( edg1 )
  151.               (vl-some
  152.                 (function (lambda ( edg2 )
  153.                   (if
  154.                     (and
  155.                       (equal (distance (car edg1) (caddr edg1)) (distance (car edg2) (caddr edg2)) 1e-6)
  156.                       (or
  157.                         (equal (cadr edg1) (cadr edg2) 1e-6)
  158.                         (equal (rem (+ (cadr edg1) pi) (+ pi pi)) (rem (+ (cadr edg2) pi pi) (+ pi pi)) 1e-6)
  159.                         (equal (rem (+ (cadr edg1) pi pi) (+ pi pi)) (rem (+ (cadr edg2) pi) (+ pi pi)) 1e-6)
  160.                       )
  161.                     )
  162.                     (progn
  163.                       (setq lws (vl-remove lww lws) n (1- n))
  164.                       (cond
  165.                         ( (equal (cadr edg1) (cadr edg2) 1e-6)
  166.                           (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (car edg2)) (vlax-3d-point (car edg1)))
  167.                           (foreach x lwwd
  168.                             (if (not (equal edg2 x 1e-6))
  169.                               (progn
  170.                                 (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (car edg2)) (car x)) (car x) x))
  171.                                 (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (car edg2)) (caddr xx)) (caddr xx) xx))
  172.                                 (setq lwd (cons xx lwd))
  173.                               )
  174.                             )
  175.                           )
  176.                           (setq lwd (vl-remove edg1 lwd))
  177.                         )
  178.                         ( (or
  179.                             (equal (rem (+ (cadr edg1) pi) (+ pi pi)) (rem (+ (cadr edg2) pi pi) (+ pi pi)) 1e-6)
  180.                             (equal (rem (+ (cadr edg1) pi pi) (+ pi pi)) (rem (+ (cadr edg2) pi) (+ pi pi)) 1e-6)
  181.                           )
  182.                           (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (caddr edg2)) (vlax-3d-point (car edg1)))
  183.                           (foreach x lwwd
  184.                             (if (not (equal edg2 x 1e-6))
  185.                               (progn
  186.                                 (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (caddr edg2)) (car x)) (car x) x))
  187.                                 (setq xx (subst (mapcar (function +) (mapcar (function -) (car edg1) (caddr edg2)) (caddr xx)) (caddr xx) xx))
  188.                                 (setq lwd (cons xx lwd))
  189.                               )
  190.                             )
  191.                           )
  192.                           (setq lwd (vl-remove edg1 lwd))
  193.                         )
  194.                       )
  195.                     )
  196.                   )
  197.                 ))
  198.                 lwwd
  199.               )
  200.             ))
  201.             lwd
  202.           )
  203.         )
  204.       )
  205.       lwd
  206.     )
  207.  
  208.     (if (not orth)
  209.       (setq lwd (process lwss (length lwss) nil))
  210.       (progn
  211.         (if (> (length qqq) 1)
  212.           (setq ddd (process qqq (length qqq) nil))
  213.         )
  214.         (setq lwd (process qqqlr (length qqqlr) lwd))
  215.         (setq lwd (process qqqul (length qqqul) lwd))
  216.         (setq lwso (vl-remove-if (function (lambda ( x ) (vl-some (function (lambda ( y ) (eq x y))) (append qqq qqqlr qqqul)))) lwss))
  217.         (setq qqqbb (bb (apply (function append) (mapcar (function (lambda ( q ) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget q))))) (append qqq qqqlr qqqul)))))
  218.         (setq centbb (bb (if (= c "Yes") (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget cent))) (apply (function append) (mapcar (function (lambda ( x ) (mapcar (function cdr) (vl-remove-if (function (lambda ( y ) (/= (car y) 10))) (entget x))))) qqq)))))
  219.         (foreach lw lwso
  220.           (setq lwbb (bb (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  221.           (cond
  222.             ( (equal (distance (car qqqbb) (car centbb)) (distance (car lwbb) (caddr lwbb)) 1e-6)
  223.               (vla-move (vlax-ename->vla-object lw) (vlax-3d-point (caddr lwbb)) (vlax-3d-point (car centbb)))
  224.             )
  225.             ( (equal (distance (cadr qqqbb) (cadr centbb)) (distance (cadr lwbb) (cadddr lwbb)) 1e-6)
  226.               (vla-move (vlax-ename->vla-object lw) (vlax-3d-point (cadddr lwbb)) (vlax-3d-point (cadr centbb)))
  227.             )
  228.             ( (equal (distance (caddr qqqbb) (caddr centbb)) (distance (caddr lwbb) (car lwbb)) 1e-6)
  229.               (vla-move (vlax-ename->vla-object lw) (vlax-3d-point (car lwbb)) (vlax-3d-point (caddr centbb)))
  230.             )
  231.             ( (equal (distance (cadddr qqqbb) (cadddr centbb)) (distance (cadddr lwbb) (cadr lwbb)) 1e-6)
  232.               (vla-move (vlax-ename->vla-object lw) (vlax-3d-point (cadr lwbb)) (vlax-3d-point (cadddr centbb)))
  233.             )
  234.           )
  235.         )
  236.       )
  237.     )
  238.   )
  239.  
  240.   (if (= 8 (logand 8 (getvar (quote undoctl))))
  241.     (if command-s
  242.       (command-s "_.UNDO" "_E")
  243.       (vl-cmdf "_.UNDO" "_E")
  244.     )
  245.   )
  246.   (if command-s
  247.     (command-s "_.UNDO" "_M")
  248.     (vl-cmdf "_.UNDO" "_M")
  249.   )
  250.   (initget "Yes No")
  251.   (setq orth (cond ( (getkword "\nEnable orthogonal shapes for some pieces [Yes / No] <Yes> : ") ) ( "Yes" ) ))
  252.   (if (= orth "Yes")
  253.     (setq orth t)
  254.     (setq orth nil)
  255.   )
  256.   (if orth
  257.     (progn
  258.       (prompt "\nSelect polygons you want CCW - adjacent orthogonal sides (left and up ones) <ENTER - CONTINUE> : ")
  259.       (if (setq s (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  260.         (foreach lw (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
  261.           (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  262.             (rlw lw)
  263.           )
  264.           (setq qqqul (cons lw qqqul))
  265.         )
  266.       )
  267.       (prompt "\nSelect polygons you want CW - adjacent orthogonal sides (right and down ones) <ENTER - CONTINUE> : ")
  268.       (if (setq s (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  269.         (foreach lw (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
  270.           (if (not (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  271.             (rlw lw)
  272.           )
  273.           (setq qqqlr (cons lw qqqlr))
  274.         )
  275.       )
  276.       (initget "Yes No")
  277.       (setq c (cond ( (getkword "\nDo you have central piece, or many central pieces [Yes / No] <Yes> : ") ) ( "Yes" )))
  278.       (if (= c "Yes")
  279.         (progn
  280.           (while (not (setq cent (car (entsel "\nPick central ortho piece..."))))
  281.             (prompt "\nMissed...")
  282.           )
  283.           (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget cent))))
  284.             (rlw cent)
  285.           )
  286.           (setq qqq (cons cent qqq))
  287.         )
  288.         (progn
  289.           (prompt "\nSelect central pieces non orthogonal...")
  290.           (if (setq ss (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  291.             (repeat (setq i (sslength ss))
  292.               (setq lw (ssname ss (setq i (1- i))))
  293.               (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  294.                 (rlw lw)
  295.               )
  296.               (setq qqq (cons lw qqq))
  297.             )
  298.           )
  299.         )
  300.       )
  301.     )
  302.   )
  303.   ;|
  304.   (initget 1 "ll lr ur ul")
  305.   (setq base (getkword "\nChoose basepoint orientation [ll / lr / ur / ul] : "))
  306.   |;
  307.   (setq base "ll")
  308.   (prompt "\nSelect polygonal LWPOLYLINE(s) on unlocked Layer(s)...")
  309.   (if (setq ss (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons -4 "&") (cons 70 1) (cons -4 "<NOT") (cons -4 "<>") (cons 42 0.0) (cons -4 "NOT>"))))
  310.     (progn
  311.       (repeat (setq i (sslength ss))
  312.         (setq lws (cons (ssname ss (setq i (1- i))) lws))
  313.       )
  314.       (setq lwss lws)
  315.       (if (= c "Yes")
  316.         (progn
  317.           (setq lws (vl-remove cent lws))
  318.           (setq lws (cons cent lws))
  319.         )
  320.       )
  321.       (if (not orth)
  322.         (if (or (= base "ll") (= base "lr"))
  323.           (foreach lw lws
  324.             (if (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  325.               (rlw lw)
  326.             )
  327.           )
  328.           (foreach lw lws
  329.             (if (not (listclockwise-p (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  330.               (rlw lw)
  331.             )
  332.           )
  333.         )
  334.       )
  335.       (jigsaw lws orth)
  336.     )
  337.   )
  338.   (*error* nil)
  339. )
  340.  

M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on April 03, 2023, 08:31:47 AM
I think that that's it...
Posted code worked in any case of jigsaw.dwg...
Updated code is here : https://www.theswamp.org/index.php?topic=44783.msg613820#msg613820

Thanks for attention,
M.R.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on April 03, 2023, 05:15:12 PM
Just wanted to show how it's working...
Title: Re: ==={Challenge}=== Broken Pieces
Post by: GDF on April 11, 2023, 07:25:09 AM
==={Challenge 2}=== PENTAMONES Pieces

Fit each of the 12 pieces within a rectangle grid.
Title: Re: ==={Challenge}=== Broken Pieces
Post by: ribarm on April 11, 2023, 11:21:39 AM
You should have posted set up and solutions for each of grids to see weather is it possible to combine pieces...
Here you posted only pieces and grids and further more I suppose that rotation of pieces is unavoidable...

But all in all funny thingy that very much has similarity with tetris game...