;********CADPIN 2.0********
;program pro import a export bodu z AutoCADu a pro generovani tabulky souradnic
;(c) Ing. Petr Malec, 1997

(defun c:tas ( / al c dim ed h ma mi n p r sc scp ss1 sz x y)
(if (= (tblsearch "appid" "cadpin") nil) (regapp "cadpin"))
(setq p 0)
(prompt "\nVyberte body pro zápis do tabulky...")
(if (setq ss1 (ssget '((0 . "point") (-3 ("cadpin")))))
 (progn
  (setq sc nil sz nil dim (getvar "DIMZIN"))
  (setvar "DIMZIN" 0)
  (repeat (sslength ss1)
   (setq ed (entget (ssname ss1 p) '("cadpin")))
   (setq scp (cadr (assoc '-3 ed)))
   (setq n (cdr (cadr scp)))
   (if (> n 0.0)
     (progn
      (setq sc (cons n sc)
            x (rtos (abs (cadr (assoc 10 ed))) 2 3)
            y (rtos (abs (caddr (assoc 10 ed))) 2 3))
      (setq r (list n x y))
      (setq sz (cons r sz))
     )
   )
   (setq p (1+ p))
  )
  (setq p (getpoint "\nZadejte levý horní roh tabulky: "))
  (command "_UCS" "O" p)
  (setq h (getreal "\nZadejte výšku popisového textu <2.0>: "))
  (if (null h) (setq h 2.0))
  (setq al (angle (trans '(0.0 0.0 0.0) 1 0) (trans '(1.0 0.0 0.0) 1 0))
        mi (apply 'min sc)
        ma (apply 'max sc)
        p 0
        y (* -3.0 h))
  (entmake (list '(0 . "line") (cons 10 (trans '(0.0 0.0 0.0) 1 0)) (cons 11 (trans (list (* 27.0 h) 0.0 0.0) 1 0))))
  (entmake (list '(0 . "line") (cons 10 (trans (list 0.0 (* -3.0 h) 0.0) 1 0)) (cons 11 (trans (list (* 27.0 h) (* -3.0 h) 0.0) 1 0))))
  (entmake (list '(0 . "text") '(10 0.0 0.0 0.0) (cons 40 h) (cons 1 "BOD") (cons 50 al) '(41 . 0.9) '(7 . "standard") '(72 . 2) (cons 11 (trans (list (* 4.0 h) (* -2.0 h) 0.0) 1 0))))
  (entmake (list '(0 . "text") '(10 0.0 0.0 0.0) (cons 40 h) (cons 1 "Y [m]") (cons 50 al) '(41 . 0.9) '(7 . "standard") '(72 . 1) (cons 11 (trans (list (* 11.0 h) (* -2.0 h) 0.0) 1 0))))
  (entmake (list '(0 . "text") '(10 0.0 0.0 0.0) (cons 40 h) (cons 1 "X [m]") (cons 50 al) '(41 . 0.9) '(7 . "standard") '(72 . 1) (cons 11 (trans (list (* 22.0 h) (* -2.0 h) 0.0) 1 0))))
  (while (< (setq n (apply 'min sc)) 1.0E7)
   (cond ((< n 10.0) (setq c (strcat "      " (rtos n 2 0))))
         ((and (>= n 10.0) (< n 100.0)) (setq c (strcat "     " (rtos n 2 0))))
         ((and (>= n 100.0) (< n 1000.0)) (setq c (strcat "    " (rtos n 2 0))))
         ((and (>= n 1000.0) (< n 10000.0)) (setq c (strcat "   " (rtos n 2 0))))
         ((and (>= n 10000.0) (< n 100000.0)) (setq c (strcat "  " (rtos n 2 0))))
         ((and (>= n 100000.0) (< n 1000000.0)) (setq c (strcat " " (rtos n 2 0))))
         (t (setq c (rtos n 2 0)))
   )
   (setq y (- y (* 2.0 h)))
   (entmake (list '(0 . "text") '(10 0.0 0.0 0.0) (cons 40 h) (cons 1 c) (cons 50 al) '(41 . 0.9) '(7 . "standard") '(72 . 2) (cons 11 (trans (list (* 4.5 h) y 0.0) 1 0))))
   (entmake (list '(0 . "text") '(10 0.0 0.0 0.0) (cons 40 h) (cons 1 (cadr (assoc n sz))) (cons 50 al) '(41 . 0.9) '(7 . "standard") '(72 . 1) (cons 11 (trans (list (* 11.0 h) y 0.0) 1 0))))
   (entmake (list '(0 . "text") '(10 0.0 0.0 0.0) (cons 40 h) (cons 1 (caddr (assoc n sz))) (cons 50 al) '(41 . 0.9) '(7 . "standard") '(72 . 1) (cons 11 (trans (list (* 22.0 h) y 0.0) 1 0))))
   (setq p (1+ p)
         sc (subst 1.0E7 n sc))
  )
  (entmake (list '(0 . "line") (cons 10 (trans '(0.0 0.0 0.0) 1 0)) (cons 11 (trans (list 0.0 (- y h) 0.0) 1 0))))  
  (entmake (list '(0 . "line") (cons 10 (trans (list 0.0 (- y h) 0.0) 1 0)) (cons 11 (trans (list (* 27.0 h) (- y h) 0.0) 1 0))))
  (entmake (list '(0 . "line") (cons 10 (trans (list (* 27.0 h) (- y h) 0.0) 1 0)) (cons 11 (trans (list (* 27.0 h) 0.0 0.0) 1 0))))  
  (command "_UCS" "P")
  (setvar "DIMZIN" dim)
  (prompt (strcat "\nDo tabulky bylo zapsáno " (rtos p 2 0) " bodů\ns rozsahem číslování od " (rtos mi 2 0) " do " (rtos ma 2 0)))
 )
 (prompt "\nNebyl vybrán žádný bod")
) 	   
(princ)
)

(defun c:pex ( / c ed f fn ma mi n p r sc scp ss1 sz z)
(if (= (tblsearch "appid" "cadpin") nil) (regapp "cadpin"))
(setq fn (getfiled "Zadejte soubor pro export bodů" "" "gsa" (+ 1 4)))
(setq f (open fn "a")
      p 0)
(prompt "\nVyberte body pro export...")
(if (setq ss1 (ssget '((0 . "point") (-3 ("cadpin")))))
 (progn
  (setq sc nil sz nil)
  (repeat (sslength ss1)
   (setq ed (entget (ssname ss1 p) '("cadpin")))
   (setq scp (cadr (assoc '-3 ed)))
   (setq n (cdr (cadr scp)))
   (if (> n 0.0)
    (progn
     (setq sc (cons n sc))
     (setq r (strcat "    " (rtos (abs (cadr (assoc 10 ed))) 2 6) " " (rtos (abs (caddr (assoc 10 ed))) 2 6))
           z (cadddr (assoc 10 ed)))
     (if (and (= z 0.0) (caddr scp)) (setq z (cdr (caddr scp))))
     (cond ((and (>= z 100.0) (< z 1000.0)) (setq z (strcat "     " (rtos z 2 6))))
           ((and (>= z 10.0) (< z 100.0)) (setq z (strcat "      " (rtos z 2 6))))
           ((and (>= z 0.0) (< z 10.0)) (setq z (strcat "       " (rtos z 2 6))))
	       (t (setq z (strcat "    " (rtos z 2 6))))
     )
     (setq r (list n (strcat r z)))
     (setq sz (cons r sz))
    )
   )
   (setq p (1+ p))
  )
  (setq p 0 mi (apply 'min sc) ma (apply 'max sc))
  (prompt "\nZapsáno bodů: ")
  (while (< (setq n (apply 'min sc)) 1.0E7)
   (cond ((< n 10.0) (setq c (strcat "      " (rtos n 2 0))))
         ((and (>= n 10.0) (< n 100.0)) (setq c (strcat "     " (rtos n 2 0))))
         ((and (>= n 100.0) (< n 1000.0)) (setq c (strcat "    " (rtos n 2 0))))
         ((and (>= n 1000.0) (< n 10000.0)) (setq c (strcat "   " (rtos n 2 0))))
         ((and (>= n 10000.0) (< n 100000.0)) (setq c (strcat "  " (rtos n 2 0))))
         ((and (>= n 100000.0) (< n 1000000.0)) (setq c (strcat " " (rtos n 2 0))))
         (t (setq c (rtos n 2 0)))
   )
   (setq r (strcat c (cadr (assoc n sz)))
         p (1+ p)
         sc (subst 1.0E7 n sc))
   (write-line r f)
   (if (= (rem p 50) 0) (prompt (strcat (rtos p 2 0) ", ")))
  )
  (prompt (strcat "\nDo souboru " fn " bylo zapsáno " (rtos p 2 0) " bodů\ns rozsahem číslování od " (rtos mi 2 0) " do " (rtos ma 2 0)))
 )
 (prompt "\nNebyl vybrán žádný bod")
) 	   
(close f)
(princ)
)

(defun c:cib ( / a al b1 d dim ed h hl n ncp nn p r sc scp ss1 ss2 sz x y z zt)
(if (= (tblsearch "appid" "cadpin") nil) (regapp "cadpin"))
(initget "Přečíslovávat")
(setq a (getkword "\nchcete Přečíslovávat <Vytvářet nové body>: "))
(if (= a "Přečíslovávat")
 (if (setq d (getreal "\nPosun v číslování: "))
  (progn 
   (setq d (float (fix d))
         p 0
         sc nil)
   (prompt "\nVyberte body pro přečíslování...")
   (if (/= d 0.0)
    (if (setq ss1 (ssget '((0 . "point") (-3 ("cadpin")))))
      (repeat (sslength ss1)
       (setq ed (entget (ssname ss1 p) '("cadpin")))
       (setq sz (assoc '-3 ed))
       (setq hl (assoc '8 ed))
       (if (= (cdr hl) "CP_BODY") (setq hl '(8 . "cp_cisla")))
       (setq scp (cadr sz))
       (setq n (cdr (cadr scp)))
       (setq sc (cons n sc))
       (setq nn (+ n d))
       (setq ncp (subst (cons 1071 nn) (cons 1071 n) scp))
       (setq ed (subst (list -3 ncp) sz ed))
       (entmod ed)
       (setq n (cons 1 (rtos n 2 0)))
       (setq ss2 (ssget "x" (list '(0 . "text") hl n '(-3 ("cadpin")))))
       (if ss2
        (progn
         (setq ed (entget (ssname ss2 0)))
         (setq nn (cons 1 (rtos nn 2 0)))
         (setq ed (subst nn n ed))
         (entmod ed)
        )
       )
       (setq p (1+ p))
      )
    )
   )
   (prompt (strcat "\nBylo přečíslováno celkem " (rtos p 2 0) " bodů\ns původním rozsahem číslování od " (rtos (apply 'min sc) 2 0) " do " (rtos (apply 'max sc) 2 0)))
  )
  (prompt "\nNebyl vybrán žádný bod, nebo byl zadán nulový posun v číslování")
 )
 (progn
  (setq al (angle (trans '(0.0 0.0 0.0) 1 0) (trans '(1.0 0.0 0.0) 1 0)))
  (setq h (getreal "\nZadejte výšku popisového textu <1.4>: "))
  (if (null h) (setq h 1.4))
  (initget "S")
  (setq r (getkword "\nchcete body S výškou, <Bez výšky>: "))
  (if (= r "S")
   (progn
    (setq dim (getvar "DIMZIN"))
    (setvar "DIMZIN" 0)
    (while (setq n (getreal "\nZadejte číslo nového bodu: "))
     (while (setq b1 (getpoint (strcat "\nBod číslo " (rtos (fix n) 2 0) " :")))
      (setq b1 (trans b1 1 0))
      (initget 1)
      (setq zt (getreal "Zadejte výšku bodu (např. 198.22): ")) 
      (setq z (+ (caddr b1) zt) x (car b1) y (cadr b1))
      (entmake (list '(0 . "point") (list 10 x y z) (list -3 (list "cadpin" (cons 1071 n)))))
      (entmake (list '(0 . "text") (list 10 x (+ y (/ h 2.0)) z) (cons 40 h) (cons 1 (rtos (fix n) 2 0)) (cons 50 al) '(7 . "standard") (list -3 (list "cadpin" (cons 1071 n)))))
      (entmake (list '(0 . "text") '(8 . "cp_vysky") (list 10 (- x (* h 2.83)) (- y (/ h 2.0)) z) (cons 40 h) (cons 1 (vupr zt)) (cons 50 al) '(7 . "standard") '(72 . 1) (list 11 x y z) '(73 . 2)))
      (setq n (1+ n))
     )
    )
    (setvar "DIMZIN" dim)
   )
   (while (setq n (getreal "\nZadejte číslo nového bodu: "))
    (while (setq b1 (getpoint (strcat "\nBod číslo " (rtos (fix n) 2 0) " :")))
     (setq b1 (trans b1 1 0))
	 (setq x (car b1) y (cadr b1) z (caddr b1))
     (entmake (list '(0 . "point") (list 10 x y z) (list -3 (list "cadpin" (cons 1071 n)))))
     (entmake (list '(0 . "text") (list 10 x (+ y (/ h 2.0)) z) (cons 40 h) (cons 1 (rtos (fix n) 2 0)) (cons 50 al) '(7 . "standard") (list -3 (list "cadpin" (cons 1071 n)))))
	 (setq n (1+ n))
    )
   )
  )
 )
)
(princ)
)

(defun c:pin ( / a al b d dim f fn h n p r re s sc x y z)
(if (= (tblsearch "appid" "cadpin") nil) (regapp "cadpin"))
(setq fn (getfiled "Vyberte soubor bodů pro import" "" "gsa" 4))
(setq f (open fn "r"))
(initget (+ 2 4))
(setq a (getreal "\nZadejte číselný rozsah - první importovaný bod (Return pro celý soubor): "))
(if (= a nil)
 (setq a 1 b 1E7)
 (progn
  (setq a (fix a))
  (initget (+ 1 2 4))
  (setq b (fix (getreal "\n                       - poslední importovaný bod: ")))
  (if (> a b)
   (progn
   (setq d a)
   (setq a b)
   (setq b d)
   )
  )
 )
)
(initget (+ 2 4))
(setq h (getreal "Zadejte výšku popisového textu <1.4>: "))
(if (= h nil) (setq h 1.4))
(setq al (angle (trans '(0.0 0.0 0.0) 1 0) (trans '(1.0 0.0 0.0) 1 0))
      p 0
      sc nil
      d (- b a)
      dim (getvar "DIMZIN"))
(initget "3dimenzionální")
(setq r (getkword "\nZadejte rozměr bodů v AutoCADu:  3dimenzionální, <2dimenzionální>: "))
(prompt "\nNačteno bodů: ")
(setvar "DIMZIN" 0)
(if (= r "3dimenzionální")
 (while (and (setq re (read-line f)) (<= p d))
  (setq n (read re))
  (if (and (= (type n) 'int) (and (>= n a) (<= n b)))
   (progn
    (setq s nil)
    (while (= (ascii re) 32) (setq re (substr re 2)))
    (repeat 3
     (while (/= (ascii re) 32) (setq re (substr re 2)))
     (setq s (cons (atof re) s))
     (while (= (ascii re) 32) (setq re (substr re 2)))
    )
    (mapcar 'set '(z y x) s)
    (setq x (* x -1.0) y (* y -1.0))
    (entmake (list '(0 . "point") '(8 . "cp_body") (list 10 x y z) (list -3 (list "cadpin" (cons 1071 n)))))
    (entmake (list '(0 . "text") '(8 . "cp_cisla") (list 10 x (+ y (/ h 2.0)) z) (cons 40 h) (cons 1 (rtos n 2 0)) (cons 50 al) '(7 . "standard") (list -3 (list "cadpin" (cons 1071 n)))))
    (entmake (list '(0 . "text") '(8 . "cp_vysky") (list 10 (- x (* h 2.83)) (- y (/ h 2.0)) z) (cons 40 h) (cons 1 (vupr z)) (cons 50 al) '(7 . "standard") '(72 . 1) (list 11 x y z) '(73 . 2)))
    (setq p (1+ p))
    (if (= (rem p 50) 0) (prompt (strcat (rtos p 2 0) ", ")))
    (setq sc (cons n sc))
   )
  )
 )
 (while (and (setq re (read-line f)) (<= p d))
  (setq n (read re))
  (if (and (= (type n) 'int) (and (>= n a) (<= n b)))
   (progn
    (setq s nil)
    (while (= (ascii re) 32) (setq re (substr re 2)))
    (repeat 3
     (while (/= (ascii re) 32) (setq re (substr re 2)))
     (setq s (cons (atof re) s))
     (while (= (ascii re) 32) (setq re (substr re 2)))
    )
    (mapcar 'set '(z y x) s)
    (setq x (* x -1.0) y (* y -1.0))
    (entmake (list '(0 . "point") '(8 . "cp_body") (list 10 x y 0.0) (list -3 (list "cadpin" (cons 1071 n) (cons 1040 z)))))
    (entmake (list '(0 . "text") '(8 . "cp_cisla") (list 10 x (+ y (/ h 2.0)) 0.0) (cons 40 h) (cons 1 (rtos n 2 0)) (cons 50 al) '(7 . "standard") (list -3 (list "cadpin" (cons 1071 n)))))
    (entmake (list '(0 . "text") '(8 . "cp_vysky") (list 10 (- x (* h 2.83)) (- y (/ h 2.0)) 0.0) (cons 40 h) (cons 1 (vupr z)) (cons 50 al) '(7 . "standard") '(72 . 1) (list 11 x y 0.0) '(73 . 2)))
    (setq p (1+ p))
    (if (= (rem p 50) 0) (prompt (strcat (rtos p 2 0) ", ")))
    (setq sc (cons n sc))
   )
  )
 )
)
(close f)
(if (= p 0) (prompt "\nV zadaném číselném rozsahu nebyl nalezen žádný bod")
            (prompt (strcat "\nZe souboru " fn " bylo načteno " (rtos p 2 0) " bodů\ns rozsahem číslování od " (rtos (apply 'min sc) 2 0) " do " (rtos (apply 'max sc) 2 0)))
)
(setvar "DIMZIN" dim)
(princ)
)

(defun vupr (z / b z2)
(setq z2 (rtos (/ z 100.0) 2 4))
(setq b (substr z2 (- (strlen z2) 1)))
(setq z2 (substr z2 (- (strlen z2) 3) 2))
(setq z2 (strcat z2 "  " b))
)

(defun zao (x d / m)
 (setq m (expt 10.0 d))
 (if (< x 0.0) (setq x (/ (fix (- (* x m) 0.5)) m)) (setq x (/ (fix (+ (* x m) 0.5)) m)))
)

(princ "\n\tCadpin načten. Použitelné příkazy jsou PIN, PEX, CIB, TAS.")
(princ)
