Topic: {Challenge}Get same zone boundary index set from the Matrix

[chlh_jd]

Hi Evgeniy , yours test ok in VLIDE .
But mine Encounter problem :

Code: [Select]

'VLIDE hard error ***
Has reached Internal Stack Limit (Analog)  .
Dose while loop take much RAM ?

Code: [Select]

(defun test  (l / f1 f2 y x lst l1 a b c e res ss)
  ;; refer Evgeniy's code
  ;; by GSLS(SS) 2012-9-26
  (defun f1  (a l)
    (cond ((not l) nil)
  ((equal a (caar l))
   (cons 0 (car l)))
  ((equal a (cadar l))
   (cons 1 (car l)))
  (t (f1 a (cdr l)))
  ))
  (defun f2  (l / r p p0 p1)
    (setq r (list (car l))
  l (cdr l))
    (while (cadr l)
      (setq p  (car l)
    p1 (cadr l)
    l  (cdr l)
    p0 (car r))
      (if (not (or (= (car p0) (car p) (car p1))
   (= (cadr p0) (cadr p) (cadr p1))))
(setq r (cons p r))))
    (cons (car l) r))
  (setq y -0.5)
  (mapcar (function (lambda (a b)
      (setq y (1+ y)
    x -1.5)
      (mapcar (function (lambda (a b)
  (setq x (1+ x))
  (if (/= a b)
    (setq lst
   (cons (list (list x y) (list (1+ x) y))
lst))
    )))
      a
      b)))
  l
  (cdr l))
  (setq y -1.5)
  (mapcar (function (lambda (a)
      (setq y (1+ y)
    x -0.5)
      (mapcar (function (lambda (a b)
  (setq x (1+ x))
  (if (/= a b)
    (setq lst
   (cons (list (list x y) (list x (1+ y)))
lst))
    )))
      a
      (cdr a))))
  l
  )
  (gc)
  (while lst
    (setq a   (car lst)
  lst (cdr lst))
    (while (setq b (f1 (car a) lst))
      (setq lst (vl-remove (cdr b) lst)
    a (cons (if (zerop (car b))
(caddr b)
(cadr b))
      a)))
    (setq a (reverse a))
    (while (setq b (f1 (car a) lst))
      (setq lst (vl-remove (cdr b) lst)
    a (cons (if (zerop (car b))
(caddr b)
(cadr b))
      a)))
    (setq a (f2 a))
    (if
      (>
(abs
  (/ (apply (function +)
    (mapcar (function (lambda (x y)
(- (* (car x) (cadr y))
   (* (car y) (cadr x)))))
    (cons (last a) a)
    a))
     2.))
5);_add min_area filter .
       (setq res (cons a res))))
  ;_(setq ss (ssadd))
  (foreach a  res
   ;| (if (setq e (entmakex
  (append
    (list (cons 0 "LWPOLYLINE")
  (cons 100 "AcDbEntity")
  (cons 100 "AcDbPolyline")
  (cons 90 (length a))
  )
    (mapcar (function (lambda (x) (cons 10 x))) a)
    (list (cons 70 0) (cons 62 6))
    )))
      (setq ss (ssadd e ss)))|;
    (entmake
  (append
    (list (cons 0 "LWPOLYLINE")
  (cons 100 "AcDbEntity")
  (cons 100 "AcDbPolyline")
  (cons 90 (length a))
  )
    (mapcar (function (lambda (x) (cons 10 x))) a)
    (list (cons 70 0) (cons 62 6))
    ))
    )
  ;|
  (vl-catch-all-apply
    (function vl-cmdf)
    (list "_.Pedit" "M" ss "" "S" ""))|;
  (princ)
  )


[ElpanovEvgeniy]

I'm sorry, I do not have enough time to find bugs in your code...

[chlh_jd]

You're welcome , I'll rewrite it tomorrow .

[chlh_jd]

