;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_BLOCKSORT                                          - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  Blöcke nach Daten sortieren                                    - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_blocksort                                                    - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 22.09.2025                                                - ;
;;; -              durch : Andreas Kraus                                             - ;
;;; - ------------------------------------------------------------------------------ - ;

(vl-load-com)
(DEFUN COMPARE (E0 E1 /)
  (COND	((> (CAR E0) (CAR E1)) 1)
	((< (CAR E0) (CAR E1)) -1)
	((QUOTE T) 0)
  )
)
(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-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_DEL-NTH (LISTE N / DUMMY_LIST)
  (REPEAT N
    (SETQ DUMMY_LIST (CONS (CAR LISTE) DUMMY_LIST)
	  LISTE	     (CDR LISTE)
    )
  )
  (APPEND (REVERSE DUMMY_LIST) (CDR LISTE))
)
(DEFUN K_GET-TEXTSTRING	(ENT_NAME / ENT_DATA)
  (SETQ	ENT_DATA
	 (COND ((= (TYPE ENT_NAME) (QUOTE VLA-OBJECT))
		(ENTGET (vlax-vla-object->ename ENT_NAME))
	       )
	       ((= (TYPE ENT_NAME) (QUOTE ENAME)) (ENTGET ENT_NAME))
	       ((= (TYPE ENT_NAME) (QUOTE LIST)) ENT_NAME)
	 )
  )
  (WHILE (> (LENGTH (K_GET_ASSOC ENT_DATA 1)) 1)
    (SETQ
      ENT_DATA (K_DEL-NTH ENT_DATA
			  (VL-POSITION (ASSOC 1 ENT_DATA) ENT_DATA)
	       )
    )
  )
  (COND
    ((= (CDR (ASSOC 0 ENT_DATA)) "ATTDEF")
     (APPLY (QUOTE STRCAT)
	    (MAPCAR (QUOTE CDR)
		    (APPEND (K_GET_ASSOC ENT_DATA (QUOTE (1)))
			    (CDR (K_GET_ASSOC ENT_DATA (QUOTE (3))))
		    )
	    )
     )
    )
    ((MEMBER (CDR (ASSOC 0 ENT_DATA))
	     (QUOTE ("TEXT" "MTEXT" "ATTRIB"))
     )
     (APPLY (QUOTE STRCAT)
	    (MAPCAR (QUOTE CDR) (K_GET_ASSOC ENT_DATA (QUOTE (1 3))))
     )
    )
    ((MEMBER (CDR (ASSOC 0 ENT_DATA)) (QUOTE ("MULTILEADER")))
     (vla-get-TextString
       (vlax-ename->vla-object (CDR (ASSOC -1 ENT_DATA)))
     )
    )
    (T nil)
  )
)
(DEFUN K_GET_ASSOC (LISTE GRUPPE)
  (IF (/= (TYPE GRUPPE) (QUOTE LIST))
    (SETQ GRUPPE (LIST GRUPPE))
  )
  (VL-REMOVE-IF-NOT
    (QUOTE (LAMBDA (DATA) (MEMBER (CAR DATA) GRUPPE)))
    LISTE
  )
)
(DEFUN K_GET_DATA (OBJ_NAMEN BEZ APP_LIST ART)
  (DEFUN K_GET_DATA_WORK (OBJ_NAME  /	      ATT_LIST	DAT
			  DATA	    DATA_LIST DYN_LIST	ML_LIST
			  OBJ	    PROP      XDATA	XTYPE
			 )
    (IF	OBJ_NAME
      (PROGN
	(IF (= (TYPE APP_LIST) (QUOTE STR))
	  (SETQ APP_LIST (LIST APP_LIST))
	)
	(IF (= (TYPE ART) (QUOTE STR))
	  (SETQ ART (LIST ART))
	)
	(IF (= (TYPE OBJ_NAME) (QUOTE ENAME))
	  (SETQ OBJ_NAME (vlax-ename->vla-object OBJ_NAME))
	)
	(IF (AND (OR (NULL ART) (MEMBER "*" ART) (MEMBER "ATT" ART))
		 (L-CONJUNCTION
		   (IF (LISTP BEZ)
		     BEZ
		     (LIST BEZ)
		   )
		   (LIST "*" "ML-Beschreibung")
		 )
		 (= (vla-get-ObjectName OBJ_NAME) "AcDbMline")
	    )
	  (SETQ	ML_LIST
		 (LIST
		   (LIST "ML-Beschreibung"
			 (CDR (ASSOC 3
				     (DICTSEARCH
				       (CDR (ASSOC -1
						   (DICTSEARCH
						     (NAMEDOBJDICT)
						     "ACAD_MLINESTYLE"
						   )
					    )
				       )
				       (vla-get-StyleName OBJ_NAME)
				     )
			      )
			 )
		   )
		 )
	  )
	)
	(IF
	  (AND
	    (OR (NULL ART) (MEMBER "ATT" (MAPCAR (QUOTE STRCASE) ART)))
	    (vlax-property-available-p OBJ_NAME "hasattributes")
	    (= (vla-get-HasAttributes OBJ_NAME) :vlax-true)
	    (NOT
	      (MINUSP (vlax-safearray-get-u-bound
			(vlax-variant-value (vla-GetAttributes OBJ_NAME))
			1
		      )
	      )
	    )
	  )
	   (SETQ ATT_LIST
		  (MAPCAR (QUOTE (LAMBDA (OBJ)
				   (LIST (vla-get-TagString OBJ)
					 (K_GET-TEXTSTRING OBJ)
				   )
				 )
			  )
			  (vlax-invoke OBJ_NAME (QUOTE GETATTRIBUTES))
		  )
	   )
	)
	(IF
	  (AND
	    (OR (NULL ART) (MEMBER "DYN" (MAPCAR (QUOTE STRCASE) ART)))
	    (vlax-property-available-p OBJ_NAME "isdynamicblock")
	    (= (vla-get-IsDynamicBlock OBJ_NAME) :vlax-true)
	  )
	   (SETQ DYN_LIST
		  (VL-REMOVE
		    (QUOTE nil)
		    (MAPCAR
		      (QUOTE (LAMBDA (PROP)
			       (IF (= (vla-get-Show PROP) :vlax-true)
				 (LIST (vla-get-PropertyName PROP)
				       (vlax-variant-value
					 (vla-get-Value PROP)
				       )
				 )
			       )
			     )
		      )
		      (IF
			(VL-CATCH-ALL-ERROR-P
			  (VL-CATCH-ALL-APPLY
			    (QUOTE vlax-invoke)
			    (LIST OBJ_NAME
				  (QUOTE GETDYNAMICBLOCKPROPERTIES)
			    )
			  )
			)
			 nil
			 (vlax-invoke
			   OBJ_NAME
			   (QUOTE GETDYNAMICBLOCKPROPERTIES)
			 )
		      )
		    )
		  )
	   )
	)
	(IF
	  (AND
	    (OR (NULL ART) (MEMBER "EED" (MAPCAR (QUOTE STRCASE) ART)))
	    (MEMBER "*" APP_LIST)
	  )
	   (VLAX-FOR APP (vla-get-RegisteredApplications
			   (vla-get-Document OBJ_NAME)
			 )
	     (IF (AND (NOT (VL-CATCH-ALL-ERROR-P
			     (VL-CATCH-ALL-APPLY
			       (QUOTE vla-GetXData)
			       (LIST OBJ_NAME
				     (vla-get-Name APP)
				     (QUOTE XTYPE)
				     (QUOTE XDATA)
			       )
			     )
			   )
		      )
		      XTYPE
		      XDATA
		 )
	       (PROGN (vlax-safearray->list XTYPE)
		      (SETQ DATA_LIST
			     (APPEND
			       DATA_LIST
			       (VL-REMOVE-IF-NOT
				 (QUOTE
				   (LAMBDA (DATA)
				     (= (TYPE (CAR DATA)) (QUOTE STR))
				   )
				 )
				 (GATHER
				   (CDR
				     (MAPCAR (QUOTE vlax-variant-value)
					     (vlax-safearray->list XDATA)
				     )
				   )
				   2
				 )
			       )
			     )
		      )
	       )
	     )
	   )
	   (FOREACH APP	APP_LIST
	     (IF
	       (AND
		 (NOT (VL-CATCH-ALL-ERROR-P
			(VL-CATCH-ALL-APPLY
			  (QUOTE vla-GetXData)
			  (LIST OBJ_NAME APP (QUOTE XTYPE) (QUOTE XDATA))
			)
		      )
		 )
		 XTYPE
		 XDATA
	       )
		(PROGN (vlax-safearray->list XTYPE)
		       (SETQ DATA_LIST
			      (APPEND
				DATA_LIST
				(VL-REMOVE-IF-NOT
				  (QUOTE
				    (LAMBDA (DATA)
				      (= (TYPE (CAR DATA)) (QUOTE STR))
				    )
				  )
				  (GATHER
				    (CDR
				      (MAPCAR (QUOTE vlax-variant-value)
					      (vlax-safearray->list XDATA)
				      )
				    )
				    2
				  )
				)
			      )
		       )
		)
	     )
	   )
	)
	(COND
	  ((= (TYPE BEZ) (QUOTE STR))
	   (IF (= BEZ "*")
	     (PROGN
	       (SETQ DATA (APPEND ML_LIST ATT_LIST DATA_LIST DYN_LIST))
	     )
	     (PROGN (SETQ
		      DATA (COND
			     ((vlax-property-available-p OBJ_NAME BEZ)
			      (IF (VL-CATCH-ALL-ERROR-P
				    (SETQ DATA
					   (VL-CATCH-ALL-APPLY
					     (QUOTE getpropertyvalue)
					     (LIST (K_->ENT_NAME OBJ_NAME) BEZ)
					   )
				    )
				  )
				(SETQ DATA
				       (EVAL
					 (LIST (READ (STRCAT "vla-get-" BEZ))
					       OBJ_NAME
					 )
				       )
				)
				DATA
			      )
			     )
			     ((ASSOC BEZ ML_LIST)
			      (SETQ DATA (NTH 1 (ASSOC BEZ ML_LIST)))
			     )
			     ((ASSOC
				(STRCASE BEZ)
				(MAPCAR
				  (QUOTE
				    (LAMBDA (DAT)
				      (LIST (STRCASE (CAR DAT)) (CADR DAT))
				    )
				  )
				  ML_LIST
				)
			      )
			      (SETQ DATA
				     (NTH
				       1
				       (ASSOC
					 (STRCASE BEZ)
					 (MAPCAR
					   (QUOTE (LAMBDA (DAT)
						    (LIST (STRCASE (CAR DAT))
							  (CADR DAT)
						    )
						  )
					   )
					   ML_LIST
					 )
				       )
				     )
			      )
			     )
			     ((ASSOC BEZ DYN_LIST)
			      (SETQ DATA (NTH 1 (ASSOC BEZ DYN_LIST)))
			     )
			     ((ASSOC
				(STRCASE BEZ)
				(MAPCAR
				  (QUOTE
				    (LAMBDA (DAT)
				      (LIST (STRCASE (CAR DAT)) (CADR DAT))
				    )
				  )
				  DYN_LIST
				)
			      )
			      (SETQ DATA
				     (NTH
				       1
				       (ASSOC
					 (STRCASE BEZ)
					 (MAPCAR
					   (QUOTE (LAMBDA (DAT)
						    (LIST (STRCASE (CAR DAT))
							  (CADR DAT)
						    )
						  )
					   )
					   DYN_LIST
					 )
				       )
				     )
			      )
			     )
			     ((ASSOC BEZ ATT_LIST)
			      (SETQ DATA (NTH 1 (ASSOC BEZ ATT_LIST)))
			     )
			     ((ASSOC
				(STRCASE BEZ)
				(MAPCAR
				  (QUOTE
				    (LAMBDA (DAT)
				      (LIST (STRCASE (CAR DAT)) (CADR DAT))
				    )
				  )
				  ATT_LIST
				)
			      )
			      (SETQ DATA
				     (NTH
				       1
				       (ASSOC
					 (STRCASE BEZ)
					 (MAPCAR
					   (QUOTE (LAMBDA (DAT)
						    (LIST (STRCASE (CAR DAT))
							  (CADR DAT)
						    )
						  )
					   )
					   ATT_LIST
					 )
				       )
				     )
			      )
			     )
			     ((ASSOC BEZ DATA_LIST)
			      (SETQ DATA (NTH 1 (ASSOC BEZ DATA_LIST)))
			     )
			     ((ASSOC
				(STRCASE BEZ)
				(MAPCAR
				  (QUOTE
				    (LAMBDA (DAT)
				      (LIST (STRCASE (CAR DAT)) (CADR DAT))
				    )
				  )
				  DATA_LIST
				)
			      )
			      (SETQ DATA
				     (NTH
				       1
				       (ASSOC
					 (STRCASE BEZ)
					 (MAPCAR
					   (QUOTE (LAMBDA (DAT)
						    (LIST (STRCASE (CAR DAT))
							  (CADR DAT)
						    )
						  )
					   )
					   DATA_LIST
					 )
				       )
				     )
			      )
			     )
			   )
		    )
	     )
	   )
	  )
	  ((= (TYPE BEZ) (QUOTE LIST))
	   (SETQ DATA
		  (MAPCAR
		    (QUOTE
		      (LAMBDA (BEZ / DATA)
			(COND
			  ((vlax-property-available-p OBJ_NAME BEZ)
			   (IF (VL-CATCH-ALL-ERROR-P
				 (SETQ
				   DATA	(VL-CATCH-ALL-APPLY
					  (QUOTE getpropertyvalue)
					  (LIST	(K_->ENT_NAME OBJ_NAME)
						BEZ
					  )
					)
				 )
			       )
			     (SETQ
			       DATA (EVAL
				      (LIST
					(READ (STRCAT "vla-get-" BEZ))
					OBJ_NAME
				      )
				    )
			     )
			   )
			  )
			  ((ASSOC BEZ DYN_LIST)
			   (SETQ DATA (NTH 1 (ASSOC BEZ DYN_LIST)))
			  )
			  ((ASSOC
			     (STRCASE BEZ)
			     (MAPCAR
			       (QUOTE
				 (LAMBDA (DAT)
				   (LIST (STRCASE (CAR DAT)) (CADR DAT))
				 )
			       )
			       DYN_LIST
			     )
			   )
			   (SETQ DATA
				  (NTH 1
				       (ASSOC
					 (STRCASE BEZ)
					 (MAPCAR
					   (QUOTE
					     (LAMBDA (DAT)
					       (LIST (STRCASE (CAR DAT))
						     (CADR DAT)
					       )
					     )
					   )
					   DYN_LIST
					 )
				       )
				  )
			   )
			  )
			  ((ASSOC BEZ ATT_LIST)
			   (SETQ DATA (NTH 1 (ASSOC BEZ ATT_LIST)))
			  )
			  ((ASSOC
			     (STRCASE BEZ)
			     (MAPCAR
			       (QUOTE
				 (LAMBDA (DAT)
				   (LIST (STRCASE (CAR DAT)) (CADR DAT))
				 )
			       )
			       ATT_LIST
			     )
			   )
			   (SETQ DATA
				  (NTH 1
				       (ASSOC
					 (STRCASE BEZ)
					 (MAPCAR
					   (QUOTE
					     (LAMBDA (DAT)
					       (LIST (STRCASE (CAR DAT))
						     (CADR DAT)
					       )
					     )
					   )
					   ATT_LIST
					 )
				       )
				  )
			   )
			  )
			  ((ASSOC BEZ DATA_LIST)
			   (SETQ DATA (NTH 1 (ASSOC BEZ DATA_LIST)))
			  )
			  ((ASSOC
			     (STRCASE BEZ)
			     (MAPCAR
			       (QUOTE
				 (LAMBDA (DAT)
				   (LIST (STRCASE (CAR DAT)) (CADR DAT))
				 )
			       )
			       DATA_LIST
			     )
			   )
			   (SETQ DATA
				  (NTH 1
				       (ASSOC
					 (STRCASE BEZ)
					 (MAPCAR
					   (QUOTE
					     (LAMBDA (DAT)
					       (LIST (STRCASE (CAR DAT))
						     (CADR DAT)
					       )
					     )
					   )
					   DATA_LIST
					 )
				       )
				  )
			   )
			  )
			)
			(LIST BEZ DATA)
		      )
		    )
		    BEZ
		  )
	   )
	  )
	)
      )
      (SETQ DATA nil)
    )
    (FOREACH V (QUOTE (OBJ_NAME	ATT_LIST  DAT	    DATA      DATA_LIST
				DYN_LIST  ML_LIST   OBJ	      PROP
				XDATA	  XTYPE
			       )
	       )
      (SETQ V nil)
    )
    DATA
  )
  (COND	((LISTP OBJ_NAMEN)
	 (MAPCAR (QUOTE K_GET_DATA_WORK) OBJ_NAMEN)
	)
	((= (TYPE OBJ_NAMEN) (QUOTE PICKSET))
	 (MAPCAR (QUOTE K_GET_DATA_WORK) (K_SATZ->ENTLIST OBJ_NAMEN))
	)
	(T (K_GET_DATA_WORK OBJ_NAMEN))
  )
)
(DEFUN K_GET_MERKLISTE (NAME / WERT)
  (IF (ASSOC NAME K_MERKLISTE)
    (SETQ WERT (NTH 1 (ASSOC NAME K_MERKLISTE)))
  )
  WERT
)
(DEFUN K_GROUP_ENTLIST (LISTE	   PROP	      /		 DUMMY
			DUMMY_LIST FERTIG_LIST		 NAME
			PROP	   WORK	      WORK_LIST
		       )
  (DEFUN ENT-PROP (ENT) (EVAL PROP))
  (SETQ	WORK_LIST (MAPCAR (QUOTE (LAMBDA (NAME)
				   (LIST (K_->OBJ_NAME NAME)
					 (ENTGET (K_->ENT_NAME NAME))
					 NAME
				   )
				 )
			  )
			  LISTE
		  )
  )
  (SETQ	WORK_LIST (MAPCAR (QUOTE (LAMBDA (WORK)
				   (CONS (VL-CATCH-ALL-APPLY
					   (QUOTE ENT-PROP)
					   (LIST (NTH 0 WORK))
					 )
					 WORK
				   )
				 )
			  )
			  WORK_LIST
		  )
  )
  (WHILE WORK_LIST
    (SETQ DUMMY (CAR WORK_LIST))
    (SETQ DUMMY_LIST
	   (LIST
	     (CAR DUMMY)
	     (MAPCAR
	       (QUOTE LAST)
	       (VL-REMOVE-IF-NOT
		 (QUOTE
		   (LAMBDA (DATA) (EQUAL (CAR DATA) (CAR DUMMY)))
		 )
		 WORK_LIST
	       )
	     )
	   )
    )
    (SETQ WORK_LIST
	   (VL-REMOVE-IF
	     (QUOTE (LAMBDA (DATA) (EQUAL (CAR DATA) (CAR DUMMY))))
	     WORK_LIST
	   )
    )
    (SETQ FERTIG_LIST (CONS DUMMY_LIST FERTIG_LIST))
  )
  FERTIG_LIST
)
(DEFUN K_LISTE_ANZAHL (LISTE)
  (MAPCAR
    (QUOTE
      (LAMBDA (EINTRAG)
	(LIST EINTRAG
	      (LENGTH (VL-REMOVE-IF-NOT
			(QUOTE (LAMBDA (DUMMY) (EQUAL DUMMY EINTRAG)))
			LISTE
		      )
	      )
	)
      )
    )
    (K_PURGE_LIST LISTE)
  )
)
(DEFUN K_PURGE_LIST (LISTE / DUMMY_LIST)
  (WHILE LISTE
    (SETQ DUMMY_LIST (CONS (CAR LISTE) DUMMY_LIST)
	  LISTE	     (VL-REMOVE (CAR LISTE) LISTE)
    )
  )
  (REVERSE DUMMY_LIST)
)
(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_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_SORT-I	(LISTE FUNKTION)
  (SETQ	WORK_LISTE
	 (MAPCAR (QUOTE LIST)
		 LISTE
		 (K_ZAHLENREIHE (LENGTH LISTE))
	 )
  )
  (SETQ	STR_LIST (VL-REMOVE-IF-NOT
		   (QUOTE (LAMBDA (Q) (= (TYPE (CAR Q)) (QUOTE STR))))
		   WORK_LISTE
		 )
  )
  (SETQ	INT_LIST (VL-REMOVE-IF-NOT
		   (QUOTE (LAMBDA (Q) (= (TYPE (CAR Q)) (QUOTE INT))))
		   WORK_LISTE
		 )
  )
  (SETQ
    REAL_LIST (VL-REMOVE-IF-NOT
		(QUOTE (LAMBDA (Q) (= (TYPE (CAR Q)) (QUOTE REAL))))
		WORK_LISTE
	      )
  )
  (SETQ
    ZSTR_LIST (MAPCAR
		(QUOTE (LAMBDA (I) (NTH I ZSTR_LIST)))
		(VL-SORT-I
		  (MAPCAR
		    (QUOTE ATOF)
		    (MAPCAR (QUOTE CAR)
			    (SETQ
			      ZSTR_LIST	(VL-REMOVE-IF-NOT
					  (QUOTE (LAMBDA (Q)
						   (VL-STRING-SEARCH
						     (SUBSTR (CAR Q) 1 1)
						     "0123456789."
						   )
						 )
					  )
					  STR_LIST
					)
			    )
		    )
		  )
		  FUNKTION
		)
	      )
  )
  (MAPCAR
    (QUOTE CADR)
    (APPEND
      (MAPCAR (QUOTE
		(LAMBDA (I) (NTH I (L-2NDINHIBITION STR_LIST ZSTR_LIST)))
	      )
	      (VL-SORT-I
		(MAPCAR (QUOTE CAR) (L-2NDINHIBITION STR_LIST ZSTR_LIST))
		FUNKTION
	      )
      )
      ZSTR_LIST
      (MAPCAR (QUOTE (LAMBDA (I) (NTH I (APPEND INT_LIST REAL_LIST))))
	      (VL-SORT-I (MAPCAR (QUOTE CAR) (APPEND INT_LIST REAL_LIST))
			 FUNKTION
	      )
      )
    )
  )
)
(DEFUN K_ZAHLENREIHE (Z / N REIHE)
  (SETQ REIHE (LIST (1- (FIX Z))))
  (REPEAT (1- (FIX Z))
    (SETQ REIHE (CONS (1- (CAR REIHE)) REIHE))
  )
  REIHE
)
(DEFUN L-2NDINHIBITION (L0 L1 / CMP L2)
  (SETQ L0 (VL-SORT (MAKE-SORTABLE L0) (QUOTE _<)))
  (SETQ L1 (VL-SORT (MAKE-SORTABLE L1) (QUOTE _<)))
  (WHILE (AND L0 L1)
    (SETQ CMP (COMPARE (CAR L0) (CAR L1)))
    (COND ((= CMP -1)
	   (SETQ L2 (CONS (CDAR L0) L2)
		 L0 (CDR L0)
	   )
	  )
	  ((= CMP 1) (SETQ L1 (CDR L1)))
	  ((QUOTE T)
	   (SETQ L0 (CDR L0)
		 L1 (CDR L1)
	   )
	  )
    )
  )
  (APPEND L2 (MAPCAR (QUOTE CDR) L0))
)
(DEFUN L-CONJUNCTION (L0 L1 / CMP L2)
  (SETQ L0 (VL-SORT (MAKE-SORTABLE L0) (QUOTE _<)))
  (SETQ L1 (VL-SORT (MAKE-SORTABLE L1) (QUOTE _<)))
  (WHILE (AND L0 L1)
    (SETQ CMP (COMPARE (CAR L0) (CAR L1)))
    (COND ((= CMP -1) (SETQ L0 (CDR L0)))
	  ((= CMP 1) (SETQ L1 (CDR L1)))
	  ((QUOTE T)
	   (SETQ L2 (CONS (CDR (CAR L0)) L2)
		 L0 (CDR L0)
		 L1 (CDR L1)
	   )
	  )
    )
  )
  L2
)
(DEFUN MAKE-SORTABLE (L /)
  (MAPCAR (QUOTE (LAMBDA (E /) (CONS (VL-PRIN1-TO-STRING E) E)))
	  L
  )
)
(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 _< (E0 E1 /) (< (CAR E0) (CAR E1)))

