;;;
;;;   Ceske kotovani pro AutoCAD.
;;;
;;;   Lisp opravujici vynaseci cary kot tak, aby mely presnou
;;;   delku.
;;;
;;;   Pozor ! Jakakoli manipulace s kotou rusi jeji opravu -> je treba
;;;   pouzit tento program znovu.
;;;
;;;   1998 Jiri Svoboda          v 1.0
;;;
;; Pokud se vám program hodí napište mi na jiri.svoboda@seznam.cz
;; budu rád, když zjistím, že jej někdo další používá.
;; Pokud máte nějaké připomínky pošlete je také - zpětná vazba vítána.

;;;   test zda jde o lin. ci zarovnanou kotu
(defun testdim(dimblk / dimtype ret)
;;; zjisti typ
	(setq dimtype (cdr (assoc 70 dimblk)))
;;; ocesej nedulezite priznaky
	(if (> dimtype 127) (setq dimtype (- dimtype 128)))
	(if (> dimtype 63) (setq dimtype (- dimtype 64)))
	(if (> dimtype 31) (setq dimtype (- dimtype 32)))
;;; testuj zda je to ten spravny typ
	(if (< dimtype 2) (setq ret 1) (setq ret 0))
;;; vrat 1 - Ano 0 - Ne
	ret
	)


;;; uprava kotovaci cary
(defun correctline(line nldir / bod1 bod2 dir dist nbod1 ndir angl )
;;; je to skutecne cara ?
	(if (= "LINE" (cdr(assoc 0 line)))
		(progn
;;; koncove body cary
			(setq bod1 (cdr (assoc 10 line)))
			(setq bod2 (cdr (assoc 11 line)))
;;; jeji velikost
			(setq dist (distance bod1 bod2))
;;; test jestli je vetsi nez zadana delka
			(if (< llength dist)
				(progn
;;; vektor vynaseci cary
					(setq dir nil)
					(mapcar '(lambda (x x1) (setq dir (append dir (list (- x x1))))) bod1 bod2)
;;; jeho uprava na zadanou delku
					(setq ndir nil)
					(mapcar '(lambda (x) (setq ndir (append ndir (list (* llength (/ x dist)))))) dir)  ;;; definice dir tak aby byl jako vynas. cara
;;; zmer uhel mezi carou a predpokladanym smerem vynaseci cary
					(setq angl 0)
					(mapcar '(lambda (x x1) (setq angl (+ angl (* x x1)))) nldir ndir)
					(setq angl (abs (/ angl (distance '(0 0 0) ndir))))
;;; test je uhel ostry
					(if (> angl 0.7)
						(progn
;;; vypocet noveho prvniho bodu
							(setq nbod1 nil)
							(mapcar '(lambda (x x1) (setq nbod1 (append nbod1 (list (+ x1 x))))) ndir bod2)
							(setq line (subst (cons 10 nbod1) (assoc 10 line) line))
;;; uprava entity cary
							(entmod line)
							(entupd (cdr (assoc -1 line)))
							)
						)
					)
				)
			)
		)
	)

;;; vlastni definice prikazu

(defun c:csdim( );;;/ ss1 cnt blname blk blk2 dim ldir nldir)
;;; zjisti na jakou delku se budou vynaseci cary upravovat
	(setq llength (getdist "Zadejte delku vynasecich car (vcetne presahu):"))
;;; vlastni vyber kot
	(princ "Vyberte koty:")
	(setq ss1 (ssget '((0 . "DIMENSION")))) /* vyber pouze koty */
	(setq cnt 0)
;;; pro kazdy prvek vyberove mnoziny
	(repeat (sslength ss1)
;;; nejprve vyber prislusnou kotu
		(setq dim (entget (ssname ss1 cnt)))
;;; zjisty jmeno prislusneho anonymniho bloku
		(setq blname (cdr (assoc 2 dim)))
;;; zjisti handle bloku
		(setq blk (tblobjname "BLOCK" blname))
;;; otestuj zda jde o spravnou koty
		(if (> (testdim dim) 0)
			(progn
;;; zjisteni predpokladaneho smeru vynaseci cary
				(setq ldir nil)
				(mapcar '(lambda (x x1) (setq ldir (append ldir (list (- x x1))))) (cdr (assoc 10 dim)) (cdr (assoc 14 dim)))
				(setq nldir nil)
                (if (/= 0 (distance '(0 0 0) ldir))
                    (progn
    				    (mapcar '(lambda (x) (setq nldir (append nldir (list (/ x (distance '(0 0 0) ldir)))))) ldir)  ;;; normuj vektor vynas cary
;;; vyber a oprav prvni caru
	    			    (setq blk2 (entnext blk))
		    		    (correctline (entget blk2) nldir)
;;; vyber a oprav druhou caru
			    	    (setq blk2 (entnext blk2))
				        (correctline (entget blk2) nldir)
;;; prekresli danou kotu na obrazovce
				        (entupd (cdr (assoc -1 dim)))
                        )
                    )
				)
			)

		(setq cnt (1+ cnt))
		)
	(princ "Hotovo.")
	(princ)
	)