;PROFIL ***** STANDARDPROFILE ***** fuer ACAD2000 (06/11/01) *****
;
;   The following functions are included:
;   PROFIL   = Haupt-Funktion
;   PRNEW    = Insert Profiles into the drawing
;   PREDIT   = Edit previously inserted Profiles
;   PRREGEN  = Reset and Regenerating Profiles
;   PRSEARCH = Suchen von Profilen nach ihrer Nummer
;   PRFILE   = Export von Profildaten in ein CDF-File
;
;   In addition, the following functions will be used
;   by those listed above:
;   MSAVE    = Speichern alter Variablen
;   MREST    = Restore old variables
;   MY_ERR   = Replace error-handler
;   PRDINIT  = Setup Dimstyle
;   PRTINIT  = Setup Textstyle
;   PRHILI   = Highlight a Profile
;   PRLOLI   = DeHighlight a Profile
;   PRUPD    = Update the Profile-line
;   PRED1    = Edit a single Profile
;   PRMIRROR = Spiegeln (Rotation um 180 Grad)
;   PRZOOM   = Zoom in on current profile
; --------------------------------------------------------------------------
(defun profil (/ answ )

;;;-------------------------------------------------------------------------
;;; Modes Save/Restore and error handling
;;;-------------------------------------------------------------------------
(defun msave (a) 
   (setq mlist '())
   (repeat (length a) 
      (setq mlist (append mlist (list (list (car a) (getvar (car a))))))
      (setq a (cdr a))
   )
) 
(defun mrest () 
   (repeat (length mlist) 
      (setvar (caar mlist) (cadar mlist))
      (setq mlist (cdr mlist))
   )
   (if (not (= olddim (getvar "DIMSTYLE")))
      (command "_.DIM1" "_RESTORE" olddim)
   )
   (setq *error* old_err 
         SSDim    NIL PRDINIT  NIL PRNEW    NIL OLDDIM   NIL
         answ     NIL PRTINIT  NIL PREDIT   NIL MSAVE    NIL
         PrCurrHi NIL PRHILI   NIL PRUPD    NIL PRREGEN  NIL
         PRLOLI   NIL PRMIRROR NIL PRSEARCH NIL PRFILE   NIL
         EDlpt    NIL PRED1    NIL PRZOOM   NIL 
   )
) 
(defun my_err (str)
   (if (and (/= str "console break")
            (/= str "Function cancelled")
            (/= str "quit / exit abort")
      )
      (princ (strcat "\nError: " str))
   ) 
   (if PrCurrHi (prloli PrCurrHi))
   (mrest)
   (if ofh (close ofh))
   (princ)
)

;;;-------------------------------------------------------------------------
;;; The HighLight- and DeHighlight-Functions.
;;;   (used by Edit en Search)
;;;-------------------------------------------------------------------------
(defun prhili (pname)
   (if (not SelCol)
      (setq SelCol 1)
   )
   (setvar "DIMCLRD" SelCol)
   (setvar "DIMCLRE" SelCol)
   (setvar "DIMCLRT" SelCol)
   (setq PrCurrHi pname) ;; Set UpdatePossibility
   (command "_.DIM1" "_UPD" pname "" )
)
(defun prloli (pname)
   ;; First reset colours, or R13 starts to NAG !
   (setvar "DIMCLRD" 256) 
   (setvar "DIMCLRE" 256)
   (setvar "DIMCLRT" 256)
;   (command "_.DIM1" "_RESTORE" "PROFIL" )
   (setq rdim (entget pname))
   (setq rdim (subst (cons 3 "PROFIL") (assoc 3 rdim) rdim))
   (entmod rdim)
   (command "_.DIM1" "_UPD" pname "" )
   (setq PrCurrHi nil) ;; Clear UpdatePossibility
)

;;;-------------------------------------------------------------------------
;;; The Update Function.
;;;   (used by Edit en Regen)
;;;-------------------------------------------------------------------------
(defun prupd (ent / pdim pt1 pt2 pt3 ang prof)
   (setq pdim (entget ent))
   (setq pt1 (cdr (assoc 13 pdim)))
   (if (not (= 0 (caddr pt1))) 
      (setq pdim (subst 
         (cons 13 (list (car pt1)(cadr pt1) 0.0))
         (assoc 13 pdim) pdim))
   )
   (setq pt2 (cdr (assoc 14 pdim)))
   (if (not (= 0 (caddr pt2))) 
      (setq pdim (subst
         (cons 14 (list (car pt2)(cadr pt2) 0.0))
         (assoc 14 pdim) pdim))
   )
   (setq ang (angle pt1 pt2))
   (setq pdim (subst (cons 50 ang) (assoc 50 pdim) pdim))
   (setq pdim (subst (cons 53 ang) (assoc 53 pdim) pdim))
   (setq pdim (subst (cons 51 0.0) (assoc 51 pdim) pdim))
   (setq pt3 (list
      (/ (+ (car pt1)(car pt2)) 2)
      (/ (+ (cadr pt1)(cadr pt2)) 2)
      0.0
      ))
   (setq pdim (subst (cons 11 pt3) (assoc 11 pdim) pdim))
   (setq pdim (subst (cons 10 (polar pt1 (-(angle pt1 pt2) 1.570796) 0.0001))
                     (assoc 10 pdim) pdim))
   (setq prof (cdr (assoc 1 pdim)))
      
   (if (not (equal (cons 210 '(0.0 0.0 1.0)) (assoc 210 pdim)))
      (setq pdim (subst (cons 210 '(0.0 0.0 1.0)) (assoc 210 pdim) pdim))
   )
   (if (not (equal prof (itoa (atoi prof))))
      (progn
         (ai_beep)
         (princ (strcat "\n   <" prof "> is not a valid number"))
         (initget 1)
         (setq prof (getint "\nNew profilenumber: "))
         (setq pdim (subst (cons 1 (itoa prof)) (assoc 1 pdim) pdim))
      )
   )
   (entmod pdim)
)

;;;-------------------------------------------------------------------------
;;; The Dimstyle INIT-Function.
;;;-------------------------------------------------------------------------
(defun prdinit ()
   (if (tblsearch "DIMSTYLE" "PROFIL")
      (command "_.DIM1" "_RESTORE" "PROFIL")
      (progn ;; Else ...
         (setvar "DIMTAD" 0)       (setvar "DIMTVP" -0.9)
         (setvar "DIMTXT" 0.07)    (setvar "DIMGAP" -0.05)
         (setvar "DIMTIH" 0)       (setvar "DIMTOH" 0)
         (setvar "DIMEXE" 0.20)    (setvar "DIMEXO" 0)
         (setvar "DIMASZ" 0)       (setvar "DIMTOFL" 1)
         (setvar "DIMSE1" 0)       (setvar "DIMSE2" 0)
         (setvar "DIMCLRD" 256)    (setvar "DIMCLRT" 256)
         (setvar "DIMCLRE" 256)
         (princ "\n ... (Re)creating dimstyle for profiles ...")
         (command "_.DIM1" "_SAVE" "PROFIL")
         (princ " Done.")
      )
   )
)

(defun prtinit ()
   (if (tblsearch "STYLE" "ATT")
      (setvar "TEXTSTYLE" "ATT")
      (command "_.STYLE" "ATT" "TXT" "0" "0.7" "" "" "" "")
   )
)

;;;-------------------------------------------------------------------------
;;; The Zoom Function. Used by Edit & Search
;;;------------------------------------------------------------------------
(defun przoom (ent / zcen pr pt1 pt2 PrDSize ScrSize Corner)
   (setq pr (entget ent))
   (setq pt1 (trans (cdr (assoc 13 pr)) ent 1 ))
   (setq pt2 (trans (cdr (assoc 14 pr)) ent 1 ))
   (setq zcen ;; Centerpoint of Window
      (list
         (/ (+ (car pt1)(car pt2)) 2)
         (/ (+ (cadr pt1)(cadr pt2)) 2)
   )  )

   (setq PrDSize ;; Width,Height of Profileline
      (list 
         (* 2 (abs (- (car pt2)(car pt1))))
         (* 2 (abs (- (cadr pt2)(cadr pt1))))
   )  )
   (setq ScrSize (getvar "SCREENSIZE")) ;; Width,Height of Screen
   (if (< ;; Profile Wider then High ?
         (atan (cadr PrDSize)(car PrDSize)) 
         (atan (cadr ScrSize)(car ScrSize))
      )
      (setq vmag (* (car PrDSize) (/ (cadr ScrSize)(car ScrSize))))
      (setq vmag (cadr PrDSize))
   )
   (if (< vmag 2) (setq vmag 2) ) ;; End If

   (setq vmag (* vmag 2))
   ;; Check for Regeneration
   (setq PrDSize (List (/ (* vmag (/ (car ScrSize)(cadr ScrSize))) 2) (/ vmag 2)))
   (if (or (< (car (getvar "VSMIN")) (- (car zcen)(car PrDSize))
              (+ (car zcen)(car PrDSize)) (car (getvar "VSMAX")))
           (< (cadr (getvar "VSMIN")) (- (cadr zcen)(cadr PrDSize))
              (+ (cadr zcen)(cadr PrDSize)) (cadr (getvar "VSMAX")))
       ) ;; End Or
      (command "_.ZOOM" "_C" zcen vmag)
      (princ "\n** Requires a regen, cannot be transparent.")
   ) ;; End If
)

;;;-------------------------------------------------------------------------
;;; The SingleEdit Function.
;;;------------------------------------------------------------------------
(defun pred1 (ent / pr Left Right Prof txtpos tel)
   (setq pr (entget ent))
   (if EDlpt 
      (setq Left (trans EDlpt 1 0) EDlpt nil)
      (progn ;; Else ...
         (setq Left (trans (cdr (assoc 13 pr)) 0 1))
         (initget 32)
         (if (not (setq Left (getpoint Left (strcat "\nNeuer linker Punkt: "
                  (rtos (car Left)) "," (rtos (cadr Left)) ">: "))))
            (setq Left (cdr (assoc 13 pr)))
            (setq Left (trans Left 1 0))
         ) ;; End If
      ) ;; End progn
   )
   ;;; Subst new Left Point and update Dim
   (setq pr (subst (cons 13 Left) (assoc 13 pr) pr))
   (entmod pr)
   (if (not (prupd ent)) (alert "Could not update this profile"))
   
   (setq Right (trans (cdr (assoc 14 pr)) 0 1))
   (initget 32)
   (if (not (setq Right (getpoint Right (strcat "\nNeuer rechter Punkt: "
            (rtos (car Right)) "," (rtos (cadr Right)) ">: "))))
      (setq Right (cdr (assoc 14 pr)))
      (setq Right (trans Right 1 0))
   ) ;; End If
   ;;; Subst new Right Point and update Dim
   (setq pr (subst (cons 14 Right) (assoc 14 pr) pr))
   (entmod pr)
   (if (not (prupd ent)) (alert "Could not update this profile"))

   (if (not (setq Prof (getint (strcat "\nNeue Profilnummer: "
         (cdr (assoc 1 pr)) ">: "))))
      (setq Prof (atoi (cdr (assoc 1 pr))))
   ) ;; End If
   ;;; Subst new ProfNum and update Dim
   (setq pr (subst (cons 1 (itoa Prof)) (assoc 1 pr) pr))
   (entmod pr)
   (if (not (prupd ent)) (alert "Could not update this profile"))
)
;;;-------------------------------------------------------------------------
;;; The Mirror Function.
;;;------------------------------------------------------------------------
(defun prmirror ( ent / pr pt1 pt2 )
   (setq pr (entget ent))
   (setq pt1 (cdr (assoc 14 pr)))
   (setq pt2 (cdr (assoc 13 pr)))
   (setq pr (subst (cons 13 pt1)(assoc 13 pr) pr))
   (setq pr (subst (cons 14 pt2)(assoc 14 pr) pr))
   (entmod pr)
   (prupd ent)
)
;;;-------------------------------------------------------------------------
;;; The Insertion Function.
;;;------------------------------------------------------------------------
(defun prnew ( / pt1 pt2 pt3 prof ang)
   (setq pt1 (getpoint "\nLinker Punkt: "))
   (while pt1
      (initget 33)
      (setq pt2 (getpoint pt1 "\nRechter Punkt: "))
      (initget 4)
      (if (not (setq prof (getint "\nProfilnummer <0>: ")))
         (setq prof 0)
      ) ;; End if
      ;; Get DimLine Position as a point at 0.1 mm below the given
      ;; Start- end EndPoints of the Profile :
      ;; If DimLinePosition is exactly on line between the given
      ;; points then StartArrow and EndArrow will be drawn in a 
      ;; Non-Standard and unwanted manner.
      (setq ang (angle pt1 pt2))
      (setq pt3 (polar pt1 (- ang 1.570796) 0.0001))
      (command "_DIM1" "_ROT" ang pt1 pt2 "_A" ang pt3 prof)
      (prupd (entlast))

      (command "_.SELECT" SSDim (entlast) "")
      (setvar "LASTPOINT" pt2) ;; enable '@'-function
      (setq pt1 (getpoint "\nNaechstes Profil; Linker Punkt: "))
   )
)

;;;-------------------------------------------------------------------------
;;; The Edit Function.
;;;-------------------------------------------------------------------------
(defun predit (/ ent tel answ)
   (setq tel 0)
   (setq ent (ssname SSDim tel))
   (while ent
      (command "_.UNDO" "_GROUP")
      (prhili ent)
      (setq EDlpt (trans (cdr (assoc 13 (entget ent))) 0 1 ))
      (initget 32 "Zoom Mirror eXit Next Previous")
      (setq answ (getpoint EDlpt (strcat 
         "\nZoom/Mirror/Previous/Next/eXit\n   or <new left point: "
         (rtos (car EDlpt)) "," (rtos (cadr EDlpt)) ">: "))
      )
      (cond
         ((not answ)
            (pred1 ent)
            (prloli ent)
            (setq tel (1+ tel))
            (setq ent (ssname SSDim tel))
         )
         ((= (type answ) 'LIST)
            (setq EDlpt answ)
            (pred1 ent)
            (prloli ent)
            (setq tel (1+ tel))
            (setq ent (ssname SSDim tel))
         )
         ((= answ "Zoom")
            (przoom ent)
         )
         ((= answ "Mirror")
            (prmirror ent)
            (prloli ent)
            (setq tel (1+ tel))
            (setq ent (ssname SSDim tel))
         )
         ((= answ "Previous")
            (prloli ent)
            (setq tel (1- tel))
            (if (< tel 0) 
               (progn
                  (princ "\nNo previous Object.")
                  (setq tel 0)
               )
               (setq ent (ssname SSDim tel))
            )
         )            
         ((= answ "Next")
            (prloli ent)
            (setq tel (1+ tel))
            (setq ent (ssname SSDim tel))
         )            
         (T 
            (prloli ent)
            (setq ent nil)
         )
      ) ;;  End Cond
      (command "_.SELECT" SSDim "")
      (command "_.UNDO" "_END")
   ) ;; End While
)
;;;-------------------------------------------------------------------------
;;; The Regen Function.
;;;-------------------------------------------------------------------------
(defun prregen (/ tel ent)
   (setq tel 0)
   (setq ent (ssname SSDim tel))
   (while ent
      (prupd ent)
      (setq tel (1+ tel))
      (setq ent (ssname SSDim tel))
   )
)

;;;-------------------------------------------------------------------------
;;; The Search Function.
;;;-------------------------------------------------------------------------
(defun prsearch (/ answ lastmove nums el tel DimFound)
   (if (setq nums (getint "\nSuchen nach Nummer: "))
      (progn
         (setq tel 0 DimFound (ssadd))
         (setq el (ssname SSDim tel))
         (princ "\n")
         (while el
            (if (= (cdr (assoc 1 (entget el))) (itoa nums))
               (ssadd el DimFound)
            )
            (setq tel (1+ tel))
            (princ (strcat "\r" (itoa tel)))
            (setq el (ssname SSDim tel))
         )
         (if (> (sslength DimFound) 0)
            (progn
               (princ (strcat "\n   " (itoa (sslength DimFound)) " gefunden\n"))
               (setq tel 0 
                     answ "eXit"
                     lastmove "Next"
               )
               (setq el (ssname DimFound tel))
            )
            (progn
               (setq el nil)
               (princ (strcat "\n   Kein Profil mit Nummer " 
                              (itoa nums)))
            )
         ) ;; End if
      ) ;; End progn
      ( setq el nil) ;; Else ...
   ) ;; End if
   (while el
      (command "_.UNDO" "_GROUP")
      (prhili el)
      (initget "Zoom Mirror Edit Next Previous eXit")
      (if (not (setq answ (getkword (strcat 
            "\nZoom/Mirror/Edit/Previous/Next/eXit <"
            lastmove ">: "))))
         (setq answ lastmove)
      )
      (cond 
         ((= answ "Zoom") (przoom el))
         ((= answ "Mirror") 
            (prmirror el)
            (prloli el)
            (setq tel (1+ tel))
            (setq el (ssname DimFound tel))
         )
         ((= answ "Edit")
            (pred1 el)
            (prloli el)
            (setq tel (1+ tel))
            (setq el (ssname DimFound tel))
         )
         ((= answ "Next") 
            (prloli el)
            (setq tel (1+ tel))
            (setq el (ssname DimFound tel))
            (setq lastmove "Next")
         )
         ((= answ "Previous")
            (prloli el)
            (setq lastmove "Previous")
            (setq tel (1- tel))
            (if (< tel 0) 
               (progn
                  (princ "\nNo previous Object.")
                  (setq tel 0)
               )
               (setq el (ssname DimFound tel))
            )
         )            
         ((= answ "eXit")
            (prloli el)
            (setq el nil)
         )
         (T nil)
      ) ;; End Cond
      (command "_.UNDO" "_END")
   ) ;; End While
   (command "_.SELECT" DimFound "")
   (setq DimFound nil)
)

;;;-------------------------------------------------------------------------
;;; The Export Function.
;;;-------------------------------------------------------------------------
(defun prfile ( / tel FN ofh FLine pt1 pt2 prof rot ND CS OS)

   ;;; Initialize some variables. Input in later version
   ;;; Get Output FileHandle [ofh]
   (setq FN (getfiled "Output to file" (getvar "DWGNAME") "TXT" 3))
   (if FN
      (setq ofh (open FN "w"))
      (alert "Not a valid Filename\nExport function terminated")
   )

   (if (and FN ofh)
      (progn
         (initget "Ucs World")
         (setq CS (getkword "\nCoordinates in current UCS or <World>: "))
         (if (not (= CS "Ucs")) (setq CS "World")) ;;Trap NULL input
         (initget "Ucs World")
         (setq OS (getkword "\nOrientation in current UCS or <World>: "))
         (if (not (= OS "Ucs")) (setq OS "World")) ;;Trap NULL input
         ;;; Get number of decimals
         (initget 4)
         (setq ND (getint (strcat "\nNumber of decimals <"
                          (itoa (getvar "LUPREC")) ">: " )))
         (if (not ND) (setq ND (getvar "LUPREC")))
         ;;; Get UCS or WorldCS
   
         ;;Get first entity before WHILE is evaluated
         (setq tel 0) ;;Reset SetCounter
         (setq en (ssname SSDim tel))
     
         ;;; Loop SelectionSet and Write to File
         (princ "\n")
         (while en
            (setq FLine "") ;;Reset the fileline
            (setq pt1 (cdr (assoc 13 (entget en))))
            (setq pt2 (cdr (assoc 14 (entget en))))
            (if (= OS "Ucs")
               (setq rot (* 57.29577951 (- (cdr (assoc 50 (entget en))) 
                  (angle '(0.0 0.0 0.0) (list (car (getvar "UCSXDIR")) 
                  (cadr (getvar "UCSXDIR")) 0.0 ))))
               )
               (setq rot (* (cdr (assoc 50 (entget en))) 57.29577951))
            )
            (if (= CS "Ucs") (setq pt1 (trans pt1 0 1) pt2 (trans pt2 0 1)) )
            (setq prof (cdr (assoc 1 (entget en))))
      
            ;;; Output to File
            (setq FLine (strcat (rtos (car pt1) 2 ND) "," (rtos (cadr pt1) 2 ND) ","))
            (setq FLine (strcat FLine (rtos (car pt2) 2 ND) "," (rtos (cadr pt2) 2 ND) ","))
            (setq FLine (strcat FLine (rtos rot 2 ND) "," prof ))
            
            (write-line FLine ofh)
              
            ;;; Get new ENtity B-E-F-O-R-E 'While' is evaluated
            (setq tel (1+ tel))
            (princ (strcat "\r" (itoa tel)))
            (setq en (ssname SSDim tel))
         ) ;; End While
         (alert (strcat (itoa tel) " records have been extracted"))
         (close ofh)
      ) ;; End progn. Else-clause follows:
      (alert "Could not open file for output.")
   ) ;; End if
)

;-------------------------------------------------------------------------
; Hauptprogramm
;-------------------------------------------------------------------------
; Initialize some variables
	(msave '("LIMCHECK" "OSMODE" "CMDECHO" "REGENMODE" "TEXTSTYLE" ))
	(setvar "LIMCHECK" 0)
	(setvar "CMDECHO" 0)
	(setvar "OSMODE" 0)
	(setvar "REGENMODE" 0)
	(command "_.LAYER" "Mach" "PROFILE" "")
	(command "_.LAYER" "FA" "172" "" "")
	(if (and (eq 1 (logand 1 (getvar "PICKFIRST")))
	      		(setq SSDim (ssget "I" '((0 . "DIMENSION")(3 . "PROFIL"))))
			)				; End And
		(progn ;; Then ...
			(command "*cancel*" "*cancel*")		; Clear Grips from screen
			(command "_.SELECT" SSDim "")	; Enable PrevSelectSet
			(princ (strcat "\n   " (itoa (sslength SSDim)) " Profile gefunden"))
		)
		(progn ;; Else ...
			(command "*cancel*" "*cancel*")		; Clear Grips from screen
			(setq SSDim (ssadd))
		)
	)						; End if
   (setq olddim (getvar "DIMSTYLE"))
   (if (not (= olddim "PROFIL")) (prdinit))
   (if (not (= (getvar "TEXTSTYLE") "ATT")) (prtinit))
   (setq old_err *error*
         *error* my_err)
   (setq answ "New")
   (while (not (= answ "eXit"))
      (initget "New Edit Regen Search File eXit")
      (if (not (setq answ
            (getkword "\nNeu/aEndern/Regenerieren/Suchen/File or <eXit>: ")))
         (setq answ "eXit")
         ;; Else loop through conditions
         (cond
            ((= answ "New") (prnew))
            ((= answ "Edit")
               (if (setq SSDim (ssget '((0 . "DIMENSION")(3 . "PROFIL"))))
                  (if (> (sslength SSDim) 0)
                     (predit)
                     (alert "No valid profiles found.") ;; Else ...
            )  )  )
            ((= answ "Regen")
               (if (setq SSDim (ssget '((0 . "DIMENSION")(3 . "PROFIL"))))
                  (if (> (sslength SSDim) 0)
                     (progn
                        (prregen)
                        (alert "Profiles have been updated.")
                     ) ;; End progn
                     (alert "No valid profiles found.") ;; Else ...
            )  )  )
            ((= answ "Search")
               (princ "\nDatei wird geladen ... ")
               (if (setq SSDim (ssget "x" '((0 . "DIMENSION")(3 . "PROFIL"))))
                  (progn
                     (princ "Done !")
                     (if (> (sslength SSDim) 0)
                        (prsearch)
                        (alert "No valid profiles found.") ;; Else ...
            )  )  )  )
            ((= answ "File")
               (if (setq SSDim (ssget '((0 . "DIMENSION")(3 . "PROFIL"))))
                  (if (> (sslength SSDim) 0)
                     (prfile)
                     (alert "No valid profiles in drawing.") ;; Else ...
            )  )  )
         ) ;; End Cond
      ) ;; End If
   ) ;; End While
   (mrest)
   (princ)
)

(defun c:prf () (profil))  
(princ "\n\t   Programm PROFIL geladen;   START mit prf ")  
(princ)