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

[chlh_jd]

Hi, All 
I have a problem , to Get all same elements's zone boundary elements's index code set from the matrix list .
Any of the following forms of two adjacent elements considered Unicom , like 米

Code: [Select]

(( ...  ... ...)
  ...  1 1 1 ...
  ...   1 1 1 ...
  ...   1 1 1 ...))
e.g.

Code: [Select]

((nil 1 1 1 1 nil 0 2 2)
 (nil 1 1 1 1 1 0 nil 2)
 (nil nil 1 1 1 1 1 nil nil)
 (nil nil 0 1 2  3 1 0 nil)
)
fuction to cal (item = 1 )'s zone boundary , the result is ( ((0 1) (1 1) (2 2) (3 3)  (2 4) (2 5) (3 6) (2 6) (1 5) (0 4) (0 3) (0 2)) ...)
Here's item=1 has one zoon just supposed , Function have to cal all zones just like the nil item .

This function is very often encountered (e.g. used in Vector graphics), so I dubbed the "challenge" the beginning of .

[ElpanovEvgeniy]

I could not understand the task ...
publish a simple example with the call and response ...

graphics are welcome ...

[chlh_jd]

I could not understand the task ...
publish a simple example with the call and response ...
graphics are welcome ...

Sorry for my poor English .
Perhaps the function just like the Figure .

Code: [Select]

