;;; - ------------------------------------------------------------------------------ - ;
;;; -                 T O O L - K_DIMCHAIN                                           - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung :  Bemaßungen zu Maßketten konvertieren                           - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle      :  k_dimchain                                                     - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 28.05.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 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_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_LAYLOCK? (OBJ)
  (K_IS	(vla-get-Lock
	  (vla-Item (vla-get-Layers (K_AC-DOC))
		    (vla-get-Layer (K_->OBJ_NAME OBJ))
	  )
	)
  )
)
(DEFUN K_LISTCOUNT (LISTE / DUMMY)
  (WHILE LISTE
    (SETQ DUMMY
	   (CONS
	     (LIST (CAR LISTE)
		   (LENGTH (VL-REMOVE-IF-NOT
			     (QUOTE (LAMBDA (Q) (EQUAL Q (CAR LISTE))))
			     LISTE
			   )
		   )
	     )
	     DUMMY
	   )
    )
    (SETQ LISTE (VL-REMOVE (CAR LISTE) LISTE))
  )
  (REVERSE DUMMY)
)
(DEFUN K_PURGEX_LIST (LISTE / DUMMY_LIST)
  (SETQ
    LISTE (MAPCAR
	    (QUOTE
	      (LAMBDA (DUMMY) (LIST (VL-PRINC-TO-STRING DUMMY) DUMMY))
	    )
	    LISTE
	  )
  )
  (WHILE LISTE
    (SETQ DUMMY_LIST (CONS (CADAR LISTE) DUMMY_LIST)
	  LISTE	     (VL-REMOVE-IF
		       (QUOTE (LAMBDA (DUMMY) (EQUAL (CAR DUMMY) (CAAR LISTE))))
		       LISTE
		     )
    )
  )
  (REVERSE DUMMY_LIST)
)
(DEFUN K_RUNDEN	(NUM PREC)
  (IF (ZEROP PREC)
    NUM
    (IF	(MEMBER (TYPE NUM) (QUOTE (INT REAL)))
      (* PREC
	 (FIX (IF (MINUSP NUM)
		(- (/ NUM PREC) 0.5)
		(+ (/ NUM PREC) 0.5)
	      )
	 )
      )
      NUM
    )
  )
)
(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 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 MAKE-SORTABLE (L /)
  (MAPCAR (QUOTE (LAMBDA (E /) (CONS (VL-PRIN1-TO-STRING E) E)))
	  L
  )
)
(DEFUN _< (E0 E1 /) (< (CAR E0) (CAR E1)))