Because I recursive call  the function and the function has not export, resulting in a stack overflow .
Hi Evgeniy , how much time you spent  to calculated one time ?
My computer Ram state , use (mem) returns  ... Run for a few minutes and did not get the results , I interrupt it .

Code: [Select]

"; GC calls: " 1361 "; GC run time: " 664471 " ms"
"\nDynamic memory segments statistic:\n"
"PgSz  Used  Free  FMCL  Segs  Type\n"
512  2006    27    25    16  lisp stacks
 256  2917  1929   222    19  bytecode area
4096215129    12     5 14339  CONS memory
  32  2254  1710  1354     2  ::new
4096    85    80    14    11  DM Str
 512     1   126   126     1  undo strings
4096143499    12    12  9565  DMxx memory
 128     4   507   506     1  bstack body
"Segment size: " 65536 ", total used: " 23954 ", free: "1


[ElpanovEvgeniy]

I have a fast enough computer, I did not think a few seconds...

[chlh_jd]

I have a fast enough computer, I did not think a few seconds...

My Computer -----
        CPU : Intel Core i7  920@2.67GHz 3.6 GHz
        RAM : 16.0 GB
        HD : WDC 2TB 7200 Rev / min
        GCard : Nvidia GeForce 9800 (1GB)
I think it's enough fast for PC , yours Server ?
       

[ElpanovEvgeniy]

I think it's enough fast for PC , yours Server ?
       

Yes, I have a very noisy workstation.
I'm worth a lot of programs - different versions and different languages. Autodesk - licensed ADN.
All programs on my vmware virtual machines.

[ElpanovEvgeniy]

If necessary, I can make accurate measurements of run-time...

[chlh_jd]

Yes, I have a very noisy workstation.
I'm worth a lot of programs - different versions and different languages. Autodesk - licensed ADN.
All programs on my vmware virtual machines.

Oh , very envious of you have such a good hardware support .

If necessary, I can make accurate measurements of run-time...

And thank you for help a lot .
I think I must improve it's Algorithm first .

[chlh_jd]

There is no  Algorithm better than Evgeniy used , I think .
So use Evgeniy's function build first version .
Codes See the lsp file post .

[chlh_jd]

To Get BmpList , Can Use following Lisp .
Use Highflybird's programe ImageToDcl.EXE , Can be downloaded here :
http://www.theswamp.org/index.php?action=dlattach;topic=42619.0;attach=23385

Code: [Select]