(setq l ((0 0 0 0 0 0 1 1 1 1 1 1 1 1 1)
  (0 0 0 0 0 1 1 1 1 2 1 1 1 1 1)
  (0 0 0 0 1 1 1 1 1 2 2 2 2 2 2)
  (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
  (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
  (1 1 0 1 1 1 1 1 1 1 2 2 2 2 2)
  (1 1 1 1 0 1 1 1 2 2 2 2 1 1 1)
  (0 1 0 0 0 1 1 1 2 2 1 1 1 1 1)
  (1 1 0 1 1 1 1 1 1 1 1 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 1 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 2 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 1 1 1 2)
  (1 1 1 1 1 1 1 1 2 2 2 2 2 2 2)
  (1 1 1 1 1 1 1 1 1 2 2 2 2 2 1)
  (1 1 1 1 1 1 1 1 1 1 2 2 2 1 1)))
;;Cal same colour zone
(foo l) --->
'(
(2 ((0 0) (1 0) (2 0) (3 0) (4 0) (5 0) (4 1) (3 2) (3 3) (3 4) (2 5) (1 4) (0 4) (0 3) (0 2) (0 1) (0 0))
   ((4 6) (4 7) (2 7) (2 8)))
(1 ((6 0) (7 0) (8 0) (8 1) (8 2) (9 3) (9 4) (9 5) (8 5) (7 6) (7 7) (8 8) (8 9) (8 10) (8 11) (8 12) (8 13)
    (7 14) (8 15) (9 16) (8 16) (7 16) (6 16) (5 16) (4 16) (3 16) (2 16) (1 16) (0 16) (0 15) (0 14) (0 13)
    (0 12) (0 11) (0 10) (0 9) (0 8) (0 7) (0 6) (0 5) (1 5) (1 6) (1 7) (1 8) (1 9) (2 9) (3 8) (4 8) (5 7)
    (5 6) (4 5) (4 4) (4 3) (4 2) (5 1) (6 0))
   ((9 0) (10 0) (11 0) (12 0) (13 0) (14 0) (14 1) (13 1) (12 1) (11 1) (10 1) (9 0))
   ((12 6) (13 6) (14 6) (14 7) (14 8) (14 9) (14 10) (14 11) (14 12) (13 13) (12 13) (11 13) (11 12) (11 11)
   (12 10) (11 9) (10 9) (9 8) (10 7) (11 7) (12 6))
   ((14 15) (14 16) (13 16) (14 15)))
(0 ((9 1) (10 2) (11 2) (12 2) (13 2) (14 2) (14 3) (14 4) (14 5) (13 5) (12 5) (11 6) (10 6) (9 7) (8 7)
  (8 6) (9 6) (10 5) (10 4) (10 3) (9 2) (9 1))
   ((14 14) (14 13) (13 14) (12 14) (10 14) (10 13) (10 12) (10 11) (11 10) (10 10) (9 9) (9 10) (9 11)
    (9 12) (9 13) (8 14) (9 15) (10 16) (12 16) (13 15) (14 14))))


[chlh_jd]

To solve Vector Graphics must add other conditions , however , here we just suppose to cal the same colore zone , If only one small square , see as not can be link to other squares .

[chlh_jd]

I found my English is too poor , I can't explain my right thoughts .
I post the result picture I want .
So the function is to cal the same colore zone's indexs of the colore zone matrix .

[ElpanovEvgeniy]

problem is similar to search geodesic contours...

Code - Auto/Visual Lisp: [Select]

1. (setq l '((0 0 0 0 0 0 1 1 1 1 1 1 1 1 1)
2.           (0 0 0 0 0 1 1 1 1 2 1 1 1 1 1)
3.           (0 0 0 0 1 1 1 1 1 2 2 2 2 2 2)
4.           (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
5.           (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
6.           (1 1 0 1 1 1 1 1 1 1 2 2 2 2 2)
7.           (1 1 1 1 0 1 1 1 2 2 2 2 1 1 1)
8.           (0 1 0 0 0 1 1 1 2 2 1 1 1 1 1)
9.           (1 1 0 1 1 1 1 1 1 1 1 1 1 1 1)
10.           (1 1 1 1 1 1 1 1 1 2 1 1 1 1 1)
11.           (1 1 1 1 1 1 1 1 1 2 2 2 1 1 1)
12.           (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
13.           (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
14.           (1 1 1 1 1 1 1 1 1 2 2 1 1 1 2)
15.           (1 1 1 1 1 1 1 1 2 2 2 2 2 2 2)
16.           (1 1 1 1 1 1 1 1 1 2 2 2 2 2 1)
17.           (1 1 1 1 1 1 1 1 1 1 2 2 2 1 1)
18.          )
19.       x 0
20.       y -1
21. )
22. (mapcar (function (lambda (a b)
23.                     (setq x 0 y (1+ y))
24.                     (mapcar (function (lambda (a b c d)
25.                                         (entmakex (list '(0 . "3DFACE")
26.                                                         '(100 . "AcDbEntity")
27.                                                         '(67 . 0)
28.                                                         '(410 . "Model")
29.                                                         '(100 . "AcDbFace")
30.                                                         (list 10 x y a)
31.                                                         (list 11 (1+ x) y b)
32.                                                         (list 12 (1+ x) (1+ y) d)
33.                                                         (list 13 x (1+ y) c)
34.                                                         '(70 . 0)
35.                                                   )
36.                                         )
37.                                         (setq x (1+ x))
38.                                       )
39.                             )
40.                             a
41.                             (cdr a)
42.                             b
43.                             (cdr b)
44.                     )
45.                   )
46.         )
47.         l
48.         (cdr l)
49. )

[chlh_jd]

problem is similar to search geodesic contours...

Thanks Evgeniy !
Good idea !

[ElpanovEvgeniy]

Code - Auto/Visual Lisp: [Select]

1. (defun eea-geodesic-contours-TheSwamp (l / X Y)
2.   ;; by ElpanovEvgeniy
3.   ;;(eea-geodesic-contours-TheSwamp l)
4.   (defun min-max (a b c) (list (min a b c) (max a b c)))
5.   (defun fix-z (p z) (list (car p) (cadr p) z))
6.   (setq y -1.
7.         l (apply (function append)
8.                  (mapcar (function
9.                            (lambda (a b)
10.                              (setq x -1.
11.                                    y (1+ y)
12.                              )
13.                              (apply (function append)
14.                                     (mapcar (function
15.                                               (lambda (a b c d / z)
16.                                                 ;;(setq a (caar l) b (cadar l) c(caadr l) d(cadadr l))
17.                                                 (setq x (1+ x)
18.                                                       z (/ (+ a b c d) 4.)
19.                                                 )
20.                                                 (list (list (min-max a b z) (list x y a) (list (1+ x) y b) (list (+ x 0.5) (+ y 0.5) z))
21.                                                       (list (min-max a c z) (list x y a) (list x (1+ y) c) (list (+ x 0.5) (+ y 0.5) z))
22.                                                       (list (min-max b d z) (list (1+ x) y b) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
23.                                                       (list (min-max c d z) (list x (1+ y) c) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
24.                                                 )
25.                                               )
26.                                             )
27.                                             a
28.                                             (cdr a)
29.                                             b
30.                                             (cdr b)
31.                                     )
32.                              )
33.                            )
34.                          )
35.                          l
36.                          (cdr l)
37.                  )
38.           )
39.   )
40.   (foreach z '(0.5 1.5 2.5)
41.     (foreach tr l
42.       (if (and (<= (caar tr) z (cadar tr))
43.                (cdr (setq tr (vl-remove nil
44.                                         (list (inters (nth 1 tr) (nth 2 tr) (fix-z (nth 1 tr) z) (fix-z (nth 2 tr) z))
45.                                               (inters (nth 2 tr) (nth 3 tr) (fix-z (nth 2 tr) z) (fix-z (nth 3 tr) z))
46.                                               (inters (nth 1 tr) (nth 3 tr) (fix-z (nth 1 tr) z) (fix-z (nth 3 tr) z))
47.                                         )
48.                              )
49.                     )
50.                )
51.           )
52.         (entmakex (list '(0 . "line") (cons 62 (fix (* z 10))) (cons 10 (car tr)) (cons 11 (cadr tr))))
53.       )
54.     )
55.   )
56.   (princ)
57. )

Code: [Select]

(setq l '((0 0 0 0 0 0 1 1 1 1 1 1 1 1 1)
          (0 0 0 0 0 1 1 1 1 2 1 1 1 1 1)
          (0 0 0 0 1 1 1 1 1 2 2 2 2 2 2)
          (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
          (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
          (1 1 0 1 1 1 1 1 1 1 2 2 2 2 2)
          (1 1 1 1 0 1 1 1 2 2 2 2 1 1 1)
          (0 1 0 0 0 1 1 1 2 2 1 1 1 1 1)
          (1 1 0 1 1 1 1 1 1 1 1 1 1 1 1)
          (1 1 1 1 1 1 1 1 1 2 1 1 1 1 1)
          (1 1 1 1 1 1 1 1 1 2 2 2 1 1 1)
          (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
          (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
          (1 1 1 1 1 1 1 1 1 2 2 1 1 1 2)
          (1 1 1 1 1 1 1 1 2 2 2 2 2 2 2)
          (1 1 1 1 1 1 1 1 1 2 2 2 2 2 1)
          (1 1 1 1 1 1 1 1 1 1 2 2 2 1 1)
         )
      )
(eea-geodesic-contours-TheSwamp l)


[ElpanovEvgeniy]

small addition to supplementary contours ... 

Code - Auto/Visual Lisp: [Select]

1. (defun eea-geodesic-contours-TheSwamp (l lst-z / X Y)
2.   ;; by ElpanovEvgeniy
3.   ;;(eea-geodesic-contours-TheSwamp l '(0.5 1.5))
4.   (defun min-max (a b c) (list (min a b c) (max a b c)))
5.   (defun fix-z (p z) (list (car p) (cadr p) z))
6.   (setq y -1.
7.         l (apply (function append)
8.                  (mapcar (function
9.                            (lambda (a b)
10.                              (setq x -1.
11.                                    y (1+ y)
12.                              )
13.                              (apply (function append)
14.                                     (mapcar (function
15.                                               (lambda (a b c d / z)
16.                                                 ;;(setq a (caar l) b (cadar l) c(caadr l) d(cadadr l))
17.                                                 (setq x (1+ x)
18.                                                       z (/ (+ a b c d) 4.)
19.                                                 )
20.                                                 (list (list (min-max a b z) (list x y a) (list (1+ x) y b) (list (+ x 0.5) (+ y 0.5) z))
21.                                                       (list (min-max a c z) (list x y a) (list x (1+ y) c) (list (+ x 0.5) (+ y 0.5) z))
22.                                                       (list (min-max b d z) (list (1+ x) y b) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
23.                                                       (list (min-max c d z) (list x (1+ y) c) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
24.                                                 )
25.                                               )
26.                                             )
27.                                             a
28.                                             (cdr a)
29.                                             b
30.                                             (cdr b)
31.                                     )
32.                              )
33.                            )
34.                          )
35.                          l
36.                          (cdr l)
37.                  )
38.           )
39.   )
40.   (foreach z lst-z
41.     (foreach tr l
42.       (if (and (<= (caar tr) z (cadar tr))
43.                (cdr (setq tr (vl-remove nil
44.                                         (list (inters (nth 1 tr) (nth 2 tr) (fix-z (nth 1 tr) z) (fix-z (nth 2 tr) z))
45.                                               (inters (nth 2 tr) (nth 3 tr) (fix-z (nth 2 tr) z) (fix-z (nth 3 tr) z))
46.                                               (inters (nth 1 tr) (nth 3 tr) (fix-z (nth 1 tr) z) (fix-z (nth 3 tr) z))
47.                                         )
48.                              )
49.                     )
50.                )
51.           )
52.         (entmakex (list '(0 . "line") (cons 62 (fix (* z 10))) (cons 10 (car tr)) (cons 11 (cadr tr))))
53.       )
54.     )
55.   )
56.   (princ)
57. )

Code: [Select]

(eea-geodesic-contours-TheSwamp l '(0.1 0.3 0.5 0.7 0.9 1.1 1.3 1.5 1.7 1.9))

[dgorsman]

There's probably some good information on edge detection in the image processing field that would be directly applicable.

[chlh_jd]

Evgeniy's allways excellent ! 
I have to spend a lot of time to understand your implementation ideas and source code .

[ElpanovEvgeniy]

added display of all triangles - will now be more clear, the algorithm of the program...

Code - Auto/Visual Lisp: [Select]

1. (eea-geodesic-contours-TheSwamp l '(0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 1.1 1.2 1.3 1.4 1.5 1.6 1.7 1.8 1.9 2.0))

Code - Auto/Visual Lisp: [Select]

1. (defun eea-geodesic-contours-TheSwamp (l lst-z / X Y)
2.   ;; by ElpanovEvgeniy
3.   ;;(eea-geodesic-contours-TheSwamp l '(0.5 1.5))
4.   ;; last edit 26.09.2012
5.   (defun min-max (a b c) (list (min a b c) (max a b c)))
6.   (defun fix-z (p z) (list (car p) (cadr p) z))
7.   (setq y -1.
8.         l (apply (function append)
9.                  (mapcar (function
10.                            (lambda (a b)
11.                              (setq x -1.
12.                                    y (1+ y)
13.                              )
14.                              (apply (function append)
15.                                     (mapcar (function
16.                                               (lambda (a b c d / z)
17.                                                 (setq x (1+ x)
18.                                                       z (/ (+ a b c d) 4.)
19.                                                 )
20.                                                 (list (list (min-max a b z) (list x y a) (list (1+ x) y b) (list (+ x 0.5) (+ y 0.5) z))
21.                                                       (list (min-max a c z) (list x y a) (list x (1+ y) c) (list (+ x 0.5) (+ y 0.5) z))
22.                                                       (list (min-max b d z) (list (1+ x) y b) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
23.                                                       (list (min-max c d z) (list x (1+ y) c) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
24.                                                 )
25.                                               )
26.                                             )
27.                                             a
28.                                             (cdr a)
29.                                             b
30.                                             (cdr b)
31.                                     )
32.                              )
33.                            )
34.                          )
35.                          l
36.                          (cdr l)
37.                  )
38.           )
39.   )
40.   (foreach tr l
41.     (entmakex (list '(0 . "3DFACE")
42.                     '(100 . "AcDbEntity")
43.                     '(62 . 251)
44.                     '(67 . 0)
45.                     '(410 . "Model")
46.                     '(100 . "AcDbFace")
47.                     (cons 10 (cadr tr))
48.                     (cons 11 (caddr tr))
49.                     (cons 12 (cadddr tr))
50.                     (cons 13 (cadddr tr))
51.                     '(70 . 0)
52.               )
53.     )
54.   )
55.   (foreach z lst-z
56.     (foreach tr l
57.       (if (and (<= (caar tr) z (cadar tr))
58.                (cdr (setq tr (vl-remove nil
59.                                         (list (inters (nth 1 tr) (nth 2 tr) (fix-z (nth 1 tr) z) (fix-z (nth 2 tr) z))
60.                                               (inters (nth 2 tr) (nth 3 tr) (fix-z (nth 2 tr) z) (fix-z (nth 3 tr) z))
61.                                               (inters (nth 1 tr) (nth 3 tr) (fix-z (nth 1 tr) z) (fix-z (nth 3 tr) z))
62.                                         )
63.                              )
64.                     )
65.                )
66.           )
67.         (entmakex (list '(0 . "line")
68.                         (cons 62 (atoi (rtos (* (- 2. z) 100) 2 0)))
69.                         (cons 10 (car tr))
70.                         (cons 11 (cadr tr))
71.                   )
72.         )
73.       )
74.     )
75.   )
76.   (princ)
77. )

[chlh_jd]

So woderful for Height contours , Evgeniy.
After learn your codes , I write my first codes .

Code: [Select]

(setq l '((0 0 0 0 0 0 1 1 1 1 1 1 1 1 1)
  (0 0 0 0 0 1 1 1 1 2 1 1 1 1 1)
  (0 0 0 0 1 1 1 1 1 2 2 2 2 2 2)
  (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
  (0 0 0 0 1 1 1 1 1 1 2 2 2 2 2)
  (1 1 0 1 1 1 1 1 1 1 2 2 2 2 2)
  (1 1 1 1 0 1 1 1 2 2 2 2 1 1 1)
  (0 1 0 0 0 1 1 1 2 2 1 1 1 1 1)
  (1 1 0 1 1 1 1 1 1 1 1 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 1 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 2 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 1 1 1 1)
  (1 1 1 1 1 1 1 1 1 2 2 1 1 1 2)
  (1 1 1 1 1 1 1 1 2 2 2 2 2 2 2)
  (1 1 1 1 1 1 1 1 1 2 2 2 2 2 1)
  (1 1 1 1 1 1 1 1 1 1 2 2 2 1 1)))
(defun test  (l / f1 f2 y x lst l1 a b c e res ss)
  (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
  )
  ;|
  (setq lst (vl-sort lst (function (lambda (a b)
     (if (equal (car a) (car b))
       (< (cadadr a) (cadadr b))
       (if (equal (cadar a) (cadar b))
(< (caar a) (caar b))
(< (cadar a) (cadar b))))))
     ))  |;
  (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))
    (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))))
  (vl-catch-all-apply
    (function vl-cmdf)
    (list "_.Pedit" "M" ss "" "S" ""))
  (princ)
  )
Use Test fun : (Test l) ---->

[chlh_jd]

Try this List in Testlst.lsp , I don't get the result .

[ElpanovEvgeniy]

Code - Auto/Visual Lisp: [Select]

1. (eea-geodesic-contours-TheSwamp l '(0.25 0.5 0.75 1.0 1.25 1.5 1.75 2.0 2.25 2.5 2.75 3.0))
2. (defun eea-geodesic-contours-TheSwamp (l lst-z / X Y)
3.   ;; by ElpanovEvgeniy
4.   ;;(eea-geodesic-contours-TheSwamp l '(0.5 1.5 2.5))
5.   ;; last edit 26.09.2012
6.   (defun min-max (a b c) (list (min a b c) (max a b c)))
7.   (defun fix-z (p z) (list (car p) (cadr p) z))
8.   (setq y -1.
9.         l (apply (function append)
10.                  (mapcar (function
11.                            (lambda (a b)
12.                              (setq x -1.
13.                                    y (1+ y)
14.                              )
15.                              (apply (function append)
16.                                     (mapcar (function
17.                                               (lambda (a b c d / z)
18.                                                 (setq x (1+ x)
19.                                                       z (/ (+ a b c d) 4.)
20.                                                 )
21.                                                 (list (list (min-max a b z) (list x y a) (list (1+ x) y b) (list (+ x 0.5) (+ y 0.5) z))
22.                                                       (list (min-max a c z) (list x y a) (list x (1+ y) c) (list (+ x 0.5) (+ y 0.5) z))
23.                                                       (list (min-max b d z) (list (1+ x) y b) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
24.                                                       (list (min-max c d z) (list x (1+ y) c) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
25.                                                 )
26.                                               )
27.                                             )
28.                                             a
29.                                             (cdr a)
30.                                             b
31.                                             (cdr b)
32.                                     )
33.                              )
34.                            )
35.                          )
36.                          l
37.                          (cdr l)
38.                  )
39.           )
40.   )
41. ;;;  (foreach tr l
42. ;;;    (entmakex (list '(0 . "3DFACE")
43. ;;;                    '(100 . "AcDbEntity")
44. ;;;                    '(62 . 251)
45. ;;;                    '(67 . 0)
46. ;;;                    '(410 . "Model")
47. ;;;                    '(100 . "AcDbFace")
48. ;;;                    (cons 10 (cadr tr))
49. ;;;                    (cons 11 (caddr tr))
50. ;;;                    (cons 12 (cadddr tr))
51. ;;;                    (cons 13 (cadddr tr))
52. ;;;                    '(70 . 0)
53. ;;;              )
54. ;;;    )
55. ;;;  )
56.   (foreach z lst-z
57.     ;;(setq z 2.5)
58.     (foreach tr l
59.       (if (and (<= (caar tr) z (cadar tr))
60.                (cdr (setq tr (vl-remove nil
61.                                         (list (inters (nth 1 tr) (nth 2 tr) (fix-z (nth 1 tr) z) (fix-z (nth 2 tr) z))
62.                                               (inters (nth 2 tr) (nth 3 tr) (fix-z (nth 2 tr) z) (fix-z (nth 3 tr) z))
63.                                               (inters (nth 1 tr) (nth 3 tr) (fix-z (nth 1 tr) z) (fix-z (nth 3 tr) z))
64.                                         )
65.                              )
66.                     )
67.                )
68.           )
69.         (entmakex (list '(0 . "line")
70.                         (cons 8 (rtos z 2 1))
71.                         (cons 10 (car tr))
72.                         (cons 11 (cadr tr))
73.                   )
74.         )
75.       )
76.     )
77.   )
78.   (princ)
79. )

[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...

[ElpanovEvgeniy]

strange that this topic no one else is reading... 

[chlh_jd]

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...

Agree , I've Cold two days, tomorrow continue to modify .
Thank you a lot .

strange that this topic no one else is reading... 

I've search all the swamp , Little helps .
Perhaps this time all busy  In China , we are celebrating the National Day and Mid-Autumn Festival .
Or I put a wrong title .

[CAB]

strange that this topic no one else is reading... 

I'm reading but too busy to participate.
Nice work, maybe next week I'll have some free time.

[dgorsman]

The test image is a little... questionable... for work.   

[chlh_jd]

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

Before translate Bmp RGB List into Gray Matrix :

Code: [Select]

     Set background RBG colours  ----> Filter RGB  List  ----> Set forward colours ---->Merge nearly color
     Then go to the step you suggest , drop or add setion .

Is this way better ?
 

[chlh_jd]

Hi all , I've change all codes which easy to test . See the Vector4.lsp

Code: [Select]

(princ "T Bmp2lst CmdGroup : \n
          T1----Create Bmp from the Imagelist's txt file , Insert basepoint '(0 0) .
          T2----Delete Not Want , you also can use the Erase Command .
          T3----Set Background or BackWard Colors
          T4----Set Forward Colors
          T5----Translate Bmp to Gray Matrix .
          T6----Create Component Lines from GrayMatrix .
          T7----Deal Component Lines (Its core is like Pedit Command Spline deal),
                before do it you also can use AutoCAD other Command deal such as Erase/Strentch/Move .
          This CmdGroup will create 3 System Varialbes :
              *Vector_GrayMatrix*
              *Vector_file_path*
              *Vector_Backward_Colors*
              *Vector_Forward_Colors*
              *Vector_Bmp_X*
              *Vector_Bmp_Y*
          ****Warnning****:   
          ****Please Test in New dwg and not open other dwgs , Because it may take Fatal error then
              cause the AutoCAD collapse or interrupt exit****   
          ")


[chlh_jd]

I am sorry , The Vecto_tmp.txt file's Coordinates are not the routine want , It must be  tansposed , Perhaps my dear HighFlyBird  think the image_list must be rebuild .
To Test on the dwg , I change T5 command .

Code: [Select]

(defun c:t5(/ ss x y)   
  (princ (strcat "\nCurrent forward colors table is :" (vl-princ-to-string *Vector_Forward_Colors*) "."))
  (princ (strcat "\nCurrent backward colors table is :" (vl-princ-to-string *Vector_Backward_Colors*) "."))
  (or *Vector_Bmp_X* (setq *Vector_Bmp_X* 287));_Just for Test
  (or *Vector_Bmp_Y* (setq *Vector_Bmp_Y* 427));_Just for Test
  (setq ss (ssget "X" (list (cons 0 "LWPOLYLINE") (cons 8 "Image2PL")
(cons -4 "<AND") (cons -4 ">=") (cons 10 (list -1 -1)) (cons -4 "<=") (cons 10 (list (1+ *Vector_Bmp_X*) (1+ *Vector_Bmp_Y*))) (cons -4 "AND>"))))
  (if ss
    (progn
      (setq *Vector_GrayMatrix* ([0] (1+ (fix *Vector_Bmp_Y*)) (1+ (fix *Vector_Bmp_X*))))
      (ssapply ss (lambda (en / ent c p)
    (setq ent (entget en)  
  c (dxf 420 ent)
  p (dxf 10 ent))
    (if (and c (not (member c *Vector_Backward_Colors*)))
      (progn
(if (member c *Vector_Forward_Colors*)
   (setq c 6)
   (setq c (vector:True->grayaci c)
c (- 255 c))
  )
(setq *Vector_GrayMatrix* (ch-lst c (list (fix (cadr p))(fix (car p))) *Vector_GrayMatrix*)))
      )
    )
       )
      )
    (princ "\nPlease Select Bmp_PLs based on (0 0) , Don't Select the refer objects !")
  )
  (if *gsls_debug*
    (progn
  (setq y -1.)
  (foreach a *Vector_GrayMatrix*
    (setq x -1.
      y (1+ y)
      )
    (foreach b a
      (setq x (1+ x))
      (if (/= b 0)
      (entupd (entmakex
(list
  (cons 0 "LWPOLYLINE")
  (cons 100 "AcDbEntity")
  (cons 100 "AcDbPolyline")
  (cons 90 2)
  (cons 43 1.0)
  (cons 8 "GrayBmp")
  (cons 62 (min (max 0 (fix (- 255 b))) 255))
  (cons 10 (list x y))
  (cons 10 (list (1+ x) y))
  )
))
      )))
  ))
  (princ)
  )
To deal some better , I change the T7 command

Code: [Select]

(defun c:t7 (/ f1 f2 tor ss)
  (defun f1  (en / ent l Noclosed ps pe e)
    (setq ent    (entget en)
  l    (ss-assoc 10 ent)
  Noclosed (zerop (rem (dxf 70 ent) 2)))
    (repeat 8
      (setq ps (car l)
    pe (last l))
      (setq l (mapcar (function (lambda (a b)
  (midpt a b)))
      l
      (cdr l)))
      (if Noclosed
(setq l (append (cons ps l) (list pe)))
(setq l (cons (midpt ps pe) l))))
    (setq e (entmakex
      (append
(list (cons 0 "LWPOLYLINE")
      (cons 100 "AcDbEntity")
      (cons 100 "AcDbPolyline")
      (cons 90 (length l))
      (assoc 8 ent)
      (assoc 70 ent)
      )
(mapcar (function (lambda (x) (cons 10 x))) l)
)
      ))
    (if (< (vla-get-length (vlax-ename->vla-object e)) 8)
      (entdel e))
    (entdel en)
    (princ)
    )
  (defun f2  (en / ent l l0 ps pe e Noclosed)
    (setq ent    (entget en)
  l    (ss-assoc 10 ent)
  Noclosed (zerop (rem (dxf 70 ent) 2)))
    (setq ps (car l)
  pe (last l)
  l  (cdr l)
  l0 (list ps))
    (while l
      (if (> (distance ps (car l)) 1)
(setq l0 (cons (car l) l0)
      ps (car l0)))
      (setq l (cdr l)))
    (if (and l0 (> (distance pe (car l0)) 1))
      (setq l (cons pe l0))
      (setq l l0)
      )
    (setq l0 (list (car l))
  l  (cdr l))
    (if (not Noclosed)
      (setq l (append l l0)))
    (while (cadr l)
      (setq a (car l0)
    b (car l)
    c (cadr l)
    l (cdr l))
      (if (not (equal (abs (- (angle b a) (angle b c))) pi tor))
(setq l0 (cons b l0)))
      )
    (setq l l0)
    (if l
      (progn
(setq
  e (entmakex
      (append
(list (cons 0 "LWPOLYLINE")
      (cons 100 "AcDbEntity")
      (cons 100 "AcDbPolyline")
      (cons 90 (length l))
      (assoc 8 ent)
      (assoc 70 ent)
      )
(mapcar (function (lambda (x) (cons 10 x))) l)
)
      ))
(if (< (vla-get-length (vlax-ename->vla-object e)) 8)
  (entdel e))))
    (entdel en)
    (princ)
    ) 
  ;;
  (while (or (not tor) (> tor 2e-1))
    (initget 4)
    (setq tor (getreal "\nType in a radian for Rarefying polylines [0.01~0.2]<0.08>:"))
    (or tor (setq tor 0.08)))
  (foreach z (list 6 5 4 3 2 1);_This ...
    (setq ss (ssget "X" (list (cons 0 "LINE") (cons 8 (rtos z 2 1)))))
    (command "_.pedit" "m" ss "" "Y" "J" "2." "");_Only Test in ACAD2011 , Other Vesion you must edited by yourself .
    (setq ss (ssget "X" (list (cons 0 "LWPOLYLINE") (cons 8 (rtos z 2 1))
      (cons -4 "<AND") (cons -4 ">=") (cons 10 (list -1 -1))
      (cons -4 "<=") (cons 10 (list (1+ *Vector_Bmp_X*) (1+ *Vector_Bmp_Y*)))
      (cons -4 "AND>"))))
    (if ss
      (ssapply ss f1))
    (setq ss (ssget "X" (list (cons 0 "LWPOLYLINE") (cons 8 (rtos z 2 1))
      (cons -4 "<AND") (cons -4 ">=") (cons 10 (list -1 -1))
      (cons -4 "<=") (cons 10 (list (1+ *Vector_Bmp_X*) (1+ *Vector_Bmp_Y*)))
      (cons -4 "AND>"))))
    (if ss
      (ssapply ss f2))
    )
  (princ "\nBitmap transfer vector has been completed .")
  (princ "\nAny Suggest you can post on : http://www.theswamp.org/index.php?topic=42846.0 ")
  (princ)
  )


[chlh_jd]

New Version change some
 1. vector:True->grayaci
 2. use depth 4.5 3.5 2.5 1.5
 

[chlh_jd]

Brain broken , Need more help 
Pherhaps more about Vector Algorithm , Some date later try to write Evgeniy's Big change .

[ElpanovEvgeniy]

Brain broken , Need more help 
Pherhaps more about Vector Algorithm , Some date later try to write Evgeniy's Big change .

I'm sorry!
I find it hard to spend a lot of time on this research.
Probably the right approach - finding the most intense (curved) space.

[qjchen]

strange that this topic no one else is reading... 

To chlh_jd, it is a very interesting topic~

To Evgeniy, I am reading

Your method is very good, to change them into elevation and then you can get the result, very clever.

Last time, I also thinking in this program, but I think it is too hard for me.

There are two topics about BMP 2 CAD

Daniel: http://www.theswamp.org/index.php?topic=22296.0
qjchen: http://www.theswamp.org/index.php?topic=28071.msg336615#msg336615

I think it can be converted into vector.

Now you have given us the direction, so maybe when I have time, I will try to test it in .NET.

Oh, Last time I draw some 3dmesh in  http://www.theswamp.org/index.php?topic=41630.msg467499#msg467499

and Seant tell me some cool things about NURBS, http://www.theswamp.org/index.php?topic=36560.0

He have done the similar and cool works.

[chlh_jd]

I'm sorry!
I find it hard to spend a lot of time on this research.
Probably the right approach - finding the most intense (curved) space.

Not at all , You are always welcome !

To chlh_jd, it is a very interesting topic~
...

Key of times , you are always present  ,  Very learned !

Thank you a lot Evgeniy , QJChen .

[chlh_jd]

Some soft Vector result , It seem that no better than we do 
Can we go on next step : deal the result from command T7 ...
Perhaps : Evgeniy said "finding the most intense (curved) space."

[chlh_jd]

New version , it seems improve little .
Now, I believe , if continue , the result is at hand .
When I got the result , I'll post the codes in this topic , but when can not be determined .
Has been too much off-topic ,  a lot of thank you Evgeniy , thank you again .

[ElpanovEvgeniy]

Code - Auto/Visual Lisp: [Select]

1. (eea-geodesic-contours-TheSwamp l '(1.33 2.66))
2. (defun eea-geodesic-contours-TheSwamp (l lst-z / X Y)
3.   ;; by ElpanovEvgeniy
4.   ;;(eea-geodesic-contours-TheSwamp l '(0.5 1.5 2.5))
5.   ;; last edit 26.09.2012
6.   ;; last edit 05.10.2012
7.   (defun min-max (a b c) (list (min a b c) (max a b c)))
8.   (defun fix-z (p z) (list (car p) (cadr p) z))
9.   (setq y -1.
10.         l (apply (function append)
11.                  (mapcar (function
12.                            (lambda (a b)
13.                              (setq x -1.
14.                                    y (1+ y)
15.                              )
16.                              (apply (function append)
17.                                     (mapcar (function
18.                                               (lambda (a b c d / z)
19.                                                 (setq x (1+ x)
20.                                                       z (/ (+ a b c d) 4.)
21.                                                 )
22.                                                 (list (list (min-max a b z) (list x y a) (list (1+ x) y b) (list (+ x 0.5) (+ y 0.5) z))
23.                                                       (list (min-max a c z) (list x y a) (list x (1+ y) c) (list (+ x 0.5) (+ y 0.5) z))
24.                                                       (list (min-max b d z) (list (1+ x) y b) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
25.                                                       (list (min-max c d z) (list x (1+ y) c) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
26.                                                 )
27.                                               )
28.                                             )
29.                                             a
30.                                             (cdr a)
31.                                             b
32.                                             (cdr b)
33.                                     )
34.                              )
35.                            )
36.                          )
37.                          l
38.                          (cdr l)
39.                  )
40.           )
41.   )
42.   (foreach z lst-z
43.     (foreach tr l
44.       (if (and (<= (caar tr) z (cadar tr))
45.                (< 1 (-(cadar tr)(caar tr)))
46.                (cdr (setq tr (vl-remove nil
47.                                         (list (inters (nth 1 tr) (nth 2 tr) (fix-z (nth 1 tr) z) (fix-z (nth 2 tr) z))
48.                                               (inters (nth 2 tr) (nth 3 tr) (fix-z (nth 2 tr) z) (fix-z (nth 3 tr) z))
49.                                               (inters (nth 1 tr) (nth 3 tr) (fix-z (nth 1 tr) z) (fix-z (nth 3 tr) z))
50.                                         )
51.                              )
52.                     )
53.                )
54.           )
55.         (entmakex (list '(0 . "line")
56.                         (cons 8 (rtos z 2 1))
57.                         (cons 10 (car tr))
58.                         (cons 11 (cadr tr))
59.                   )
60.         )
61.       )
62.     )
63.   )
64.   (princ)
65. )

[ElpanovEvgeniy]

last version:

[ElpanovEvgeniy]

played a lot with a picture - an interesting program...
code for last version:

Code - Auto/Visual Lisp: [Select]

1. (eea-geodesic-contours-TheSwamp l '(0.5 1.5 2.5 3.5))
2.  
3. (defun eea-geodesic-contours-TheSwamp (l lst-z / X Y)
4.   ;; by ElpanovEvgeniy
5.   ;;(eea-geodesic-contours-TheSwamp l '(0.5 1.5 2.5))
6.   ;; last edit 26.09.2012
7.   ;; last edit 05.10.2012
8.   (defun min-max (a b c) (list (min a b c) (max a b c)))
9.   (defun fix-z (p z) (list (car p) (cadr p) z))
10.   (setq l (mapcar (function
11.                     (lambda (a b) (mapcar (function (lambda (a b c d)
12.                                                       (/ (+ a b c d) 4.)
13. ;;;                                                     (sqrt (sqrt (* a b c d)))
14.                                                       )) a (cdr a) b (cdr b)))
15.                   )
16.                   l
17.                   (cdr l)
18.           )
19.         y -1.
20.         l (apply (function append)
21.                  (mapcar (function
22.                            (lambda (a b)
23.                              (setq x -1.
24.                                    y (1+ y)
25.                              )
26.                              (apply (function append)
27.                                     (mapcar (function
28.                                               (lambda (a b c d / z)
29.                                                 (setq x (1+ x)
30.                                                       z (sqrt (sqrt (* a b c d)))
31. ;;;                                                      z (/ (+ a b c d) 4.)
32.                                                 )
33.                                                 (list (list (min-max a b z) (list x y a) (list (1+ x) y b) (list (+ x 0.5) (+ y 0.5) z))
34.                                                       (list (min-max a c z) (list x y a) (list x (1+ y) c) (list (+ x 0.5) (+ y 0.5) z))
35.                                                       (list (min-max b d z) (list (1+ x) y b) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
36.                                                       (list (min-max c d z) (list x (1+ y) c) (list (1+ x) (1+ y) d) (list (+ x 0.5) (+ y 0.5) z))
37.                                                 )
38.                                               )
39.                                             )
40.                                             a
41.                                             (cdr a)
42.                                             b
43.                                             (cdr b)
44.                                     )
45.                              )
46.                            )
47.                          )
48.                          l
49.                          (cdr l)
50.                  )
51.           )
52.   )
53.   (foreach tr l
54.       (if (and
55.                (< 0.9 (-(cadar tr)(caar tr)))
56.                (setq z (/(+ (caar tr)(cadar tr))2.))
57.                (cdr (setq tr (vl-remove nil
58.                                         (list (inters (nth 1 tr) (nth 2 tr) (fix-z (nth 1 tr) z) (fix-z (nth 2 tr) z))
59.                                               (inters (nth 2 tr) (nth 3 tr) (fix-z (nth 2 tr) z) (fix-z (nth 3 tr) z))
60.                                               (inters (nth 1 tr) (nth 3 tr) (fix-z (nth 1 tr) z) (fix-z (nth 3 tr) z))
61.                                         )
62.                              )
63.                     )
64.                )
65.           )
66.         (entmakex (list '(0 . "line")
67.                         (cons 8 (rtos z 2 1))
68.                        (cons 10 (car tr))
69.                        (cons 11 (cadr tr))
70.                   )
71.         )
72.       )
73.     )
74.   (princ)
75. )

[chlh_jd]

played a lot with a picture - an interesting program...
code for last version:
...

Thanks Evgeniy .
These days , I serach Vector Pic in the NET once more , Seems that high-quality vector softwares ( Adobe Illustrator CS6 , CorelDraw , AutoDesk Raster Design ...) has constructed a series of material library (Human, landscape, object library ...) , They can quickly match the material and make more real vectorization . Because we can't write these to  do it , so yours result is good enough for me .

[chlh_jd]

Someone do a comparison :

1, Acme.TraceART.v3.5
 (Brief: Acme TraceART professionals quickly converting raster to vector format function; can convert a variety of engineering blueprint includes architectural, mechanical, geological, GIS, electronic, etc.)
 2, Algolabs.Raster.to.Vector.Conversion.Toolkit.v2.73
 (Short Description: This software can be a variety of technical drawings, picture by lines from raster format converted to vector format)
 3, Autodesk CAD Overlay 2002
 (Brief: Autocad vector software support tracking, etc.)
 4, AUTODESK RASTER DESIGN 2005
 (Brief: a new name, new features, new possibilities! Autodesk Raster Design software is the next generation of products of the former Autodesk CAD Overlay. Changed its name to better describe its application name, and it included in the Autodesk product line of digital design data. compared with CAD Overlay AutodeskRasterDesign
 There are a lot of new features to improve the efficiency of your work, and can help you take full advantage of the graphics, maps and photographs of the scan)
 5, BENTLEY IRAS-B v8.1.2
 (Short Description: vectorization tools)
 6, BENTLEY.Descartes.v8.05
 (Brief: Cartography, visualization solutions as well as professional graphics vectorization)
 7, BENTLEY.Iras-B.v8.2004.Edition
 (Brief: microstation company produced powerful scanning drawings vectorization software management, editing, conversion for scanned drawings to vector.)
 8, CASSCAN 5.0 small proportion Edition
 (Brief: is the Southern Company scan vector the soft CASSCAN40 the upgrade products CASSCAN50 compared with version 4.0, completely abandoned OverlayR14 of of platform, and CADR14 platform upgrade to CAD2000/2002, increase overall rectangular surface features extract digital intelligent identification and other powerful features; addition to using popular CAD2000/2002 platform, the same time followed of the of Southern terrain cadastral mapping software CASS50 essence of, friendly interface, clear processes; fast image processing capabilities coupled with powerful CAD graphics editing features
 Can accurately track lines, fast draw object; combined with small-format scanners work quickly and easily scanned drawing vector GIS digitized results directly. )
 9, Consistent.Software.Spotlight.PRO.v5.2
(Short Description: This software can be scanned raster image raster, vector, or a mixture of the two editors, you can also perform raster - vector conversion)
 10, Hamrick.Software.VueScan.v8.0.4
 (Brief: when suitable for professional scanning tool for businesses and home use, to provide high-quality image scanning, color balance and correction, reducing costs while increasing the scanning speed. The use VceScan can make your old scanner regained its youthful )
 11, R2V 5.6
 (Short Description: scanned raster map vector software)
 12, RX.AUTOIMAGE.PRO.R7.5
 (Brief: RxAutoImageR7 hybrid editing software is an advanced raster loss, and can perform raster graphics format conversion to the loss. Forautocad version)
 13, RX.SPOTLIGHT.PRO.R7
 (Briefly: the scanned raster image raster, vector, or a mix of both editing and ... this is forAutocad Edition)
 14, Scan2CAD V5.1c
 (Short Description: scanned raster map vector software)
 15, Vpmax pro 6.04
 (Short Description: scanned raster map vector software)
 16, VPStudio V6.75
 (Short Description: scanned raster map vector software)
 17, WinTopo2.5
 (Short Description: scanned raster map vector software)