(defun c:k_blocksort (/		  AUSWAHL_LIST		  BEZ
		      BEZ_LIST	  BEZ_LIST_GESAMT	  D
		      DATA_LIST	  DIST_MAX    DO	  ENT
		      ENTGRP_LIST ENT_LIST    ENT_NAME	  GRP
		      GRP_DO_LIST grp_temp    k_blocksort_ID
		      OK	  PX	      SORT	  S_LIST
		      X		  XY	      Y		  picpoint
		      x-pos	  y-pos
		     )
;;; Blöcke auf X- oder Y-Achse sortieren
  (defun k_blocksort_enddlg (wert)
    (setq xy (get_tile "xy"))
    (setq dist_max (atof (get_tile "dist-max")))
    (if	(/= (get_tile "x-pos") "")
      (setq x-pos (atof (get_tile "x-pos")))
      (setq x-pos nil)
    )
    (if	(/= (get_tile "y-pos") "")
      (setq y-pos (atof (get_tile "y-pos")))
      (setq y-pos nil)
    )
    (setq ok wert)
    (done_dialog wert)
  )

  (defun k_blocksort_bez_list ()
    (mode_tile "ändern" 1)
    (if	(= $reason 4)
      (progn
	(setq bez	   (nth (atoi (get_tile "bez_list")) bez_list)
	      auswahl_list
			   (append
			     auswahl_list
			     (list (list bez (get_tile "dist-obj") (get_tile "dist-grp"))
			     )
			   )
	      bez_list	   (vl-remove-if
			     '(lambda (bez) (assoc bez auswahl_list))
			     bez_list_gesamt
			   )
	)
	(start_list "bez_list")
	(mapcar 'add_list bez_list)
	(end_list)
	(start_list "auswahl_list")
	(mapcar 'add_list (mapcar 'vl-princ-to-string auswahl_list))
	(end_list)
      )
    )
  )

  (defun k_blocksort_auswahl_list ()
    (setq bez (nth (atoi (get_tile "auswahl_list")) auswahl_list))
    (if	(= $reason 4)
      (progn
	(mode_tile "ändern" 1)
	(setq
	  auswahl_list (vl-remove bez auswahl_list)
	  bez_list     (vl-remove-if
			 '(lambda (bez) (assoc bez auswahl_list))
			 bez_list_gesamt
		       )
	)
	(start_list "bez_list")
	(mapcar 'add_list bez_list)
	(end_list)
	(start_list "auswahl_list")
	(mapcar 'add_list (mapcar 'vl-princ-to-string auswahl_list))
	(end_list)
      )
      (progn
	(set_tile "dist-obj" (cadr bez))
	(set_tile "dist-grp" (caddr bez))
	(mode_tile "ändern" 0)
      )
    )
  )

  (defun k_blocksort_ändern ()
    (setq bez (nth (atoi (get_tile "auswahl_list")) auswahl_list))
    (setq auswahl_list
	   (subst (list	(car bez)
			(get_tile "dist-obj")
			(get_tile "dist-grp")
		  )
		  bez
		  auswahl_list
	   )
    )
    (start_list "auswahl_list")
    (mapcar 'add_list (mapcar 'vl-princ-to-string auswahl_list))
    (end_list)
  )

  (defun k_blocksort_sort (e_list auswahl_list sort / fertig)
    (if	auswahl_list
      (setq sort	 (car auswahl_list)
	    auswahl_list (cdr auswahl_list)
      )
      (setq fertig t)
    )

;;; Daten für entsprechenden Eintrag auslesen
    (setq s_list (mapcar '(lambda (ent_name)
			    (k_get_data ent_name (car sort) "*" nil)
			  )
			 e_list
		 )
    )

