;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_ML-FILLET                                          - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  Multilinien abrunden                                           - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_ml-fillet                                                    - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 15.02.2023                                                - ;
;;; -              durch : Andreas Kraus                                             - ;
;;; - ------------------------------------------------------------------------------ - ;

(vl-load-com)
(DEFUN K_->OBJ_NAME (NAME)
  (COND	((= (TYPE NAME) (QUOTE ENAME))
	 (vlax-ename->vla-object NAME)
	)
	((= (TYPE NAME) (QUOTE VLA-OBJECT)) NAME)
	((= (TYPE NAME) (QUOTE STR))
	 (vlax-ename->vla-object (HANDENT NAME))
	)
	((= (TYPE NAME) (QUOTE LIST))
	 (vlax-ename->vla-object (CDR (ASSOC -1 NAME)))
	)
  )
)
(DEFUN K_AC-DOC	nil
  (vla-get-ActiveDocument (vlax-get-acad-object))
)
(DEFUN K_GET_MERKLISTE (NAME / WERT)
  (IF (ASSOC NAME K_MERKLISTE)
    (SETQ WERT (NTH 1 (ASSOC NAME K_MERKLISTE)))
  )
  WERT
)
(DEFUN K_OFANG (MODUS)
  (COND	((AND (= MODUS "aus") (= (LOGAND (GETVAR "osmode") 16384) 0))
	 (SETVAR "osmode" (+ (GETVAR "osmode") 16384))
	)
	((AND (= MODUS "ein")
	      (= (LOGAND (GETVAR "osmode") 16384) 16384)
	 )
	 (SETVAR "osmode" (- (GETVAR "osmode") 16384))
	)
	((= (TYPE MODUS) (QUOTE INT))
	 (IF (MINUSP MODUS)
	   (SETVAR "osmode"
		   (K_GET_MERKLISTE (STRCAT "osmode" (ITOA (ABS MODUS))))
	   )
	   (K_PUT_MERKLISTE
	     (STRCAT "osmode" (ITOA MODUS))
	     (GETVAR "osmode")
	   )
	 )
	)
	((= MODUS "mem")
	 (K_PUT_MERKLISTE "osmode" (GETVAR "osmode"))
	)
	((AND (= MODUS "restore") (K_GET_MERKLISTE "osmode"))
	 (SETVAR "osmode" (K_GET_MERKLISTE "osmode"))
	)
  )
)
(DEFUN K_PUT_MERKLISTE (NAME WERT)
  (IF (ASSOC NAME K_MERKLISTE)
    (SETQ K_MERKLISTE
	   (SUBST (LIST NAME WERT)
		  (ASSOC NAME K_MERKLISTE)
		  K_MERKLISTE
	   )
    )
    (SETQ K_MERKLISTE (CONS (LIST NAME WERT) K_MERKLISTE))
  )
  (PRINC)
)
(DEFUN K_TEILUNGEN (N1 N2 TEILER / LISTE M)
  (SETQ	TEILER (FIX TEILER)
	LISTE  (LIST (FLOAT N2))
	M      (/ (- N2 N1) (FLOAT TEILER))
  )
  (REPEAT TEILER (SETQ LISTE (CONS (- (CAR LISTE) M) LISTE)))
)
(DEFUN RECHNE_BOGEN (P1 P2 / OBJ_NAME PZ Q TEILUNG)
  (SETQ	OBJ_NAME (K_->OBJ_NAME ENT_NAME)
	PZ	 (INTERS (vlax-curve-getPointAtParam
			   OBJ_NAME
			   (+ (vlax-curve-getParamAtPoint OBJ_NAME P1) 0.25)
			 )
			 (POLAR	(vlax-curve-getPointAtParam
				  OBJ_NAME
				  (+ (vlax-curve-getParamAtPoint OBJ_NAME P1) 0.25)
				)
				(+ (* PI 0.5)
				   (ANGLE (QUOTE (0 0))
					  (vlax-curve-getFirstDeriv
					    OBJ_NAME
					    (+ (vlax-curve-getParamAtPoint OBJ_NAME P1) 0.25)
					  )
				   )
				)
				1.0
			 )
			 (vlax-curve-getPointAtParam
			   OBJ_NAME
			   (- (vlax-curve-getParamAtPoint OBJ_NAME P2) 0.25)
			 )
			 (POLAR	(vlax-curve-getPointAtParam
				  OBJ_NAME
				  (- (vlax-curve-getParamAtPoint OBJ_NAME P2) 0.25)
				)
				(+ (* PI 0.5)
				   (ANGLE (QUOTE (0 0))
					  (vlax-curve-getFirstDeriv
					    OBJ_NAME
					    (- (vlax-curve-getParamAtPoint OBJ_NAME P2) 0.25)
					  )
				   )
				)
				1.0
			 )
			 nil
		 )
  )
  (IF (> (REM (SETQ TEILUNG (/ (ABS (- (ANGLE PZ P1) (ANGLE PZ P2))) W_MAX))
	      1.0
	 )
	 0.0
      )
    (SETQ TEILUNG (1+ (FIX TEILUNG)))
    (SETQ TEILUNG (FIX TEILUNG))
  )
  (SETQ	P_LIST (APPEND (REVERSE
			 (MAPCAR (QUOTE (LAMBDA (Q) (vlax-curve-getPointAtParam OBJ_NAME Q)))
				 (K_TEILUNGEN
				   (+ (vlax-curve-getParamAtPoint OBJ_NAME P1) (/ 0.5 TEILUNG))
				   (- (vlax-curve-getParamAtPoint OBJ_NAME P2) (/ 0.5 TEILUNG))
				   TEILUNG
				 )
			 )
		       )
		       P_LIST
	       )
  )
)

