;3D Contour AutoLisp program 
;Created by Indra Madyasiwi Wresniaji (c)1995
;CAD Research and Development of Lab Komputer Desain Arsitektur 
;Architecture Dept. of Bandung Institute of Technology
;Ganesha St. 10th Bandung Indonesia
;***************************************************************
;Send us $25 or more to buy some cokes and pizzas, please.
;This program needs some elevated lines 
;***************************************************************

(defun C:LV ( / sss ss_1 ss_idx
		le_ma he_ma ll_ma ur_ma 
		x_seg y_seg x_gap y_gap x_pos y_pos
		x_count y_count
		isl_sp isl_ep i_ev int_lines 
		e_name e_data e_spev e_epev e_spt e_sev e_spt_p e_pt
		e_ept e_eev e_ept_p ev_scl 
		done counter
		i_pt i_pt_p i_ds 
		x_coord Y_coord z_coord
		s_fpt e_fpt s_pt 
		max_ds mx_lst 
		ds_lst pt_lst 
		d_ds e_ds p_ds 
		p_mx pt_lst
		_rnl_0 _rnl_1 _rnl_2 _rnl_3 _rnl_4
		_count_0 _count_1
		_rncom_0 _rncom_1) ;LOCAL VARIABLE LIST ADDED BY WHG

  (lv:1)
  (lv:2)
  (lv:3)
  (lv:4)
  (lv:5)
  (lv:6)
  (lv:7)
  (lv:8)
  (lv:9)
  (lv:10)
  (princ)
)

