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

0 Members and 1 Guest are viewing this topic.

pBe

  • Bull Frog
  • Posts: 377
==={Challenge}=== Broken Pieces
« 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]
..............................
« Last Edit: June 19, 2013, 01:30:54 AM by pBe »

pBe

  • Bull Frog
  • Posts: 377
Re: ==={Challenge}=== Broken Pieces
« Reply #1 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
« Last Edit: June 16, 2013, 04:09:58 AM by pBe »

Lee Mac

  • Seagull
  • Posts: 12390
  • London, England
Re: ==={Challenge}=== Broken Pieces
« Reply #2 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)

pBe

  • Bull Frog
  • Posts: 377
Re: ==={Challenge}=== Broken Pieces
« Reply #3 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  :)
 
 

Lee Mac

  • Seagull
  • Posts: 12390
  • London, England
Re: ==={Challenge}=== Broken Pieces
« Reply #4 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.
« Last Edit: June 16, 2013, 12:42:14 PM by Lee Mac »

pBe

  • Bull Frog
  • Posts: 377
Re: ==={Challenge}=== Broken Pieces
« Reply #5 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

ribarm

  • Water Moccasin
  • Posts: 2367
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #6 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:
« Last Edit: June 20, 2013, 05:57:23 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2367
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #7 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.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2367
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #8 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:
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

pBe

  • Bull Frog
  • Posts: 377
Re: ==={Challenge}=== Broken Pieces
« Reply #9 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

ribarm

  • Water Moccasin
  • Posts: 2367
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #10 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.
« Last Edit: June 20, 2013, 05:58:08 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

pBe

  • Bull Frog
  • Posts: 377
Re: ==={Challenge}=== Broken Pieces
« Reply #11 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
« Last Edit: June 18, 2013, 01:56:23 AM by pBe »

pBe

  • Bull Frog
  • Posts: 377
Re: ==={Challenge}=== Broken Pieces
« Reply #12 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>

ribarm

  • Water Moccasin
  • Posts: 2367
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #13 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.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2367
  • Marko Ribar, architect
Re: ==={Challenge}=== Broken Pieces
« Reply #14 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)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube