;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_PL-CUTBLK                                          - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  Polylinien an Blöcken brechen                                  - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_pl-cutblk                                                    - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 19.08.2024                                                - ;
;;; -              durch : Andreas Kraus                                             - ;
;;; - ------------------------------------------------------------------------------ - ;

(vl-load-com)
(DEFUN GATHER (LST LEN)
  (COND	((NULL LST) nil)
	((> (LENGTH LST) LEN)
	 (CONS (N-CAR LEN LST) (GATHER (N-CDR LEN LST) LEN))
	)
	((QUOTE SONST) (LIST LST))
  )
)
(DEFUN K_->ENT_NAME (NAME)
  (COND	((= (TYPE NAME) (QUOTE ENAME)) NAME)
	((= (TYPE NAME) (QUOTE VLA-OBJECT))
	 (vlax-vla-object->ename NAME)
	)
	((= (TYPE NAME) (QUOTE STR)) (HANDENT NAME))
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC -1 NAME))
	 (CDR (ASSOC -1 NAME))
	)
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC 5 NAME))
	 (HANDENT (CDR (ASSOC 5 NAME)))
	)
  )
)
(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))
	)
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC -1 NAME))
	 (vlax-ename->vla-object (CDR (ASSOC -1 NAME)))
	)
	((AND (= (TYPE NAME) (QUOTE LIST)) (ASSOC 5 NAME))
	 (vlax-ename->vla-object (HANDENT (CDR (ASSOC 5 NAME))))
	)
  )
)
(DEFUN K_AC-BEREICH nil
  (COND	((= (GETVAR "tilemode") 1)
	 (vla-get-ActiveLayout (K_AC-DOC))
	)
	((AND (= (GETVAR "tilemode") 0) (= (GETVAR "cvport") 1))
	 (vla-get-ActiveLayout (K_AC-DOC))
	)
	((AND (= (GETVAR "tilemode") 0) (> (GETVAR "cvport") 1))
	 (vla-Item (vla-get-Layouts (K_AC-DOC)) "model")
	)
  )
)
(DEFUN K_AC-DOC	nil
  (vla-get-ActiveDocument (vlax-get-acad-object))
)
(DEFUN K_COLLECTION->LIST (COLLECTION / LISTE)
  (COND	((MEMBER "VLA-COLLECTION->LIST" (ATOMS-FAMILY 1))
	 (SETQ LISTE (VLA-COLLECTION->LIST COLLECTION))
	)
	((MEMBER "VLAX-FOR" (ATOMS-FAMILY 1))
	 (SETQ LISTE (LIST))
	 (VLAX-FOR DUMMY COLLECTION (SETQ LISTE (CONS DUMMY LISTE)))
	 (REVERSE LISTE)
	)
  )
  LISTE
)
(DEFUN K_COPYOBJECTS (OBJ_LIST QUELLE ZIEL RET / NEW_LIST)
  (IF (NULL QUELLE)
    (SETQ QUELLE (K_AC-DOC))
  )
  (COND	((= (TYPE OBJ_LIST) (QUOTE ENAME))
	 (SETQ OBJ_LIST (LIST (vlax-ename->vla-object OBJ_LIST)))
	)
	((= (TYPE OBJ_LIST) (QUOTE VLA-OBJECT))
	 (SETQ OBJ_LIST (LIST OBJ_LIST))
	)
	((= (TYPE OBJ_LIST) (QUOTE LIST))
	 (SETQ OBJ_LIST (MAPCAR (QUOTE K_->OBJ_NAME) OBJ_LIST))
	)
	(T nil)
  )
  (SETQ	OBJ_LIST (VL-REMOVE (QUOTE nil)
			    (MAPCAR (QUOTE
				      (LAMBDA (OBJ)
					(COND ((= (TYPE OBJ) (QUOTE ENAME)) (vlax-ename->vla-object OBJ))
					      ((= (TYPE OBJ) (QUOTE VLA-OBJECT)) OBJ)
					      (T nil)
					)
				      )
				    )
				    OBJ_LIST
			    )
		 )
  )
  (SETQ	NEW_LIST (VL-CATCH-ALL-APPLY
		   (QUOTE vlax-invoke)
		   (LIST QUELLE (QUOTE COPYOBJECTS) OBJ_LIST ZIEL)
		 )
  )
  (IF RET
    NEW_LIST
    nil
  )
)
(DEFUN K_FILTER	(OBJ_LIST FILTER_LIST)
  (IF (NOT (LISTP (CAR FILTER_LIST)))
    (SETQ FILTER_LIST (LIST FILTER_LIST))
  )
  (FOREACH FILTER FILTER_LIST
    (SETQ OBJ_LIST (VL-REMOVE-IF-NOT
		     (QUOTE
		       (LAMBDA (OBJ)
			 (IF (VL-CATCH-ALL-ERROR-P
			       (SETQ DUMMY (VL-CATCH-ALL-APPLY
					     (QUOTE EVAL)
					     (LIST
					       (LIST (READ (STRCAT "vla-get-" (VL-PRINC-TO-STRING (CAR FILTER))))
						     OBJ
					       )
					     )
					   )
			       )
			     )
			   nil
			   (EQUAL (K_VARIANT->VALUE
				    (EVAL
				      (LIST (READ (STRCAT "vla-get-" (VL-PRINC-TO-STRING (CAR FILTER))))
					    OBJ
				      )
				    )
				  )
				  (CADR FILTER)
			   )
			 )
		       )
		     )
		     OBJ_LIST
		   )
    )
  )
  OBJ_LIST
)
(DEFUN K_GET-DEF (OBJ_NAME FILE)
  (IF (NULL FILE)
    (SETQ FILE (K_AC-DOC))
  )
  (SETQ OBJ_NAME (K_->OBJ_NAME OBJ_NAME))
  (COND	((= (vla-get-ObjectName OBJ_NAME) "AcDbBlockReference")
	 (vla-Item (vla-get-Blocks FILE) (vla-get-Name OBJ_NAME))
	)
	((= (vla-get-ObjectName OBJ_NAME) "AcDbAttribute")
	 (CAR
	   (K_FILTER (K_COLLECTION->LIST
		       (vla-Item (vla-get-Blocks FILE)
				 (CDR
				   (ASSOC 2
					  (ENTGET (CDR (ASSOC 330 (ENTGET (K_->ENT_NAME OBJ_NAME)))))
				   )
				 )
		       )
		     )
		     (LIST "tagstring" (vla-get-TagString OBJ_NAME))
	   )
	 )
	)
	((= (vla-get-ObjectName OBJ_NAME) "AcDbMline")
	 (vla-Item (vla-Item (vla-get-Dictionaries FILE) "acad_mlinestyle")
		   (vla-get-StyleName OBJ_NAME)
	 )
	)
	(T nil)
  )
)
(DEFUN K_GET_MERKLISTE (NAME / WERT)
  (IF (ASSOC NAME K_MERKLISTE)
    (SETQ WERT (NTH 1 (ASSOC NAME K_MERKLISTE)))
  )
  WERT
)
(DEFUN K_IS (WERT)
  (COND	((= WERT :vlax-false) nil)
	((= WERT :vlax-true) T)
	((= WERT nil) nil)
	((= WERT T) T)
	((= WERT 1) T)
	((= WERT 0) nil)
	((= WERT "1") T)
	((= WERT "0") nil)
	((= (STRCASE WERT) "JA") T)
	((= (STRCASE WERT) "NEIN") nil)
  )
)
(DEFUN K_LASTOBJECTS (ENT / ENT_LIST)
  (SETQ ENT (K_->ENT_NAME ENT))
  (IF (NOT (EQUAL ENT (ENTLAST)))
    (PROGN (WHILE (NOT (EQUAL (SETQ ENT (ENTNEXT ENT)) (ENTLAST)))
	     (SETQ ENT_LIST (CONS ENT ENT_LIST))
	   )
	   (SETQ ENT_LIST (CONS ENT ENT_LIST))
	   (MAPCAR (QUOTE K_->OBJ_NAME) ENT_LIST)
    )
  )
)
(DEFUN K_MEM_LAYSTAT (/ LAYSTATLIST LAY)
  (SETQ	LAYSTATLIST
	 (MAPCAR (QUOTE	(LAMBDA	(LAY)
			  (LIST	(vla-get-Name LAY)
				(vla-get-LayerOn LAY)
				(vla-get-Freeze LAY)
				(vla-get-Lock LAY)
			  )
			)
		 )
		 (K_COLLECTION->LIST (vla-get-Layers (K_AC-DOC)))
	 )
  )
  (K_PUT_MERKLISTE
    "k_mem_laystat"
    (VL-REMOVE (QUOTE nil)
	       (CONS LAYSTATLIST (K_GET_MERKLISTE "k_mem_laystat"))
    )
  )
  (PRINC)
)
(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_RESTORE_VAR (VARLIST / K_SAVEVAR_LIST)
  (SETQ K_SAVEVAR_LIST (K_GET_MERKLISTE "k_savevar_list"))
  (IF (= VARLIST "*")
    (SETQ VARLIST (MAPCAR (QUOTE (LAMBDA (VAR) (NTH 0 VAR))) K_SAVEVAR_LIST))
  )
  (IF (= (TYPE VARLIST) (QUOTE STR))
    (SETQ VARLIST (LIST VARLIST))
  )
  (FOREACH VAR VARLIST
    (IF	(SETQ VAR (ASSOC VAR K_SAVEVAR_LIST))
      (SETVAR (NTH 0 VAR) (NTH 1 VAR))
    )
  )
)
(DEFUN K_RST_LAYSTAT (/ OBJ_NAME DAT)
  (SETVAR "cmdecho" 0)
  (FOREACH DAT (CAR (K_GET_MERKLISTE "k_mem_laystat"))
    (IF	(AND (TBLSEARCH "LAYER" (NTH 0 DAT))
	     (SETQ OBJ_NAME (vla-Item (vla-get-Layers (K_AC-DOC)) (NTH 0 DAT)))
	)
      (PROGN (vla-put-LayerOn OBJ_NAME (NTH 1 DAT))
	     (IF (/= (CAR DAT) (GETVAR "clayer"))
	       (vla-put-Freeze OBJ_NAME (NTH 2 DAT))
	     )
	     (vla-put-Lock OBJ_NAME (NTH 3 DAT))
      )
    )
  )
  (IF (CDR (K_GET_MERKLISTE "k_mem_laystat"))
    (K_PUT_MERKLISTE
      "k_mem_laystat"
      (CDR (K_GET_MERKLISTE "k_mem_laystat"))
    )
  )
  (PRINC)
)
(DEFUN K_SATZ->ENTLIST (SATZ)
  (IF (= (TYPE SATZ) (QUOTE PICKSET))
    (VL-REMOVE-IF-NOT
      (QUOTE (LAMBDA (DUMMY) (= (TYPE DUMMY) (QUOTE ENAME))))
      (MAPCAR (QUOTE CADR) (SSNAMEX SATZ))
    )
  )
)
(DEFUN K_SATZ->OBJLIST (SATZ)
  (MAPCAR (QUOTE vlax-ename->vla-object)
	  (K_SATZ->ENTLIST SATZ)
  )
)
(DEFUN K_SAVE_VAR (VARLIST / K_SAVEVAR_LIST)
  (SETQ K_SAVEVAR_LIST (K_GET_MERKLISTE "k_savevar_list"))
  (IF (= (TYPE VARLIST) (QUOTE STR))
    (SETQ VARLIST (LIST VARLIST))
  )
  (FOREACH VAR VARLIST
    (IF	(ASSOC VAR K_SAVEVAR_LIST)
      (SETQ K_SAVEVAR_LIST
	     (SUBST (LIST VAR (GETVAR VAR))
		    (ASSOC VAR K_SAVEVAR_LIST)
		    K_SAVEVAR_LIST
	     )
      )
      (SETQ K_SAVEVAR_LIST (CONS (LIST VAR (GETVAR VAR)) K_SAVEVAR_LIST))
    )
  )
  (K_PUT_MERKLISTE "k_savevar_list" K_SAVEVAR_LIST)
)
(DEFUN K_SSGET (TEXT FILTER / SATZ)
  (IF TEXT
    (PROGN (K_SAVE_VAR "NOMUTT")
	   (PRINC (STRCAT " " TEXT))
	   (SETVAR "NOMUTT" 1)
    )
  )
  (VL-CATCH-ALL-APPLY
    (LIST (QUOTE LAMBDA)
	  (QUOTE nil)
	  (QUOTE (SETQ SATZ (APPLY (QUOTE SSGET) FILTER)))
    )
  )
  (IF TEXT
    (K_RESTORE_VAR "NOMUTT")
  )
  SATZ
)
(DEFUN K_VARIANT->VALUE	(VAR / VALUE)
  (IF (= (TYPE VAR) (QUOTE variant))
    (PROGN (SETQ VALUE (vlax-variant-value VAR))
	   (COND ((= (TYPE VALUE) (QUOTE safearray))
		  (IF (MINUSP (vlax-safearray-get-u-bound VALUE 1))
		    nil
		    (vlax-safearray->list VALUE)
		  )
		 )
		 (T VALUE)
	   )
    )
    VAR
  )
)
(DEFUN N-CAR (N LST / RES)
  (REPEAT (MIN N (LENGTH LST))
    (SETQ RES (CONS (CAR LST) RES)
	  LST (CDR LST)
    )
  )
  (REVERSE RES)
)
(DEFUN N-CDR (N LST) (REPEAT N (SETQ LST (CDR LST))))

