;;; - ------------------------------------------------------------------------------- - ;
;;; -                T O O L - A C M - L T Y P E M A K E R                            - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - Beschreibung : Erstellung von Linientypen mit Dialogunterstüztung               - ;
;;; - Befehle      : ACM-LTYPEMAKER                                                   - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - letzte Änderung am : 05.01.2025                                                 - ;
;;; -              durch : Thomas Krüger                                              - ;
;;; - ------------------------------------------------------------------------------- - ;
(vl-load-com)
;;; - ------------------------------------------------------------------------------ - ;
(defun C:ACM-LTYPEMAKER(/ STYPES-GET STYPE-GET STYPESTRING-GET LTDESCRIPTION-GET
                          LINETYPEDEF DT:SINGLELINETYPE-LOAD DT:LINETYPE-DEF
                          LTYPEMAKEDLG EXPERT DATA LT
                       )
  (defun DT:UNDOEND()
    (while(= 8(logand 8 (getvar "undoctl")))
      (vla-endundomark(vla-get-activedocument(vlax-get-acad-object)))
    )      
  )
  (defun DT:UNDOSTART()
    (DT:UNDOEND)
    (vla-startundomark(vla-get-activedocument(vlax-get-acad-object)))
  )
  (defun DT:ERROR (MSG)    
    (if(not(wcmatch(strcase MSG t) "*break,*cancel*,*exit*"))      
      (princ (strcat "\nFEHLER: " MSG))
    )
    (DT:UNDOEND)
    (DT:RESET)
    (princ)
  )
  (defun DT:INIT()  
    (DT:UNDOSTART)        
    (setq ERRORSAVE *error*  *error* DT:ERROR
          EXPERT(getvar "EXPERT")
          OLDCMD(getvar "CMDECHO")
    )
  )
  (defun DT:RESET()
    (setvar "EXPERT" EXPERT)
    (setvar "CMDECHO" OLDCMD)
    (setq *error* ERRORSAVE)
    (mapcar '(lambda(X) (set X nil))(list 'ERRORSAVE))
    (DT:UNDOEND)
    (princ)
  )
  (defun STYPES-GET()
     ;; Prozentsatz der Strichlänge, jede Unterliste sollte insgesamt 1 ergeben
     ;; und max. 10 Einträge haben /Positive Einträge sind Striche, negative Einträge
     ;;;sind Lücken
     (list (list "Continuous" '(1.0))
           (list "Center"     '(0.35 -0.10 0.10 -0.10 0.35))
           (list "Dashdot"    '(0.35 -0.15 0 -0.15 0.35))
           (list "Dashdot2"   '(0.2 -0.1 0 -0.1 0.2 -0.1 0 -0.1 0.2))
           (list "Dashed"     '(0.3 -0.1 0.3 -0.1 0.3))
           (list "Dashed2"    '(0.25 -0.125 0.25 -0.125 0.25))
           (list "Dot"        '(0 -0.25 0 -0.25 0 -0.25 0 -0.25 0))
           (list "Hidden"     '(0.2 -0.2 0.2 -0.2 0.2))
           (list "Hidden2"    '(0.143 -0.143 0.143 -0.143 0.143 -0.143 0.143))
           (list "Phantom"    '(0.3 -0.08 0.08 -0.08 0.08 -0.08 0.3))
           (list "3Dash"      '(0.325 -0.05 0.05 -0.05 0.05 -0.05 0.05 -0.05 0.325))
           (list "2Dots"      '(0.35 -0.10 0 -0.10 0 -0.10 0.35))
           (list "3Dots"      '(0.3 -0.10 0 -0.10 0 -0.10 0 -0.10 0.3))
     )  
  )
  (defun STYPE-GET(STYPENAME)
    (if(and(setq STYPES(STYPES-GET))
           (setq STYPES(mapcar
                      '(lambda(X)(list (strcase (car X))(cadr X))) 
                      STYPES
                    )
           )
           (=(type STYPENAME)'STR)
           (setq STYPE (cadr(assoc(strcase STYPENAME) STYPES)))
       )
      STYPE
    )
  )
  (defun STYPESTRING-GET(STYPE / Y STYPESTRINGLIST)
    (if(and(=(type STYPE)'LIST)
           (vl-every 'numberp STYPE)
           (setq STYPESTRINGLIST 
            (mapcar
             '(lambda (x)
                (cond
                 ((= X 0) ".")
                 ((< X 0)
                    (setq Y "")
                    (repeat
                      (if(=(fix 0)0) 1 (fix(* 10.0 (abs X))))
                      (setq Y(strcat Y " "))
                    )
                 )
                 ((<= X 0.1) "-")
                 ((setq Y "")(repeat(fix(* 10.0 X))(setq Y (strcat Y "-"))))
                )
              )
              STYPE
            )  
           )
       )
     (apply 'strcat STYPESTRINGLIST)
    )
  )  
  (defun LTDESCRIPTION-GET(CHARS STYPENAME / STYPE STDESC DES MAXL)
    (if(and(or(=(type CHARS)'STR)(setq CHARS ""))
           (or(setq STYPE(STYPE-GET STYPENAME))(setq STYPE '(1.0)))    
           (setq STDESC(STYPESTRING-GET STYPE))
       )
      (progn
        (setq MAXL 35)
        (setq DES(strcat STDESC CHARS))
        (while (>= MAXL(+(strlen DES)(strlen STDESC)(strlen CHARS)(strlen STDESC)))        
          (setq DES(strcat DES STDESC CHARS))
        )                
        (setq DES (strcat DES STDESC))
      )  
    )
  )
  ;(LINETYPEDEF "DUMMY" "O" "STANDARD" 2.5 0.65 12.5 "Center")
  (defun LINETYPEDEF(LTNAME CHARS TSTYLE HTEXT GTEXT LDASH STYPENAME / STYPE NTW LTDEF)
    (defun TW(CHARS HTEXT TSTYLE / D TS I P)      
       (if(and(setq TS(tblobjname "STYLE" TSTYLE))(setq I(cdr(assoc 41(entget TS)))))
         (setq I (/ 1.0 I))
         (setq I 1.0)
       )    
       (if(setq P(textbox(list(cons 1 CHARS)(cons 7 TSTYLE)(cons 40 HTEXT))))
         (progn
           (setq D(* I(distance(car P)(list(caadr P)(cadar P)))))
           (list D(caar P)(-(cadadr P)(abs(cadar P))))
         )
       )
     )
     (if(and(or(and(=(type LTNAME)'STR)(snvalid LTNAME))(setq LTNAME "DUMMY"))
            (or(=(type CHARS)'STR)(setq CHARS ""))
            (or(and(=(type TSTYLE)'STR)(tblobjname "STYLE"TSTYLE))(setq TSTYLE "STANDARD"))
            (or(numberp HTEXT)(setq HTEXT(if(=(getvar "MEASUREMENT")0)0.075 2.50)))         
            (or(numberp GTEXT)(setq GTEXT(if(=(getvar "MEASUREMENT")0)0.025 0.65)))            
            (or(numberp LDASH)(setq LDASH(if(=(getvar "MEASUREMENT")0)0.250 12.5)))            
            (or(setq LTDESC(LTDESCRIPTION-GET CHARS STYPENAME))(setq LTDESC ""))
            (or(setq STYPE(STYPE-GET STYPENAME))(setq STYPE '(1.0)))
            (setq NTW(TW CHARS HTEXT TSTYLE))
        )   
       (setq LTDEF(strcat "*" LTNAME "," LTDESC
                          "\nA,"
                            (apply
                              'strcat
                              (mapcar
                               '(lambda(x)(strcat(vl-prin1-to-string(* LDASH X))","))
                                STYPE
                              )
                            )
                            "-"
                            (vl-prin1-to-string(+ GTEXT(*(car NTW)0.5)))
                            ",[\"" CHARS "\"," TSTYLE ",S=" (vl-prin1-to-string HTEXT) ",R=0.0,X=-"
                            (vl-prin1-to-string(*(car   NTW)0.5))
                            ",Y=-"
                            (vl-prin1-to-string(*(caddr NTW)0.5))
                            "],-"
                            (vl-prin1-to-string(+ GTEXT(*(car NTW)0.5)))
                  
                  )
       )
     )
  )

  ;(DT:SINGLELINETYPE-LOAD "RAND" "acadiso.lin" 'T) 
  (defun DT:SINGLELINETYPE-LOAD (LTNAME FILENAME RELOAD?
                                / OLDEXPERT OLDCMDECHO OLDFILEDIA RESULT
                                )
    (if(and(=(type LTNAME)'STR)(snvalid LTNAME)
           (=(type FILENAME)'STR)
           (setq FILENAME(findfile FILENAME))
       )
      (progn         
         (setq OLDEXPERT (getvar  "EXPERT"))
         (setq OLDCMDECHO(getvar "CMDECHO"))
         (setq OLDFILEDIA(getvar "FILEDIA"))
         (setvar "EXPERT"  0)
         (setvar "CMDECHO" 0)
         (setvar "FILEDIA" 0)
         (setq RESULT
           (cond      
             ((and RELOAD?
                   (tblobjname "LTYPE" LTNAME)
                   (not(vl-catch-all-error-p
                         (vl-catch-all-apply
                           'vl-cmdf(list "._linetype" "_load" LTNAME FILENAME "_y" "")
                         )
                       )
                   )
              )
              "REDEF"
             ) 
             ((tblobjname "LTYPE" LTNAME)"NOREFEF")
             ((not(vl-catch-all-error-p
                    (vl-catch-all-apply
                      'vl-cmdf(list "._linetype" "_load" LTNAME FILENAME "")
                    )
                  )
              )
              "NEWLOAD"
             )
           )
         )      
         (while(=(getvar "CMDACTIVE")1)(vl-cmdf ""))
         (setvar "EXPERT"   OLDEXPERT)
         (setvar "CMDECHO" OLDCMDECHO)
         (setvar "FILEDIA" OLDFILEDIA)
         (if(not(vl-catch-all-error-p
                  (setq LT
                    (vl-catch-all-apply
                      'vla-item
                      (list
                        (vla-get-linetypes(vla-get-activedocument(vlax-get-acad-object)))
                        LTNAME
                      )
                    )
                  )
                )
            )       
            (list LTNAME LT RESULT)
         )
      )  
    )
  )
  ;(DT:LINETYPE-DEF(LINETYPEDEF "DUMMY" "O" "STANDARD" 2.5 0.65 12.5 "Center")'T)
  (defun DT:LINETYPE-DEF(DEF RELOAD? / FILENAME LTNAME FILE LINETYPE)
    (if(and(=(type DEF)'STR)           
           (=(substr DEF 1 1)"*")
           (setq POS(vl-string-search "," DEF))
           (setq LTNAME(substr DEF 2 (1- POS)))
           (snvalid LTNAME)                             
           (setq FILENAME(vl-filename-mktemp (strcat "LTMAKE.LIN")))
           (setq FILE (open FILENAME "w"))
       )
      (progn
        (princ(strcat "\n" DEF "\n")FILE)        
        (close FILE)
        (setq LINETYPE(DT:SINGLELINETYPE-LOAD LTNAME FILENAME RELOAD?))
        (vl-file-delete FILENAME)
        LINETYPE
      )   
    )      
  )
  (defun LTYPEMAKEDLG( / WRITE-DCL DLG-CHECK DLG-RUN
                         VORGABE LTNAME CHARS TSTYLE STYPE LDASH HTEXT GTEXT
                     )    
    (defun WRITE-DCL(/ DIR POS FILE)
      (if(and(setq DIR(vl-filename-mktemp (strcat "LTMAKEDLG.DCL")))
             (setq FILE (open DIR "w"))
         )
        (progn
          (mapcar
            '(lambda (X)(princ (strcat X "\n") FILE))
            '(
                ""
                "LTMAKEDLG"
                ": dialog"
                "{  key = DLGTITEL;   "         
                "   : row   "
                "   {"
                "     : boxed_column"
                "     {"
                "       label = \"  Linientyp-Optionen  \";"
                "         : edit_box"
                "         { label       = \"Linientypname\";"
                "           key         = \"LTNAME\";"
                "           edit_width  = 22;"
                "         }" 
                "         : edit_box"                     
                "         { label       = \"Zeichenkette\";"
                "           key         = \"CHARS\";"
                "           edit_width  = 22;"
                "         }"
                "         : edit_box"                     
                "         { label       = \"Strichlänge\";"
                "           key         = \"LDASH\";"
                "           edit_width  = 22;"
                "         }"
                "         : edit_box"                     
                "         { label       = \"Texthöhe\";"
                "           key         = \"HTEXT\";"
                "           edit_width  = 22;"
                "         }"
                "         : edit_box"                     
                "         { label       = \"TextLücke\";"
                "           key         = \"GTEXT\";"
                "           edit_width  = 22;"
                "         }"
                "         : popup_list"
                "         {"
                "           label       = \"TextStil\";"
                "           key         = \"TEXTSTYLES\";"
                "           edit_width  = 21;"
                "         }"
                "         : popup_list"
                "         {"
                "           label       = \"Strich-Typ\";"
                "           key         = \"DASHTYPES\";"
                "           edit_width  = 21;"
                "         }"                    
                "         spacer;"
              	"         : row"
              	"         { : text"
                "           {"
                "             key = \"SHOWLT\";"
                "             value = \"\";"                
                "           }"
                "         }"                
                "     }"
                "   }"
                "   spacer;"
                "   : row"
                "   {"
                "     alignment = centered;"
                "     : button"
                "     { label = \"CREATE\";"
                "       key   = \"CREATE\";"
                "       fixed_width = true;"
                "       width = 12;"
                "       alignment = right;"
                "       mnemonic =\"C\";"
                "     }"
                "     : cancel_button"
                "     { label = \"Abbruch\";"
                "       key = \"CANCEL\";"
                "       fixed_width = true;"
                "       width = 12;"
                "       alignment = right;"
                "       mnemonic =\"A\"; "
                "       is_cancel = true;"
                "     }"
                "     : button"
                "     { label = \"Info\";"
                "       key   = \"INFO\";"
                "       fixed_width = true;"
                "       width = 12;"
                "       alignment = right;"
                "       mnemonic =\"I\";"
                "     }"
                "      "
                "  }  "
                "  : errtile"
	        "  { width = 46;"
                "    fixed_width = true;"
	        "  }"
                "}"
                ""
              )
           )
           (close FILE)
           DIR
         )
       )
    )
    (defun DLG-CHECK()
      (setq LTNAME(get_tile  "LTNAME"))
      (setq CHARS(get_tile   "CHARS"))
      (setq STYPENAME(nth
                       (atoi(get_tile "DASHTYPES"))
                       (mapcar'(lambda(X)(strcase (car X)))(STYPES-GET))
                     )
      )
      (setq TSTYLE(nth
                    (atoi(get_tile "TEXTSTYLES"))
                    (mapcar'(lambda(X)(strcase X))TSTYLES)
                  )
      )
      (setq LDASH(get_tile  "LDASH"))
      (setq HTEXT(get_tile  "HTEXT"))
      (setq GTEXT(get_tile  "GTEXT"))
      (setq LTNAME
        (cond
          ((= "" LTNAME)
            (mode_tile "LTNAME" 2)
            (set_tile "error" (strcat "Linientypname muss gesetzt sein!"))
             nil
           )
           ((or(not(snvalid LTNAME))(=(strcase LTNAME)"CONTINUOUS"))
            (mode_tile "LTNAME" 2)
            (set_tile "error" (strcat "Ungültiger Linientypname!"))
            nil
           )
           ((tblobjname "LTYPE" LTNAME)
             (set_tile "error" (strcat "Linientyp '" LTNAME "'  wird überschrieben..."))
             LTNAME           
           )
           ((not(tblobjname "LTYPE" LTNAME))           
             (set_tile "error" (strcat "Linientyp '" LTNAME "'  wird angelegt..."))
             LTNAME
           )
        )
      )                        
      (setq LDASH
        (cond
          ((>(atof LDASH)0.0) (atof LDASH))
          ('T
            (set_tile "error" "Ungültige Strichlänge. Wert muss numerisch > 0 sein.")
            (set_tile "LDASH"(vl-prin1-to-string (setq LDASH (caddr VORGABE))   ))
            LDASH   
          )
        )          
      )
      (setq HTEXT
        (cond
          ((>(atof HTEXT)0.0) (atof HTEXT))
          ('T
            (set_tile "error" "Ungültige Texthöhe. Wert muss numerisch > 0 sein.")
            (set_tile "HTEXT"(vl-prin1-to-string (setq HTEXT (cadddr VORGABE))   ))
            HTEXT  
          )
        )          
      )    
      (setq GTEXT
        (cond
          ((>(atof GTEXT)0.0) (atof GTEXT))
          ('T
            (set_tile "error" "Ungültige Textlücke. Wert muss numerisch > 0 sein.")
            (set_tile "GTEXT"(vl-prin1-to-string (setq GTEXT (last VORGABE))))
            GTEXT  
          )
        )
      )
      (set_tile "SHOWLT" (strcat "Vorschau:\t\t"(LTDESCRIPTION-GET CHARS STYPENAME)))
      (if(and LTNAME CHARS TSTYLE HTEXT GTEXT LDASH STYPENAME)
        (list LTNAME CHARS TSTYLE HTEXT GTEXT LDASH STYPENAME)
      )  
    )
    (defun DLG-RUN(DIR / DLGINDEX EXIT? DT:TEXTSTYLE-GETLIST TSTYLES TSTYLENR STYPES STYPENR)
      (defun DT:TEXTSTYLE-GETLIST(DOC / TS TSLIST)
        (if(or(and(=(type DOC)'VLA-OBJECT)(vlax-property-available-p DOC 'LINETYPES))
              (setq DOC (vla-get-activedocument(vlax-get-acad-object)))
           )
          (progn
            (vlax-for TS (vla-get-textstyles DOC) 
              (setq TSLIST(cons(list(strcase(vla-get-name TS)) TS) TSLIST))
            )
            TSLIST
          )
        )
      )      
      (setq TSTYLE "STANDARD")
      (or(setq TSTYLES(vl-remove-if
                        '(lambda(X)(or(wcmatch x "*|*")(= X "")))
                         (acad_strlsort(mapcar 'car (DT:TEXTSTYLE-GETLIST nil)))
                      )  
         )
         (setq TSTYLES'("STANDARD"))
      )
      (or(setq TSTYLENR(vl-position TSTYLE TSTYLES))(setq TSTYLENR 0))
      (setq STYPES(mapcar 'car(STYPES-GET)))
      (setq STYPENR 0)
      (setq STYPENAME (nth STYPENR STYPES))
      (if (=(getvar "MEASUREMENT")0)
        (setq VORGABE '("DUMMY" "X" 0.25 0.075 0.025))
        (setq VORGABE '("DUMMY" "X" 12.5 2.500 0.650))
      )  
      (mapcar 'set '(LTNAME CHARS LDASH HTEXT GTEXT) VORGABE)        
            
      (if(>(setq DLGINDEX (load_dialog DIR))0)
        (if(new_dialog "LTMAKEDLG" DLGINDEX)
          (progn            
            (set_tile   "DLGTITEL" "ACM-LTYPEMAKE © Th.Krüger 2025 ")
            (set_tile   "LTNAME"  LTNAME)
            (set_tile   "CHARS"    CHARS)
            (set_tile   "LDASH"    (vl-prin1-to-string LDASH))
            (set_tile   "HTEXT"    (vl-prin1-to-string HTEXT))
            (set_tile   "GTEXT"    (vl-prin1-to-string GTEXT))
            (start_list "TEXTSTYLES")(mapcar 'add_list TSTYLES)(end_list)
            (set_tile   "TEXTSTYLES" (itoa TSTYLENR))
            (start_list "DASHTYPES") (mapcar 'add_list  STYPES)(end_list)
            (set_tile   "DASHTYPES" (itoa STYPENR))

            (set_tile "SHOWLT" (strcat "Vorschau:\t\t"(LTDESCRIPTION-GET CHARS STYPENAME)))
            (action_tile "LTNAME"    "(DLG-CHECK)")
            (action_tile "CHARS"     "(DLG-CHECK)")
            (action_tile "DASHTYPES" "(DLG-CHECK)")
            (action_tile "LDASH"     "(DLG-CHECK)")
            (action_tile "HTEXT"     "(DLG-CHECK)")
            (action_tile "GTEXT"     "(DLG-CHECK)")
            (action_tile "CREATE"  (strcat
                                      "(setq RETURN(DLG-CHECK))"
                                      "(done_dialog 1)"                                          
                                   )  
            )
            (action_tile "CANCEL"       "(setq RETURN            nil)(done_dialog 0)")
            (action_tile "INFO"         "(alert(strcat \"=========== ACM-LTYPEMAKE  ==========\n\n\"
                                                       \"\tErstellung von Linientypen mit Zeichen\n\"
                                                       \"\t© Th.Krüger 2025 ( tk@cad-od.de ) \n\"
                                                 )
                                         )"      
            )                                    
            (start_dialog)                                   
            (unload_dialog DLGINDEX)
          )  
          (progn (alert "Fehler bei der Dialoginitialisierung"))
        )
        (progn (alert "Dialog nicht gefunden"))
      )  
     RETURN
    )
    (if(and(setq DCLFILE(WRITE-DCL))(setq DCLFILE(findfile DCLFILE)))       
      (progn
        (setq RETURN(DLG-RUN DCLFILE))       
        (vl-file-delete DCLFILE)
        RETURN
      )
    )  
  )
  (DT:INIT)
  (if(and(setq DATA(LTYPEMAKEDLG))
         (setq LT(DT:LINETYPE-DEF
                   (LINETYPEDEF
                     (nth 0 DATA);_LTNAME
                     (nth 1 DATA);_CHARS
                     (nth 2 DATA);_TSTYLE
                     (nth 3 DATA);_HTEXT
                     (nth 4 DATA);_GTEXT
                     (nth 5 DATA);_LDASH
                     (nth 6 DATA);_STYPENAME
                   )  
                   'T ;_Überschreiben
                 )
         )
     )    
    (vla-regen(vla-get-activedocument(vlax-get-acad-object))acallviewports)
  )
  (DT:RESET)
  (princ)
)
;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-LTYPEMAKER:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-LTYPEMAKER : Erstellung von Linientypen mit Dialogunterstüztung" 
      "\n================ "
      "\n(C) Thomas Krüger 2025" 
      "\nE-Mail: tk@cad-od.de"
      "\nBefehlszeilenaufruf : ACM-LTYPEMAKER\n"   
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(ACM-LTYPEMAKER:INFO)
(princ)