(defun c:Bmp2Lst
       (/ f1 cObj putpixel name f k s l p0 x0 y0 en0 x y r g b
res a c i i%)
  (defun f1  (r g b / cObj aci)
    ;;Edited From LeeMas's function LM:rgb->aci
    (if
      (and (or cObj
       (setq cObj
      (vla-getInterfaceObject
(vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor."
(substr (getvar 'ACADVER) 1 2))
)
     ))
   (not
     (vl-catch-all-error-p
       (vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
       )
     ))
       (vla-get-ColorIndex cObj)
       )
    )
  (defun putpixel  (x y color)
    (entmakeX
      (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 2)
(cons 43 1.0)
(cons 62 color)
(cons 10 (list x y))
(cons 10 (list (1+ x) y))
)
      )
    )
  ;|
  (setq f (vl-filename-directory (findfile "gsls.mns")))
  (princ "\nPlease use HighFlybird's work ImageToDCL.exe and pixelated the picture .")
  (princ (strcat "\nSave File Path :  " f))
  (startapp "ImageToDCL.exe" "")|;
  (princ "\nPlease use HighFlybird's work ImageToDCL.exe and pixelated the picture .")
  (startapp "ImageToDCL.exe" "")
  ;; ImageToDCL.exe written by HighFlybird
  ;; Download url : http://www.theswamp.org/index.php?action=dlattach;topic=42619.0;attach=23385
  (if (and (setq name (getfiled "Select the Pixel table file to Vector :"
;|(strcat f "\\")|;
""
"txt"
0))
   (setq f (open name "R")))
    (progn
      (while (setq s (read-line f))
(setq k (read s))
(if (and k (= (type k) (quote LIST)) (= (length k) 6))
  (setq l (cons k l))
  ))
      (close f)
      (if l
(progn
  (setq r   (car l)
a   (1+ (car r))
r   (1+ (cadr r))
res nil)
  ;|
(setq p0 (getpoint "\nInsert point ："))
  (and (null p0) (setq p0 (list 0 0)))
  (setq p0 (trans p0 1 0))|;
  (and (null p0) (setq p0 (list 0 0)))
  (setq x0 (car p0))
  (setq y0 (cadr p0))  
  (while l
    (setq pt (car l)
  l  (cdr l)    
  c (/ (apply (function +) (butlast (cddr pt))) 3)
  c (f1 c c c)
  c(cond ((= c 7)
   254)
  ((= c 8)
   252)
  ((= c 9)
   253)
  ((member c (list 18 28 38 49))
   250)
  (t c))
  res (cons c res)))
  (if cObj
    (vlax-release-object cobj))
  (setq res (mapcar (function reverse) (list-comp res r))
l (apply (function mapcar) (cons (function list) (mapcar (function (lambda (x) (mapcar (function (lambda (x) (- x 250) )) x) )) res))))
  ;;Draw Pixmap
  (setq i -1)
  (while res
    (setq b (car res)
  res (cdr res))
    (setq i% -1
  i (1+ i)
  x  (+ x0 i))
    (while b
      (setq c (car b)
    b (cdr b))
      (setq i% (1+ i%)
   y (+ y0 i%))
      (if c
      (entmake
(list
  (cons 0 "LWPOLYLINE")
  (cons 100 "AcDbEntity")
  (cons 100 "AcDbPolyline")
  (cons 90 2)
  (cons 43 1.0)
  (cons 62 c)
  (cons 10 (list x y))
  (cons 10 (list (1+ x) y))
  )
)
      )))  
  (if (setq f (open (strcat (vl-filename-directory name)  "\\Testlst.lsp") "w"))
    (progn
      (write-line "(setq l (list " f)
      (foreach b l
      (write-line (vl-princ-to-string b) f))
      (write-line"))" f)
      (close f)))
  ;;
  (gc)
  ;;Vector Main routine ...
  (princ)
  ;;
  )
(princ "\nReads the the pixel file error, please check whether the file error.")
)
      )
    (princ "\nPixel file not found .")
    )
  (princ)
  )
;;
(defun list-comp (a b / mid rslt)
    (repeat (/ (length a) b)
      (setq mid nil)
      (repeat b
(setq mid (cons (car a) mid)
      a   (cdr a)
)
      )
      (setq rslt (cons (reverse mid) rslt))
    )
  (if a (reverse (cons a rslt))
    (reverse rslt))
  )


[ElpanovEvgeniy]

I think we should try additional algorithm - determine the height changes and only add to the high differential cross section.
0 0 1 2 2 - drop 2 - 0 = 2 add section
0 0 1 1 1 2 2 2 ... smooth drop and not add section...

[chlh_jd]

I think we should try additional algorithm - determine the height changes and only add to the high differential cross section.
0 0 1 2 2 - drop 2 - 0 = 2 add section
0 0 1 1 1 2 2 2 ... smooth drop and not add section...

Agree , I first think use Octree Search Operations , but I am worried that this dealing with matrix list in VLisp will be Inefficient .
Because the list is so large .

[chlh_jd]

In the List which create by Bmp2lst , Value smaller Colour darker .
The vectorization procedure usually priority deal with dark areas .

[ElpanovEvgeniy]

In the List which create by Bmp2lst , Value smaller Colour darker .
The vectorization procedure usually priority deal with dark areas .

I think the most important change is close multiple colors - a big change...