(defun c:k_dimchain (/		 ent_list    a_list	 grp_list
		     grp	 achs_list   achse	 achs_grp
		     dim_start_list	     dim_line_list
		     linepos	 p1	     p2		 ent_data
		     neu_dim
		    )
  (vla-startundomark (k_ac-doc))
					; aus einzelnen Bemaßungen Kettenbemaßung machen
  (setq	ent_list (vl-remove-if
		   'k_laylock?
		   (k_satz->entlist (ssget '((0 . "DIMENSION"))))
		 )
  )
					;Winkel liste
  (setq	a_list (k_purgex_list
		 (mapcar '(lambda (ent_data)
			    (rem (angle	(cdr (assoc 14 ent_data))
					(cdr (assoc 10 ent_data))
				 )
				 pi
			    )
			  )
			 (mapcar 'entget ent_list)
		 )
	       )
  )
					;gruppieren
  (setq	grp_list
	 (mapcar '(lambda (a)
		    (vl-remove-if-not
		      '(lambda (ent_data)

			 (equal	(rem (angle (cdr (assoc 14 ent_data))
					    (cdr (assoc 10 ent_data))
				     )
				     pi
				)
				a
				0.0000001
			 )
		       )
		      (mapcar 'entget ent_list)
		    )
		  )
		 a_list
	 )
  )
					; Gruppen mit nur einem Element entfernen
  (setq	grp_list
	 (vl-remove-if '(lambda (grp) (= (length grp) 1)) grp_list)
  )

					;gruppieren nach gemeinsamem Startpunkt und Richtung
  (foreach grp grp_list
					; Bezugsachsen ermitteln und nach Richtung der Bemaßungen sortiert in Liste
    (setq achs_list
	   (k_listcount
	     (apply
	       'append
	       (mapcar
		 '(lambda (ent_data)
		    (setq a (rem (angle	(cdr (assoc 14 ent_data))
					(cdr (assoc 10 ent_data))
				 )
				 pi
			    )
		    )
		    (list
		      (list
			(mapcar
			  '(lambda (q) (k_runden q 0.0000001))
			  (inters
			    (cdr (assoc 13 ent_data))
			    (polar (cdr (assoc 13 ent_data)) a 1)
			    '(0 0)
			    (polar '(0 0) (+ a (/ pi 2.0)) 1)
			    nil
			  )
			)
			(k_runden a 0.0000001)
			(k_runden
			  (angle
			    (cdr (assoc 13 ent_data))
			    (inters
			      (cdr (assoc 13 ent_data))
			      (polar (cdr (assoc 13 ent_data))
				     (+ a (/ pi 2.0))
				     1
			      )
			      (cdr (assoc 14 ent_data))
			      (polar (cdr (assoc 14 ent_data)) a 1)
			      nil
			    )
			  )
			  0.0000001
			)
		      )
		      (list
			(mapcar
			  '(lambda (q) (k_runden q 0.0000001))
			  (inters
			    (cdr (assoc 14 ent_data))
			    (polar (cdr (assoc 14 ent_data)) a 1)
			    '(0 0)
			    (polar '(0 0) (+ a (/ pi 2.0)) 1)
			    nil
			  )
			)
			(k_runden a 0.0000001)
			(k_runden
			  (angle
			    (cdr (assoc 14 ent_data))
			    (inters
			      (cdr (assoc 14 ent_data))
			      (polar (cdr (assoc 14 ent_data))
				     (+ a (/ pi 2.0))
				     1
			      )
			      (cdr (assoc 13 ent_data))
			      (polar (cdr (assoc 13 ent_data)) a 1)
			      nil
			    )
			  )
			  0.0000001
			)
		      )
		    )
		  )
		 grp
	       )
	     )
	   )
    )
    (setq achs_list (vl-remove-if
		      '(lambda (dummy) (= (cadr dummy) 1))
		      achs_list
		    )
    )
    (setq achs_list (vl-sort achs_list
			     '(lambda (q1 q2) (> (last q1) (last q2)))
		    )
    )
					;jede gefundene Bezugsachse bearbeiten
    (foreach achse achs_list
					; Elemente finden
      (setq achs_grp
	     (vl-remove-if-not
	       '(lambda	(ent_data)
		  (setq	a (rem (angle (cdr (assoc 14 ent_data))
				      (cdr (assoc 10 ent_data))
			       )
			       pi
			  )
		  )
		  (or (equal
			(car achse)
			(list
			  (mapcar
			    '(lambda (q) (k_runden q 0.0000001))
			    (inters
			      (cdr (assoc 13 ent_data))
			      (polar (cdr (assoc 13 ent_data)) a 1)
			      '(0 0)
			      (polar '(0 0) (+ a (/ pi 2.0)) 1)
			      nil
			    )
			  )
			  (k_runden a 0.0000001)
			  (k_runden
			    (angle
			      (cdr (assoc 13 ent_data))
			      (inters
				(cdr (assoc 13 ent_data))
				(polar (cdr (assoc 13 ent_data))
				       (+ a (/ pi 2.0))
				       1
				)
				(cdr (assoc 14 ent_data))
				(polar (cdr (assoc 14 ent_data)) a 1)
				nil
			      )
			    )
			    0.0000001
			  )
			)
		      )
		      (equal
			(car achse)
			(list
			  (mapcar
			    '(lambda (q) (k_runden q 0.0000001))
			    (inters
			      (cdr (assoc 14 ent_data))
			      (polar (cdr (assoc 14 ent_data)) a 1)
			      '(0 0)
			      (polar '(0 0) (+ a (/ pi 2.0)) 1)
			      nil
			    )
			  )
			  (k_runden a 0.0000001)
			  (k_runden
			    (angle
			      (cdr (assoc 14 ent_data))
			      (inters
				(cdr (assoc 14 ent_data))
				(polar (cdr (assoc 14 ent_data))
				       (+ a (/ pi 2.0))
				       1
				)
				(cdr (assoc 13 ent_data))
				(polar (cdr (assoc 13 ent_data)) a 1)
				nil
			      )
			    )
			    0.0000001
			  )
			)
		      )
		  )
		)
	       grp
	     )
      )
					;gefundene Elemente aus Gruppe entfernen
      (setq grp (l-2ndinhibition grp achs_grp))

					;gefundene Elemente bearbeiten

					;Bereich und Richtung
					;Schnittpunkte mit Bezugsachse
      (setq dim_start_list
	     (mapcar
	       '(lambda	(ent_data)
		  (car
		    (vl-remove
		      'nil
		      (list
			(inters
			  (polar (cdr (assoc 13 ent_data))
				 (nth 2 (car achse))
				 -1
			  )
			  (polar (cdr (assoc 13 ent_data))
				 (nth 2 (car achse))
				 1
			  )
			  (polar (nth 0 (car achse))
				 (nth 1 (car achse))
				 (* -1
				    (distance
				      (nth 0 (car achse))
				      (cdr (assoc 13 ent_data))
				    )
				 )
			  )
			  (polar
			    (nth 0 (car achse))
			    (nth 1 (car achse))
			    (distance (nth 0 (car achse))
				      (cdr (assoc 13 ent_data))
			    )
			  )
			  t
			)
			(inters
			  (polar (cdr (assoc 14 ent_data))
				 (nth 2 (car achse))
				 -1
			  )
			  (polar (cdr (assoc 14 ent_data))
				 (nth 2 (car achse))
				 1
			  )
			  (polar (nth 0 (car achse))
				 (nth 1 (car achse))
				 (* -1
				    (distance
				      (nth 0 (car achse))
				      (cdr (assoc 14 ent_data))
				    )
				 )
			  )
			  (polar
			    (nth 0 (car achse))
			    (nth 1 (car achse))
			    (distance (nth 0 (car achse))
				      (cdr (assoc 14 ent_data))
			    )
			  )
			  t
			)
		      )
		    )
		  )
		)
	       achs_grp
	     )
      )
      (setq dim_line_list
	     (vl-sort
	       (mapcar
		 '(lambda (ent_data)
		    (inters
		      (polar
			(cdr (assoc 10 ent_data))
			(nth 2 (car achse))
			(* -1
			   (distance (nth 0 (car achse))
				     (cdr (assoc 10 ent_data))
			   )
			)
		      )
		      (polar (cdr (assoc 10 ent_data))
			     (nth 2 (car achse))
			     (distance (nth 0 (car achse))
				       (cdr (assoc 10 ent_data))
			     )
		      )
		      (polar
			(nth 0 (car achse))
			(nth 1 (car achse))
			(* -1
			   (distance (nth 0 (car achse))
				     (cdr (assoc 10 ent_data))
			   )
			)
		      )
		      (polar (nth 0 (car achse))
			     (nth 1 (car achse))
			     (distance (nth 0 (car achse))
				       (cdr (assoc 10 ent_data))
			     )
		      )
		      t
		    )
		  )
		 achs_grp
	       )
	       '(lambda	(q1 q2)
		  (< (distance (nth 0 (car achse)) q1)
		     (distance (nth 0 (car achse)) q2)
		  )
		)
	     )
      )
					;Position der Maßlinien
      (if
	(car
	  (car
	    (vl-sort (k_listcount
		       (mapcar '(lambda	(start line)
				  (< (distance (nth 0 (car achse)) start)
				     (distance (nth 0 (car achse)) line)
				  )
				)
			       dim_start_list
			       dim_line_list
		       )
		     )
		     '(lambda (q1 q2) (> (cadr q1) (cadr q2)))
	    )
	  )
	)
	 (setq linepos (car dim_line_list))
	 (setq linepos (last dim_line_list))
      )
					;Bemaßungen nach Länge sortieren
      (setq achs_grp (vl-sort achs_grp
			      '(lambda (ent_data1 ent_data2)
				 (< (cdr (assoc 42 ent_data1))
				    (cdr (assoc 42 ent_data2))
				 )
			       )
		     )
      )

					;Bemaßungen editieren
      (setq p1 nil
	    p2 nil
      )
      (foreach ent_data	achs_grp
	(if (and p1 p2)
	  (if
	    (< (distance (nth 0 (car achse)) (cdr (assoc 13 ent_data)))
	       (distance (nth 0 (car achse)) (cdr (assoc 14 ent_data)))
	    )
	     (setq p1 p2
		   p2 (cdr (assoc 14 ent_data))
	     )
	     (setq p1 p2
		   p2 (cdr (assoc 13 ent_data))
	     )
	  )
	  (if
	    (< (distance (nth 0 (car achse)) (cdr (assoc 13 ent_data)))
	       (distance (nth 0 (car achse)) (cdr (assoc 14 ent_data)))
	    )
	     (setq p1 (cdr (assoc 13 ent_data))
		   p2 (cdr (assoc 14 ent_data))
	     )
	     (setq p1 (cdr (assoc 14 ent_data))
		   p2 (cdr (assoc 13 ent_data))
	     )
	  )
	)
	(if (> (distance p1 p2) 0)
	  (progn
	    (setq neu_dim (vla-AddDimRotated
			    (vla-get-block
			      (vla-get-activelayout (k_ac-doc))
			    )
			    (VLAX-3D-POINT p1)
			    (VLAX-3D-POINT p2)
			    (VLAX-3D-POINT linepos)
			    (nth 2 (car achse))
			  )
	    )
					;        (vlax-dump-object neu_dim)
	    (if	(equal (vla-get-Measurement neu_dim) 0 0.001)
	      (vla-delete neu_dim)
	    )
	  )
	)
	(vla-delete (k_->obj_name ent_data))
      )
    )
  )
  (princ)
  (vla-endundomark (k_ac-doc))
)

;;; - ------------------------------------------------------------------------------ - ;
(princ
  (strcat
    "\nk_dimchain:  Bemaßungen zu Maßketten konvertieren"
    "\n===========  "
    "\n(C) Andreas Kraus 2024 (info@kraus-cad.de)"
    "\nBefehlszeilenaufruf : k_dimchain\n"
  )
)
;;; - ------------------------------------------------------------------------------ - ;
(princ)