;;; wenn Daten mehrfach vorkommen dann gruppieren
    (if	(or fertig
	    (vl-every '(lambda (n) (= n 1))
		      (mapcar 'cadr (k_liste_anzahl s_list))
	    )
	    (= (last sort) "")
	    (= (last sort) "0")
	)
      (list (nth 1 sort)
	    (mapcar
	      '(lambda (i) (nth i e_list))
	      (k_sort-i	(mapcar	'(lambda (ent)
				   (vl-princ-to-string
				     (k_get_data ent (car sort) "*" nil)
				   )
				 )
				e_list
			)
			'<
	      )
	    )
      )
      (list
	(nth 2 sort)
	(mapcar
	  '(lambda (grp) (k_blocksort_sort grp auswahl_list sort))
	  (mapcar
	    'cadr
	    (mapcar
	      '(lambda (i) (nth i grp_temp))
	      (k_sort-i
		(mapcar	'car
			(setq
			  grp_temp (k_group_entlist
				     e_list
				     '(k_get_data ent (car sort) "*" nil)
				   )
			)
		)
		'<
	      )
	    )
	  )
	)
      )
    )
  )

  (defun k_blocksort_do	(do_list / d)
;;; Objekte neu positionieren
    (setq d (car do_list))
    (setq do (cadr do_list))
;;; Objekte oder Objektgruppen positionieren
    (if	(= (type (car do)) 'ENAME)
;;; wenn Objekt, dann neu positonieren
      (foreach obj (mapcar 'k_->obj_name do)
	(vla-move obj
		  (vla-get-insertionpoint obj)
		  (VLAX-3D-POINT px)
	)
	(setq px
	       (cond
		 ((= xy "x")
		  (mapcar '+ px (list (atof d) 0 0))
		 )
		 ((= xy "-x")
		  (mapcar '- px (list (atof d) 0 0))
		 )
		 ((= xy "y")
		  (mapcar '+ px (list 0 (atof d) 0))
		 )
		 ((= xy "-y")
		  (mapcar '- px (list 0 (atof d) 0))
		 )
	       )
	)
      )
;;; wenn Objektgruppe, dann zuerst deren Positopn ermitteln
      (foreach do_temp do
	(k_blocksort_do do_temp)
	(setq px
	       (cond
		 ((= xy "x")
		  (mapcar '+ px (list (atof d) 0 0))
		 )
		 ((= xy "-x")
		  (mapcar '- px (list (atof d) 0 0))
		 )
		 ((= xy "y")
		  (mapcar '+ px (list 0 (atof d) 0))
		 )
		 ((= xy "-y")
		  (mapcar '- px (list 0 (atof d) 0))
		 )
	       )
	)
      )
    )
  )

  (defun k_blocksort_xy	()
    (setq xy (get_tile "xy"))
    (cond
      ((or (= xy "x") (= xy "-x"))
       (mode_tile "x-pos" 0)
       (mode_tile "y-pos" 1)
      )
      ((or (= xy "y") (= xy "-y"))
       (mode_tile "x-pos" 1)
       (mode_tile "y-pos" 0)
      )
    )
  )

  (vla-startundomark (k_ac-doc))
  (if (setq ent_list (k_satz->entlist (ssget '((0 . "INSERT")))))
    (progn
      (setq
	data_list	(mapcar
			  '(lambda (ent_name)
			     (list
			       (cons "data" (k_get_data ent_name "*" "*" nil))
			       '("dist" 0)
			       (assoc 10 (entget ent_name))
			       (list "ent_name" ent_name)
			     )
			   )
			  ent_list
			)
	bez_list_gesamt
			(k_purge_list
			  (mapcar 'car (apply 'append (mapcar 'cdar data_list)))
			)
	bez_list	bez_list_gesamt
	app_list	(acad_strlsort
			  (mapcar 'vla-get-name
				  (k_collection->list
				    (vla-get-registeredapplications
				      (k_ac-doc)
				    )
				  )
			  )
			)
	achse		'(0 0)
	xy		"x"
	dist_max	(* (car (getvar "snapunit")) 5.0)
      )
      (if (setq merk_list (k_get_merkliste "k_blocksort"))
	(setq auswahl_list
			   (vl-remove-if-not
			     '(lambda (data)
				(member (car data) bez_list)
			      )
			     (nth 0 merk_list)
			   )
	      dist_max	   (nth 1 merk_list)
	      xy	   (nth 2 merk_list)
	      bez_list	   (vl-remove-if
			     '(lambda (bez) (assoc bez auswahl_list))
			     bez_list_gesamt
			   )
	      x-pos	   (nth 3 merk_list)
	      y-pos	   (nth 4 merk_list)
	)
      )
;;;
      (setq k_blocksort_id (load_dialog "k_blocksort.dcl"))
      (setq ok 2)
      (while (> ok 1)
	(if (not (new_dialog "k_blocksort" k_blocksort_id))
	  (exit)
	)
	(foreach trenner '("linie01" "linie02" "linie03")
	  (start_image trenner)
	  (fill_image
	    0
	    0
	    (dimx_tile trenner)
	    (dimy_tile trenner)
	    -15
	  )
	  (if (< (dimx_tile trenner) (dimy_tile trenner))
	    (vector_image
	      (fix (/ (dimx_tile trenner) 2.0))
	      0
	      (fix (/ (dimx_tile trenner) 2.0))
	      (dimy_tile trenner)
	      253
	    )
	    (vector_image
	      0
	      (fix (/ (dimy_tile trenner) 2.0))
	      (dimx_tile trenner)
	      (fix (/ (dimy_tile trenner) 2.0))
	      253
	    )
	  )
	  (end_image)
	)

	(set_tile "dist-obj" (rtos (car (getvar "snapunit"))))
	(set_tile "dist-grp"
		  (rtos (* (car (getvar "snapunit")) 2.0))
	)
	(if x-pos
	  (set_tile "x-pos" (vl-prin1-to-string x-pos))
	)
	(if y-pos
	  (set_tile "y-pos" (vl-prin1-to-string y-pos))
	)
	(action_tile "bez_list" "(k_blocksort_bez_list)")
	(action_tile "auswahl_list" "(k_blocksort_auswahl_list)")
	(action_tile "ändern" "(k_blocksort_ändern)")
	(action_tile "pic" "(k_blocksort_enddlg '2)")
	(action_tile "xy" "(k_blocksort_xy)")
	(mode_tile "ändern" 1)

	(start_list "applist")
	(mapcar 'add_list app_list)
	(end_list)

	(if (= (type picpoint) 'LIST)
	  (progn
	    (set_tile "x-pos" (rtos (car picpoint)))
	    (set_tile "y-pos" (rtos (cadr picpoint)))
	  )
	)

	(action_tile "accept" "(k_blocksort_enddlg '1)")
	(action_tile "cancel" "(k_blocksort_enddlg '0)")

	(set_tile "dist-max" (rtos dist_max))
	(set_tile "xy" xy)

	(cond
	  ((or (= xy "x") (= xy "-x"))
	   (mode_tile "x-pos" 0)
	   (mode_tile "y-pos" 1)
	  )
	  ((or (= xy "y") (= xy "-y"))
	   (mode_tile "x-pos" 1)
	   (mode_tile "y-pos" 0)
	  )
	)

	(start_list "bez_list")
	(mapcar 'add_list bez_list)
	(end_list)

	(start_list "auswahl_list")
	(mapcar 'add_list (mapcar 'vl-princ-to-string auswahl_list))
	(end_list)

	(start_dialog)

	(if (= ok 2)
	  (setq picpoint (getpoint))
	)
      )

      (unload_dialog k_blocksort_id)

      (if (and (= ok 1) auswahl_list)
	(progn
	  (k_put_merkliste
	    "k_blocksort"
	    (list auswahl_list dist_max xy x-pos y-pos)
	  )
;;; Auswahl in einzelne Zeilen bzw. Spalten aufteilen
	  (if (> dist_max 0.0)
	    (cond
	      ((or (= xy "x") (= xy "-x"))
	       (while ent_list
		 (setq y
			(apply
			  'min
			  (mapcar
			    '(lambda (ent) (caddr (assoc 10 (entget ent))))
			    ent_list
			  )
			)
		 )
		 (setq entgrp_list
			(cons
			  (vl-remove-if-not
			    '(lambda (ent)
			       (> dist_max
				  (abs (- y (caddr (assoc 10 (entget ent)))))
			       )
			     )
			    ent_list
			  )
			  entgrp_list
			)
		 )
		 (setq ent_list
			(vl-remove-if
			  '(lambda (ent)
			     (>	dist_max
				(abs
				  (- y
				     (caddr (assoc 10 (entget ent)))
				  )
				)
			     )
			   )
			  ent_list
			)
		 )
	       )
	      )
	      ((or (= xy "y") (= xy "-y"))
	       (while ent_list
		 (setq x
			(apply
			  'min
			  (mapcar
			    '(lambda (ent) (cadr (assoc 10 (entget ent))))
			    ent_list
			  )
			)
		 )
		 (setq entgrp_list
			(cons
			  (vl-remove-if-not
			    '(lambda (ent)
			       (> dist_max
				  (abs (- x (cadr (assoc 10 (entget ent)))))
			       )
			     )
			    ent_list
			  )
			  entgrp_list
			)
		 )
		 (setq ent_list
			(vl-remove-if
			  '(lambda (ent)
			     (>
			       dist_max
			       (abs (- x
				       (cadr (assoc 10 (entget ent)))
				    )
			       )
			     )
			   )
			  ent_list
			)
		 )
	       )
	      )
	    )
	    (setq entgrp_list (list ent_list))
	  )
;;;(setq ent_list (nth 0 entgrp_list))
	  (foreach ent_list entgrp_list
;;; rekursiv sortieren
	    (setq grp_do_list
		   (k_blocksort_sort ent_list auswahl_list nil)
	    )
;;; Startpunkt für Elementliste
	    (cond
	      ((= xy "x")
	       (setq px
		      (car
			(vl-sort
			  (mapcar
			    '(lambda (ent) (cdr (assoc 10 (entget ent))))
			    ent_list
			  )
			  '(lambda (p1 p2) (< (car p1) (car p2)))
			)
		      )
	       )
	       (if x-pos
		 (setq px (list x-pos (cadr px)))
	       )
	      )
	      ((= xy "-x")
	       (setq px
		      (car
			(vl-sort
			  (mapcar
			    '(lambda (ent) (cdr (assoc 10 (entget ent))))
			    ent_list
			  )
			  '(lambda (p1 p2) (> (car p1) (car p2)))
			)
		      )
	       )
	       (if x-pos
		 (setq px (list x-pos (cadr px)))
	       )
	      )
	      ((= xy "y")
	       (setq px
		      (car
			(vl-sort
			  (mapcar
			    '(lambda (ent) (cdr (assoc 10 (entget ent))))
			    ent_list
			  )
			  '(lambda (p1 p2) (< (cadr p1) (cadr p2)))
			)
		      )
	       )
	       (if y-pos
		 (setq px (list (car px) y-pos))
	       )
	      )
	      ((= xy "-y")
	       (setq px
		      (car
			(vl-sort
			  (mapcar
			    '(lambda (ent) (cdr (assoc 10 (entget ent))))
			    ent_list
			  )
			  '(lambda (p1 p2) (> (cadr p1) (cadr p2)))
			)
		      )
	       )
	       (if y-pos
		 (setq px (list (car px) y-pos))
	       )
	      )
	    )
;;; Bearbeitung
	    (k_blocksort_do grp_do_list)
	  )
	)
      )
    )
  )
  (vla-endundomark (k_ac-doc))
  (princ)
)
;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_blocksort:  Blöcke nach Daten sortieren"
    "\n===========  "
    "\n(C) Andreas Kraus 2024 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_blocksort\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)