(defun c:k_ml-fillet (/		  ANZAHL      BOGEN	  BREITE      ENT_DATA	  ENT_LIST    ENT_LIST2	  ENT_NAME    F		  K_ML-FILLET-AUFLÖS
		      MLINE_DATA  MLINE_DATA2 MLINE_NAME  MLINE_NAME2 N		  P	      PIC1	  PIC2	      PLINE_SATZ  PX	      P_LIST
		      SATZ	  SATZ2	      W_MAX
		     )
;;; Multilinien abrunden
  (defun k_ml-fillet_pic (/ pic)
    (while (null pic)
      (initget "r a")
      (setq
	pic (nentsel
	      (strcat "Objekt wählen oder r für Radius <"
		      (rtos (getvar "filletrad"))
		      ">, a für Auflösung <"
		      (rtos k_ml-fillet-auflös)
		      "> : "
	      )
	    )
      )
      (cond
	((= pic "r")
	 (setvar "filletrad" (getreal "Radius : "))
	 (setq pic nil)
	)
	((= pic "a")
	 (setq k_ml-fillet-auflös (getreal "Auflösung : "))
	 (k_put_merkliste "k_ml-fillet-auflös" k_ml-fillet-auflös)
	 (setq w_max (/ k_ml-fillet-auflös pi))
	 (setq pic nil)
	)
      )
    )
    pic
  )

  (defun k_ml-fillet_mk_mline ()
    (setq anzahl (sslength satz))
    (setq n 0)
    (setq pline_satz (ssadd))
    (repeat anzahl
      (setq ent_name (ssname satz n))
      (if ent_name
	(progn
	  (setq ent_data (entget ent_name))
	  (cond
	    ((= (cdr (assoc 0 ent_data)) "LINE")
	     (setq p (cons 10
			   (mapcar '*
				   (cdr (assoc 10 ent_data))
				   (list 1.0 1.0 0.0)
			   )
		     )
	     )
	     (setq
	       ent_data
		(subst p (assoc 10 ent_data) ent_data)
	     )
	     (setq p (cons 11
			   (mapcar '*
				   (cdr (assoc 11 ent_data))
				   (list 1.0 1.0 0.0)
			   )
		     )
	     )
	     (setq
	       ent_data
		(subst p (assoc 11 ent_data) ent_data)
	     )
	    )
	    ((= (cdr (assoc 0 ent_data)) "ARC")
	     (setq p (cons 10
			   (mapcar '*
				   (cdr (assoc 10 ent_data))
				   (list 1.0 1.0 0.0)
			   )
		     )
	     )
	     (setq
	       ent_data
		(subst p (assoc 10 ent_data) ent_data)
	     )
	    )
	  )
	  (entmod ent_data)
	  (command "pedit" ent_name "j" "br" breite "x")
	  (setq pline_satz (ssadd (entlast) pline_satz))
	)				;end progn
      )					;end if
      (setq n (1+ n))
    )					;end repeat
    (setq anzahl (sslength pline_satz))
    (setq n 0)
    (repeat anzahl
      (if pline_satz
	(progn
	  (setq ent_name (ssname pline_satz n))
	  (command "_pedit" ent_name "v" pline_satz "")
	  (while (/= (getvar "cmdactive") 0)
	    (command "x")
	  )
	  (setq pline_satz (ssget "_p"))
	  (if pline_satz
	    (if	(= anzahl (sslength pline_satz))
	      (setq n (1+ n))
	      (setq n 0)
	    )
	  )				;end if
	)
      )					;end if
    )					;end repeat
    (setq satz (ssget "l"))
    (setq f nil)
    (repeat (sslength satz)
      (princ "\r")
      (princ n)
      (princ "  ")
      (setq ent_data (entget (setq ent_name (ssname satz n))))
      (setq p_list (list))
      (setq bogen f)
      (foreach dat ent_data
	(if (= (car dat) 10)
	  (progn
	    (if	bogen
	      (rechne_bogen (car p_list) (cdr dat))
	    )
	    (setq p_list (cons (cdr dat) p_list))
	    (setq bogen f)
	  )
	)
	(if (= (car dat) 42)
	  (progn
	    (if	(/= (cdr dat) 0)
	      (setq bogen (cdr dat))
	      (setq bogen f)
	    )
	  )
	)
      )
      (if (= (rem (cdr (assoc 70 ent_data)) 2) 1)
	(if bogen
	  (rechne_bogen (car p_list) (car (reverse p_list)))
	)
      )
      (setq p_list (reverse p_list))
      (command "_mline")
      (foreach p p_list
	(command p)
      )
      (if (= (rem (cdr (assoc 70 ent_data)) 2) 1)
	(command "s")
      )
      (while (= (getvar "cmdactive") 1) (command ""))
      (entdel ent_name)
      (setq n (1- n))
    )
  )

  (vla-startundomark (k_ac-doc))
  (k_ofang "mem")
  (k_ofang "aus")
  (k_get_merkliste "k_ml-fillet-auflös")
  (if (null (setq k_ml-fillet-auflös (k_get_merkliste "k_ml-fillet-auflös"))
      )
    (progn
      (k_put_merkliste "k_ml-fillet-auflös" 1.0)
      (setq k_ml-fillet-auflös 1.0)
    )
  )
  (setq w_max (/ k_ml-fillet-auflös pi))
  (setq pic1 (k_ml-fillet_pic))
  (if pic1
    (progn
      (setq mline_name (nth 0 pic1))
      (setq mline_data (entget mline_name))
      (if (= (cdr (assoc 0 mline_data)) "MLINE")
	(progn
	  (setvar "cmlstyle" (cdr (assoc 2 mline_data)))
	  (setq px (nth 1 pic1))
	  (setq p (cdr (assoc 10 mline_data)))
	  (foreach data	mline_data
	    (if	(= (car data) 11)
	      (progn
		(if (< (distance (cdr data) px) (distance p px))
		  (setq p (cdr data))
		)
	      )
	    )
	  )
	  (setvar "clayer" (cdr (assoc 8 mline_data)))
	  (setq p_list (list))
	  (foreach dat mline_data
	    (if	(= (car dat) 11)
	      (setq p_list (cons (cdr dat) p_list))
	    )
	  )
	  (setq p_list (reverse p_list))
	  (command "_pline")
	  (foreach p p_list
	    (command p)
	  )
	  (if (= (cdr (assoc 71 mline_data)) 3)
	    (command "s")
	  )
	  (while (= (getvar "cmdactive") 1) (command ""))
	  (command "_explode" (entlast))
	  (setq satz (ssget "_p"))
	  (setq n (1- (sslength satz)))
	  (setq ent_list (list))
	  (repeat (sslength satz)
	    (setq ent_name (ssname satz n))
	    (setq ent_data (entget ent_name))
	    (if	(equal (cdr (assoc 10 ent_data)) p)
	      (setq ent_list (cons ent_name ent_list))
	    )
	    (if	(equal (cdr (assoc 11 ent_data)) p)
	      (setq ent_list (cons ent_name ent_list))
	    )
	    (setq n (1- n))
	  )
	  (if (= (length ent_list) 1)
	    (progn
	      (setq pic2 (k_ml-fillet_pic))
	      (if pic2
		(progn
		  (setq mline_name2 (nth 0 pic2))
		  (setq mline_data2 (entget mline_name2))
		  (if (= (cdr (assoc 0 mline_data2)) "MLINE")
		    (progn
		      (setvar "cmlstyle" (cdr (assoc 2 mline_data2)))
		      (setq px (nth 1 pic2))
		      (setq p (cdr (assoc 10 mline_data2)))
		      (foreach data mline_data2
			(if (= (car data) 11)
			  (progn
			    (if	(< (distance (cdr data) px)
				   (distance p px)
				)
			      (setq p (cdr data))
			    )
			  )
			)
		      )
		      (setvar "clayer" (cdr (assoc 8 mline_data2)))
		      (setq p_list (list))
		      (foreach dat mline_data2
			(if (= (car dat) 11)
			  (setq p_list (cons (cdr dat) p_list))
			)
		      )
		      (setq p_list (reverse p_list))
		      (command "_pline")
		      (foreach p p_list
			(command p)
		      )
		      (if (= (cdr (assoc 71 mline_data2)) 3)
			(command "s")
		      )
		      (while (= (getvar "cmdactive") 1) (command ""))
		      (command "_explode" (entlast))
		      (setq satz2 (ssget "_p"))
		      (setq n (1- (sslength satz2)))
		      (setq ent_list2 (list))
		      (repeat (sslength satz2)
			(setq ent_name (ssname satz2 n))
			(setq satz (ssadd ent_name satz))
			(setq ent_data (entget ent_name))
			(if (equal (cdr (assoc 10 ent_data)) p)
			  (setq ent_list2 (cons ent_name ent_list2))
			)
			(if (equal (cdr (assoc 11 ent_data)) p)
			  (setq ent_list2 (cons ent_name ent_list2))
			)
			(setq n (1- n))
		      )
		      (entdel mline_name)
		      (entdel mline_name2)
		      (command "_fillet"
			       (nth 0 ent_list)
			       (nth 0 ent_list2)
		      )
		      (setq satz (ssadd (entlast) satz))
		      (k_ml-fillet_mk_mline)
		    )
		  )
		)
	      )
	    )
	    (progn
	      (entdel mline_name)
	      (command "_fillet" (nth 0 ent_list) (nth 1 ent_list))
	      (setq satz (ssadd (entlast) satz))
	      (k_ml-fillet_mk_mline)
	    )
	  )
	)
      )
    )
  )
  (k_ofang "restore")
  (vla-endundomark (k_ac-doc))
  (princ)
)
;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_ml-fillet:  Multilinien abrunden"
    "\n===========  "
    "\n(C) Andreas Kraus 2022 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_ml-fillet\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)