(defun lv:1 ( / sss )
  (if (tblsearch "layer" "lvellar")
      (if (setq sss (ssget "x" '((8 . "lvellar"))))
          (command ".erase" sss "")
      )
  )
  (princ "\nIndra MW's IMWXP(R) LVellar(Tm)-II   (c) 1995 All rights reserved")
  (princ "\nNeed some elevated lines for this operation.")
  (if (not (setq ss_1 (ssget '((0 . "line")))))
      (progn (princ "\nNone selected.")
             (exit)
      )
  )
)

(defun lv:2 ()
  (if (tblsearch "layer" "lvellar")
      (command ".layer" "thaw"   "lvellar"
                        "on"     "lvellar"
                        "unlock" "lvellar"
                        "set"    "lvellar"
                        ""
      )
      (command ".layer" "make"   "lvellar"
                        ""
      )
  )
  (command ".copy" ss_1 "" "0,0,0" "")
  (command ".chprop" ss_1 "" "layer"     "lvellar"
                             "thickness" "0.0"
                             "color"     "3"
           ""
  )
  (command ".layer" "freeze" "~lvellar" "")
  (if (/= (getvar "worlducs") 1)
      (command ".ucs" "")
  )
  (if (or (/= (car (getvar "viewdir")) 0.0) (/= (cadr (getvar "viewdir")) 0.0))
      (command ".plan" "")
  )
  (command ".zoom" "e")
  (COMMAND ".ZOOM" ".9X")  ;WHG
  (setvar  "elevation" 0.0)
  (setvar  "thickness" 0.0)
  (setvar  "osmode" 0)
  (setvar  "coords" 1)
  (setq    le_ma (caddr (getvar "extmin"))
           he_ma (caddr (getvar "extmax"))
  )
)

(defun lv:3 ()
  (if (not (setq ll_ma (getpoint "\nLower left corner of mesh: ")))
      (exit)
  )
  (setq ll_ma (sure:2d ll_ma))
  (command ".ucs" "o" ll_ma)
  (if (not (setq ur_ma (getcorner (trans ll_ma 0 1)
                                  "\nUpper right corner of mesh: "
                       )
           )
      )
      (exit)
  )
  (setq ur_ma (trans ur_ma 1 0)
        ur_ma (sure:2d ur_ma)
  )
  (command ".ucs" "")
)  

(defun lv:4 ( / done )
  (while (not done)
         (setq x_seg (getint "\nNumber of segments along X axis <12>: "))
         (cond ( (not x_seg)
                 (setq x_seg 12
                       done  1
                 )
               )
               ( (< x_seg 1)
                 (princ "\nRequires an integer between 0 and 32767.")
               )
               ( T
                 (setq done 1)
               )
         )
  )
  (setq done nil)
  (while (not done)
         (setq y_seg (getint "\nNumber of segments along Y axis <12>: "))
         (cond ( (not y_seg)
                 (setq y_seg 12
                       done  1
                 )
               )
               ( (< y_seg 1)
                 (princ "\nRequires an integer between 0 and 32767.")
               )
               ( T
                 (setq done 1)
               )
         )
  )
  (setq x_gap (/ (- (car  ur_ma)(car  ll_ma)) x_seg)
        y_gap (/ (- (cadr ur_ma)(cadr ll_ma)) y_seg)
  )
)

(defun lv:5 ( / counter )
  (princ (strcat "\nCreating "
                 (itoa (1+ x_seg))
                 " vertical section-lines..."
         )
  )
  (setq counter -1)
  (repeat (1+ x_seg)
          (setq counter (1+ counter)
                x_pos  (+ (car ll_ma)(* counter x_gap))
                isl_sp (list x_pos (cadr ll_ma))
                isl_ep (list x_pos (cadr ur_ma))
          )
          (grtext -2 (strcat (itoa counter)
                             " out of "
                             (itoa (1+ x_seg))
                             " created"
                     )
          )
          (mk:sect isl_sp isl_ep)
  )
)

(defun lv:6 ()
  (if (setq ss_1 (ssget "x" '((-4 . "<and")(62 . 1)(8 . "lvellar")(-4 . "and>"))))
      (progn (setq counter -1)
             (while (setq e_name (ssname ss_1 (setq counter (1+ counter))))
                    (setq e_data (entget e_name)
                          e_spev (caddr (cdr (assoc 10 e_data)))
                          e_epev (caddr (cdr (assoc 11 e_data)))
                    )
                    (if (equal e_spev e_epev 1e-12)
                        (entdel e_name)
                    )
             )
      )
  )
  (if (setq ss_1 (ssget "x" '((8 . "lvellar"))))
      (command "chprop" ss_1 "" "color" "3" "")
  )
)

(defun lv:7 ( / counter )
  (princ (strcat "\nCreating "
                 (itoa (1+ y_seg))
                 " horizontal section-lines..."
         )
  )
  (setq counter -1)
  (repeat (1+ y_seg)
          (setq counter (1+ counter)
                y_pos  (+ (cadr ll_ma)(* counter y_gap))
                isl_sp (list (car ll_ma) y_pos)
                isl_ep (list (car ur_ma) y_pos)
          )
          (grtext -2 (strcat (itoa counter)
                             " out of "
                             (itoa (1+ y_seg))
                             " created"
                     )
          )
          (mk:sect isl_sp isl_ep)
  )
)

(defun lv:8 ()
  (if (setq ss_1 (ssget "x" '((-4 . "<and")(62 . 3)(8 . "lvellar")(-4 . "and>"))))
      (command ".erase" ss_1 "")
  )
)

(defun lv:9 ( / x_count y_count x_coord y_coord int_line )
  (entmake)
  (entmake (list (cons 0 "Polyline")
                 (cons 10 '(0.0 0.0 0.0))
                 (cons 66 1)
                 (cons 70 16)
                 (cons 40 0.0)
                 (cons 41 0.0)
                 (cons 71 (1+ x_seg))
                 (cons 72 (1+ y_seg))
                 (cons 73 0)
                 (cons 74 0)
                 (cons 75 0)
                 (cons 8 "lvellar")
           )
  )
  (setq x_count -1)
  (repeat (1+ x_seg)
    (setq x_count (1+ x_count)
          x_coord (+ (car ll_ma) (* x_count x_gap))
          isl_sp  (list x_coord (cadr ll_ma))
          isl_ep  (list x_coord (cadr ur_ma))
          y_count -1
    )
    (repeat (1+ y_seg)
      (setq y_count (1+ y_count)
            y_coord (+ (cadr ll_ma) (* y_count y_gap))
      )
      (if (setq int_line (ssget "c" (list x_coord y_coord) (list x_coord y_coord) '((0 . "line"))))
          (progn (setq e_name  (ssname int_line 0)
                       e_data  (entget e_name)
                       e_spt   (cdr (assoc 10 e_data))
                       e_sev   (caddr e_spt)
                       e_spt_p (sure:2d e_spt)
                       e_ept   (cdr (assoc 11 e_data))
                       e_eev   (caddr e_ept)
                       e_ept_p (sure:2d e_ept)
                       i_pt_p  (inters isl_sp isl_ep e_spt_p e_ept_p nil)
                 )
                 (if i_pt_p
                   (setq ev_scl  (/ (distance e_spt_p i_pt_p)
                                    (distance e_spt_p e_ept_p)
                                 )
                         i_ev    (+ e_sev (* ev_scl (- e_eev e_sev)))
                         z_coord i_ev
                   )
                   (setq z_coord le_ma)
                 )
          )
          (setq z_coord le_ma)
      )
      (entmake (list (cons 0 "Vertex")
                     (cons 10 (list x_coord y_coord z_coord))
                     (cons 70 64)
               )
      )
    )
  )
  (entmake (list (cons 0 "Seqend")))
)

(defun lv:10 ( / ss_1 )
  (if (setq ss_1 (ssget "x" '((-4 . "<and")(0 . "line")(8 . "lvellar")(-4 . "and>"))))
      (command ".erase" ss_1 "")
  )
)

(defun mk:sect ( s_fpt e_fpt / int_lines )
  (setq max_ds (distance s_fpt e_fpt)
        mx_lst nil
        ds_lst nil
        pt_lst nil
        int_lines nil
        ss_idx -1
  )
  (if (setq int_lines (ssget "c" s_fpt e_fpt '((0 . "LINE"))))
      (while (setq e_name  (ssname int_lines (setq ss_idx (1+ ss_idx))))
             (setq e_data  (entget e_name)
                   e_spt   (cdr (assoc 10 e_data))
                   e_sev   (caddr e_spt)
                   e_spt_p (sure:2d e_spt)
                   e_ept   (cdr (assoc 11 e_data))
                   e_eev   (caddr e_ept)
                   e_ept_p (sure:2d e_ept)
                   i_pt_p  (inters s_fpt e_fpt e_spt_p e_ept_p)
             )
             (if i_pt_p
               (setq ev_scl (/ (distance e_spt_p i_pt_p)
                               (distance e_spt_p e_ept_p)
                            )
                     i_ev   (+ e_sev (* ev_scl (- e_eev e_sev)))
                     i_pt   (list (car i_pt_p) (cadr i_pt_p) i_ev)
                     i_ds   (distance (list (car i_pt_p) (cadr i_pt_p)) s_fpt)
                     mx_lst (append mx_lst (list (cons i_ds i_pt)))
                     ds_lst (append ds_lst (list i_ds))
               )
             )
      )
      (setq s_pt   (list (car s_fpt) (cadr s_fpt) le_ma)
            e_pt   (list (car e_fpt) (cadr e_fpt) le_ma)
            s_ds   0.0
            e_ds   (distance (list (car s_pt) (cadr s_pt))
                             (list (car e_pt) (cadr e_pt))
                   )
            mx_lst (append mx_lst (list (cons s_ds s_pt)))
            ds_lst (append ds_lst (list s_ds))
            mx_lst (append mx_lst (list (cons e_ds e_pt)))
            ds_lst (append ds_lst (list e_ds))
     )
  )
  (setq ds_lst (realsort ds_lst)
        ct     -1
  )
  (while (setq p_ds   (nth (setq ct (1+ ct)) ds_lst))
         (setq p_mx   (assoc p_ds mx_lst)
               pt_lst (append pt_lst (list (cdr p_mx)))
         )
  )
  (setq s_pt (nth 0 pt_lst)
        s_pt (list (car s_fpt) (cadr s_fpt) (caddr s_pt))
        e_pt (nth (1- (length pt_lst)) pt_lst)
        e_pt (list (car e_fpt) (cadr e_fpt) (caddr e_pt))
  )
  (if (equal (nth 0 ds_lst) 0.0 1e-12)
      nil
      (setq pt_lst (append (list s_pt) pt_lst))
  )
  (if (equal (nth (1- (length ds_lst)) ds_lst) max_ds 1e-12)
      nil
      (setq pt_lst (append pt_lst (list e_pt)))
  )
  (setq ct 0)
  (while (setq e_pt (nth (setq ct (1+ ct)) pt_lst))
         (setq s_pt (nth (1- ct) pt_lst))
         (entmake (list (cons 0 "Line")
                        (cons 10 s_pt)
                        (cons 11 e_pt)
                        (cons 8 "lvellar")
                        (cons 62 1)
                  )
         )
  )
)

(defun realsort
  ( _rnl_0
  / _rnl_1
    _rnl_2
    _rnl_3
    _rnl_4
    _count_0
    _count_1
    _rncom_0
    _rncom_1
  )
  (setq _rnl_1   _rnl_0
        _rnl_4   nil
        _count_0 -1
  )
  (while (setq _rncom_0 (nth  (setq _count_0 (1+ _count_0))  _rnl_0))
         (setq _count_1 -1
               _rnl_2   nil
               _rnl_3   nil
         )
         (while (setq _rncom_1 (nth  (setq _count_1 (1+ _count_1))  _rnl_1))
           (cond ( (< _rncom_1 _rncom_0)
                   (setq _rnl_2 (cons _rncom_1 _rnl_2))
                 )
                 ( (> _rncom_1 _rncom_0)
                   (setq _rnl_3 (append _rnl_3 (list _rncom_1)))
                 )
           )
           (setq _rnl_4 (cons _rncom_0 _rnl_3) 
                 _rnl_4 (append (reverse _rnl_2) _rnl_4)
           )
         )
         (setq _rnl_1 _rnl_4 _rnl_4 nil)
  )
  (if 1 _rnl_1)
)

(defun sure:2d ( _lst )
  (list (car _lst)(cadr _lst))
)