(defun c:k_pl-cutblk (/ DEF_NAME ENT_LAST INS INS_DATA INS_LIST INS_NAME INT_LIST LAY_LIST N	OBJ_LIST OBJ_NAME P1 P2	TEMP-NAME TEMP-OBJNAME TEMP_INS	TEMP_INS_LIST TEMP_OBJ TEMP_OBJLIST TEMP_OBJLIST_LIST)
  (if (setq obj_list (k_satz->objlist
		       (k_ssget	"Objekte zum Bearbeiten wählen : "
				'(((0 . "Arc,LINE,LWPOLYLINE")))
		       )
		     )
      )
    (progn
      (setvar "cmdecho" 0)
      (vla-startundomark (k_ac-doc))
      (setq lay_list (mapcar 'vla-get-name
			     (vl-remove-if
			       '(lambda (lay) (k_is (vla-get-lock lay)))
			       (k_collection->list (vla-get-layers (k_ac-doc)))
			     )
		     )
      )
      (setq obj_list (vl-remove-if-not
		       '(lambda (obj) (member (vla-get-layer obj) lay_list))
		       obj_list
		     )
      )
      (k_mem_laystat)
      (vlax-for	layer (vla-get-layers (k_ac-doc))
	(vla-put-lock layer :vlax-false)
      )
      (k_save_var '("cmdecho"))
      (if (not
	    (setq ins_list (k_satz->objlist
			     (k_ssget "Blöcke wählen oder ENTER für alle : "
				      (list (list '(0 . "INSERT")
						  (cons 410 (vla-get-name (k_ac-bereich)))
					    )
				      )
			     )
			   )
	    )
	  )
	(setq ins_list (k_satz->objlist
			 (ssget	"x"
				(list '(0 . "INSERT")
				      (cons 410 (vla-get-name (k_ac-bereich)))
				)
			 )
		       )
	)
      )
      (setq ins_list (vl-remove-if
		       '(lambda (ins) (> (vla-get-count (k_get-def ins nil)) 100))
		       ins_list
		     )
      )
      (print "Blöcke zur Schnittpunktermittlung vorbereiten")
      (setq n (length ins_list))
;;; temporäre Blöcke nur mit Geometrie einsetzen
;;; Elemente in Block kopieren
      (setq temp_ins_list
	     (mapcar '(lambda (ins)
			(princ (strcat "\r" (itoa (setq n (1- n))) "  "))
			(setq ins_data (entget (setq ins_name (k_->ent_name ins)))
			      def_name (k_get-def ins nil)
			)
			(entmake
			  (list
			    (cons 0 "BLOCK")
			    (cons 70 3)
			    (cons 2 "*U")
			    (cons 10 (k_variant->value (vla-get-Origin def_name)))
			  )
			)
			(setq temp-name (entmake (list (cons 0 "endblk"))))
			(foreach temp-objname (vl-remove-if
						'(lambda (obj)
						   (member (vla-get-objectname obj)
							   '("AcDbAttributeDefinition")
						   )
						 )
						(k_collection->list def_name)
					      )
			  (k_copyobjects
			    temp-objname
			    nil
			    (vla-item (vla-get-blocks (k_ac-doc)) temp-name)
			    nil
			  )
			)
;;; Block einsetzen
			(setq temp_ins (vla-insertblock
					 (vla-get-block (k_ac-bereich))
					 (VLAX-3D-POINT (cdr (assoc 10 ins_data)))
					 temp-name
					 (cdr (assoc 41 ins_data))
					 (cdr (assoc 42 ins_data))
					 (cdr (assoc 43 ins_data))
					 (cdr (assoc 50 ins_data))
				       )
			)
		      )
		     ins_list
	     )
      )
      (print "Objekte zur Schnittpunktermittlung erstellen")
      (setq n (length temp_ins_list))
;;; Blöcke sprengen und Objekte in Liste zur Verarbeitung
      (setq temp_objlist_list
	     (mapcar
	       '(lambda	(temp_ins)
		  (princ (strcat "\r" (itoa (setq n (1- n))) "  "))
		  (k_variant->value (vla-explode temp_ins))
		)
	       temp_ins_list
	     )
      )
      (foreach obj temp_ins_list
	(vla-delete obj)
      )
      (print)
;;; Liste durchlaufen bis alle Objekte und alle durch Bruch entstandene Objekte bearbeitet sind
      (while obj_list
	(setvar "cmdecho" 1)
	(princ (strcat "\r" (itoa (length obj_list)) "   "))
	(setvar "cmdecho" 0)
	(setq obj_name (car obj_list))
;;; Schnittpunkte checken
	(mapcar	'(lambda (temp_objlist)
		   (if (setq int_list (vl-sort (gather (apply 'append
							      (mapcar '(lambda (temp_obj)
									 (k_variant->value
									   (vlax-invoke-method
									     obj_name
									     'IntersectWith
									     temp_obj
									     acextendnone
									   )
									 )
								       )
								      temp_objlist
							      )
						       )
						       3
					       )
					       '(lambda	(q1 q2)
						  (< (VLAX-CURVE-GETdistATPOINT obj_name q1)
						     (VLAX-CURVE-GETdistATPOINT obj_name q2)
						  )
						)
				      )
		       )
		     (progn
		       (setq p1	      (car int_list)
			     p2	      (last int_list)
			     ent_last (entlast)
		       )
;;; brechen
		       (command-s "_break" (k_->ent_name obj_name) p1 p2)
		       (if (not (equal ent_last (entlast)))
			 (setq obj_list (append obj_list (k_lastobjects ent_last)))
		       )
		     )
		   )
		 )
		temp_objlist_list
	)
	(setq obj_list (vl-remove obj_name obj_list))
      )
;;; temporäre Objekte löschen
      (foreach obj (apply 'append temp_objlist_list)
	(vla-delete obj)
      )
      (k_restore_var '("cmdecho" "nomutt"))
      (k_rst_laystat)
      (vla-endundomark (k_ac-doc))
    )
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_pl-cutblk:  Polylinien an Blöcken brechen"
    "\n===========  "
    "\n(C) Andreas Kraus 2024 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_pl-cutblk\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)
