;; ============================================================
;; SSG_CORE.LSP - Kernbibliothek: Umgebung, Fehler, Dialog
;; Allgemeingueltige Hilfsfunktionen fuer AutoCAD-LISP Makros
;; Ursprung: ACADSST/MENU/ssg.lsp, pu1pu2.lsp (Schoenenberger)
;; Bereinigt und verallgemeinert: 2025
;; ============================================================


;; ------------------------------------------------------------
;; UMGEBUNGSSICHERUNG
;; Sichert Systemvariablen vor Makroausfuehrung und stellt
;; sie danach wieder her. Wird immer als Paar verwendet:
;;   (ssg-start "Titel" '(("OSMODE") ("ORTHOMODE")))
;;   ... Makrocode ...
;;   (ssg-end)
;; ------------------------------------------------------------

(defun ssg-start (titel zusatz-vars / xlen xpos xvar)
  ;; titel      - Anzeigename des Makros
  ;; zusatz-vars - Liste zusaetzlicher Variablen z.B. '(("OSMODE")("ORTHOMODE"))
  ;;               Immer CLAYER und CMDECHO werden automatisch gesichert.
  (setq _ssg-olderr *error*
        *error*     (function ssg-errhan)
        _ssg-cavar  (append '(("CLAYER") ("CMDECHO")) zusatz-vars)
        xlen        (length _ssg-cavar)
        xpos        0
  )
  (repeat xlen
    (setq xvar       (car (nth xpos _ssg-cavar))
          _ssg-cavar (subst (cons xvar (getvar xvar))
                            (nth xpos _ssg-cavar) _ssg-cavar)
          xpos       (1+ xpos)
    )
  )
  (setvar "CMDECHO" 0)
  (command "_undo" "_G")
  (graphscr)
  (if titel (prompt (strcat "\n***** " titel " *****\n")))
  (princ)
)

(defun ssg-end (/ xpos xlen xvar)
  (if _ssg-cavar
    (progn
      (command)
      (command "_undo" "_E")
      (setq xpos 1
            xlen (length _ssg-cavar)
      )
      (if (/= (getvar "CLAYER") (caar _ssg-cavar))
        (command "_LAYER" "_SE" (cdar _ssg-cavar) "")
      )
      (repeat (1- xlen)
        (setq xvar (nth xpos _ssg-cavar)
              xpos (1+ xpos)
        )
        (setvar (car xvar) (cdr xvar))
      )
    )
  )
  (if _ssg-olderr (setq *error* _ssg-olderr))
  (princ)
)

(defun ssg-errhan (em)
  (if (= em "Function cancelled")
    (princ)
    (progn (princ "\nFehler: ") (princ em))
  )
  (command)
  (command)
  (ssg-end)
)


;; ------------------------------------------------------------
;; BENUTZER-ABFRAGEN
;; ------------------------------------------------------------

;; Ja/Nein-Abfrage mit konfigurierbarem Default
;; defa = T  -> Default ist "Yes" (Eingabe noetig um "No" zu waehlen)
;; defa = nil -> Default ist "No"
;; Rueckgabe: T wenn "No" gewaehlt (also Ablehnung), nil wenn "Yes"
(defun ssg-ques (prompt-text defa)
  (if defa
    (progn
      (initget 1 "Yes No  Yes")
      (= (getkword (strcat "\n" prompt-text " Y/N <Y>: ")) "No")
    )
    (progn
      (initget 1 "Yes No  No")
      (= (getkword (strcat "\n" prompt-text " Y/N <N>: ")) "Yes")
    )
  )
)

;; Fehlermeldung mit optionalem Signalton
;; ssg-bell = T -> kein Ton; nil -> Ton ausgeben
(defun ssg-emsg (text)
  (if (not ssg-bell) (prompt "\007"))
  (terpri)
  (prompt text)
  (terpri)
)


;; ------------------------------------------------------------
;; LAYER-HILFSFUNKTIONEN
;; ------------------------------------------------------------

;; Layer eines angeklickten Objektes ermitteln
;; txt = Prompt-Text fuer Objektauswahl
;; Rueckgabe: Layername als String, nil wenn Abbruch
(defun ssg-get-layer (txt / sel)
  (if (setq sel (entsel txt))
    (cdr (assoc 8 (entget (car sel))))
  )
)

;; Alle Objekte eines bestimmten Layers als Auswahlsatz liefern
;; lay-name = Layername; ent-typ = Entitaetstyp z.B. "LINE" (nil = alle)
(defun ssg-layer-ss (lay-name ent-typ)
  (if ent-typ
    (ssget "X" (list (cons 0 ent-typ) (cons 8 lay-name)))
    (ssget "X" (list (cons 8 lay-name)))
  )
)

;; Layer anlegen (falls nicht vorhanden) und optional setzen
;; lay-name = Name; color = Farbnummer als String z.B. "2"; set-aktiv = T/nil
(defun ssg-make-layer (lay-name color set-aktiv)
  (if set-aktiv
    (command "_LAYER" "_M" lay-name "_CO" color lay-name "")
    (command "_LAYER" "_N" lay-name "_CO" color lay-name "")
  )
)

;; Auswahlsatz-Iteration: Funktion fuer jedes Element aufrufen
;; ss = Auswahlsatz; func = Funktion mit einem Parameter (entity-name)
(defun ssg-ss-foreach (ss func / i ename)
  (if ss
    (progn
      (setq i 0)
      (while (setq ename (ssname ss i))
        (func ename)
        (setq i (1+ i))
      )
    )
  )
)

;; Alle Elemente eines Auswahlsatzes hervorheben/zuruecksetzen
;; ss = Auswahlsatz; modus = 3 (hervorheben) / 4 (invertiert) / 0 (normal)
(defun ssg-ss-redraw (ss modus / i ename)
  (if ss
    (progn
      (setq i 0)
      (while (setq ename (ssname ss i))
        (redraw ename modus)
        (setq i (1+ i))
      )
    )
  )
)

;; Auswahlsatz zu einem anderen Auswahlsatz hinzufuegen (in-place)
;; src-ss = Quell-Auswahlsatz; dest-ss = Ziel-Auswahlsatz (wird modifiziert)
(defun ssg-ss-add (src-ss dest-ss / i ename)
  (if (null dest-ss) (setq dest-ss (ssadd)))
  (setq i 0)
  (while (setq ename (ssname src-ss i))
    (ssadd ename dest-ss)
    (redraw ename 3)
    (setq i (1+ i))
  )
  dest-ss
)


;; ------------------------------------------------------------
;; BLOCK-OPERATIONEN
;; ------------------------------------------------------------

;; Eindeutigen Blocknamen aus Einfuegepunkt + Zeitstempel erzeugen
;; pt = Einfuegepunkt (Liste); Rueckgabe: Blockname als String
(defun ssg-make-blockname (pt / k1 k2)
  (setq k1 (strcat (itoa (abs (fix (car pt))))
                   (itoa (abs (fix (cadr pt))))
                   (itoa (abs (fix (caddr pt)))))
        k2 (substr (rtos (getvar "cdate") 2 9) 10 9)
  )
  (strcat k1 k2)
)

;; Einzel-Block einfuegen mit Layer anlegen
;; lay-name  = Ziel-Layer; color = Layerfarbe
;; blk-pfad  = vollstaendiger Blockpfad (ohne Erweiterung)
;; pt        = Einfuegepunkt; xscale yscale = Skalierung ("" = 1)
;; rotation  = Drehwinkel als String oder pause fuer interaktiv
(defun ssg-insert-block (lay-name color blk-pfad pt xscale yscale rotation)
  (ssg-make-layer lay-name color T)
  (command "_insert" blk-pfad pt xscale yscale rotation)
)

;; Block aus Auswahlsatz erstellen und gleich wieder einfuegen
;; pt         = Origin; rotation = Drehwinkel als String
;; ss         = Auswahlsatz der Elemente
;; Rueckgabe: Blockname (String)
(defun ssg-make-block (pt rotation ss / bname gefunden)
  (setq bname   (ssg-make-blockname pt)
        gefunden (tblsearch "block" bname)
  )
  (if (not gefunden)
    (progn
      (command "_block" bname pt ss "")
      (command "_insert" bname pt "" "" rotation)
    )
    (progn
      (alert (strcat "Blockname '" bname "' existiert bereits - wird uebersprungen."))
      (setq bname (strcat "x" bname))
      (command "_block" bname pt ss "")
      (command "_insert" bname pt "" "" rotation)
    )
  )
  bname
)


;; ------------------------------------------------------------
;; ATTRIBUT-OPERATIONEN
;; ------------------------------------------------------------

;; Attribut eines Blocks (letzte Einfuegung) aendern
;; tag     = Attributbezeichner (z.B. "ARTINR")
;; wert    = neuer Wert
;; ersetzen = T -> vollstaendiger Ersatz; nil -> Anfuegen
(defun ssg-attrib-set (tag wert ersetzen / obj typ attr-tag attr-wert)
  (setq obj (entlast))
  (while (not (equal (cdr (assoc 0 (entget obj))) "SEQEND"))
    (setq typ (cdr (assoc 0 (entget obj))))
    (if (equal typ "ATTRIB")
      (progn
        (setq attr-tag  (cdr (assoc 2 (entget obj)))
              attr-wert (cdr (assoc 1 (entget obj)))
        )
        (if (equal attr-tag tag)
          (if ersetzen
            (entmod (subst (cons 1 wert)
                           (assoc 1 (entget obj)) (entget obj)))
            (entmod (subst (cons 1 (strcat attr-wert wert))
                           (assoc 1 (entget obj)) (entget obj)))
          )
        )
      )
    )
    (setq obj (entnext obj))
  )
)

;; Mehrere Attribute eines Blocks auf einmal setzen
;; attrib-alist = Assoziationsliste '(("TAG1" . "Wert1") ("TAG2" . "Wert2") ...)
(defun ssg-attrib-set-many (attrib-alist / obj typ tag wert)
  (setq obj (entlast))
  (while (not (equal (cdr (assoc 0 (entget obj))) "SEQEND"))
    (setq typ (cdr (assoc 0 (entget obj))))
    (if (equal typ "ATTRIB")
      (progn
        (setq tag (cdr (assoc 2 (entget obj))))
        (setq wert (cdr (assoc tag attrib-alist)))
        (if (and wert (> (strlen wert) 0))
          (entmod (subst (cons 1 wert)
                         (assoc 1 (entget obj)) (entget obj)))
        )
      )
    )
    (setq obj (entnext obj))
  )
)

;; Alle Attribute eines INSERT-Entity als Assoziationsliste lesen.
;; ent = Entity-Name eines INSERT mit Attributen.
;; Rueckgabe: (("TAG1" . "Wert1") ("TAG2" . "Wert2") ...) oder nil
(defun ssg-attrib-read (ent / e ed result)
  (setq e (entnext ent))
  (while e
    (setq ed (entget e))
    (if (equal (cdr (assoc 0 ed)) "SEQEND")
      (setq e nil)
      (progn
        (if (equal (cdr (assoc 0 ed)) "ATTRIB")
          (setq result (cons (cons (cdr (assoc 2 ed)) (cdr (assoc 1 ed))) result))
        )
        (setq e (entnext e))
      )
    )
  )
  (reverse result)
)

;; Default-Attribute aus einer Definitionsliste erzeugen.
;; attrib-defs = Liste von (TAG DEFAULT) Paaren, z.B. '(("TYP" "A") ("NR" "0"))
;; Rueckgabe: Assoziationsliste (("TYP" . "A") ("NR" . "0") ...)
(defun ssg-attrib-defaults (attrib-defs / result)
  (foreach def attrib-defs
    (setq result (cons (cons (car def) (cadr def)) result))
  )
  (reverse result)
)

;; Gegebene Attribute mit Defaults zusammenfuehren.
;; given       = alist mit Ueberschreibungen (darf nil sein)
;; attrib-defs = Definitionsliste ((TAG DEFAULT) ...)
;; Rueckgabe: vollstaendige alist mit allen Tags
(defun ssg-attrib-merge (given attrib-defs / defaults pair existing)
  (setq defaults (ssg-attrib-defaults attrib-defs))
  (if given
    (foreach pair given
      (setq existing (assoc (car pair) defaults))
      (if existing
        (setq defaults (subst pair existing defaults))
        (setq defaults (append defaults (list pair)))
      )
    )
  )
  defaults
)

;; Unsichtbare ATTDEF-Entities bei (0,0) erzeugen.
;; Muss VOR dem _BLOCK-Befehl aufgerufen werden, damit die ATTDEFs
;; Teil der Blockdefinition werden.
;; attrib-defs = Definitionsliste ((TAG DEFAULT) ...)
;; text-height = Texthoehe der ATTDEFs (z.B. 50.0)
(defun ssg-attrib-make-defs (attrib-defs text-height / ypos)
  (setq ypos 0.0)
  (foreach def attrib-defs
    (entmake (list
      '(0 . "ATTDEF")
      '(8 . "0")
      (cons 10 (list 0.0 ypos 0.0))
      (cons 40 text-height)
      (cons 1 (cadr def))
      (cons 3 (car def))
      (cons 2 (car def))
      '(70 . 1)
    ))
    (setq ypos (- ypos (* text-height 2.0)))
  )
)

;; Attribut eines Blocks anhand seines Handle suchen und aendern
;; handle     = Entity-Handle (String) des INSERT
;; tag        = Attributbezeichner
;; wert       = neuer Wert
;; ersetzen   = T -> ersetzen; nil -> anhaengen
(defun ssg-attrib-by-handle (handle tag wert ersetzen / e typ blk-tag blk-wert fertig)
  (setq e      (entnext)
        fertig nil
  )
  (while (and e (not fertig))
    (setq typ (cdr (assoc 0 (entget e))))
    (if (and (equal (cdr (assoc 5 (entget e))) handle)
             (equal typ "INSERT")
             (equal (cdr (assoc 66 (entget e))) 1)
        )
      (progn
        (while (not (= (cdr (assoc 0 (entget e))) "SEQEND"))
          (if (equal (cdr (assoc 0 (entget e))) "ATTRIB")
            (progn
              (setq blk-tag  (cdr (assoc 2 (entget e)))
                    blk-wert (cdr (assoc 1 (entget e)))
              )
              (if (equal blk-tag tag)
                (if ersetzen
                  (entmod (subst (cons 1 wert)
                                 (assoc 1 (entget e)) (entget e)))
                  (entmod (subst (cons 1 (strcat blk-wert wert))
                                 (assoc 1 (entget e)) (entget e)))
                )
              )
            )
          )
          (setq e (entnext e))
        )
        (setq fertig T)
      )
    )
    (setq e (entnext e))
  )
)


;; ------------------------------------------------------------
;; DIALOG-STANDARD-PATTERN
;; Vorlage fuer DCL-Dialoge: laden, initialisieren, starten
;; Verwendung:
;;   (ssg-dialog-run "pfad/dialog.dcl" "dialog-name" init-fn accept-fn)
;;
;;   init-fn   = Funktion ohne Parameter, setzt Tiles und Actions
;;   accept-fn = Funktion ohne Parameter, liest Tiles aus
;; ------------------------------------------------------------

(defun ssg-dialog-run (dcl-pfad dialog-name init-fn accept-fn / dat)
  (setq dat (load_dialog dcl-pfad))
  (if (not (new_dialog dialog-name dat))
    (progn (alert "Dialog konnte nicht geladen werden.") (exit))
  )
  (if init-fn (init-fn))
  (action_tile "accept" "(if accept-fn (accept-fn)) (done_dialog 1)")
  (action_tile "cancel" "(done_dialog 0)")
  (start_dialog)
  (unload_dialog dat)
)


;; ------------------------------------------------------------
;; ZOOM-HILFSFUNKTIONEN
;; ------------------------------------------------------------

;; Aktuelle View-Groesse merken
(defun ssg-zoom-save ()
  (setq _ssg-view-size (getvar "VIEWSIZE"))
)

;; Auf gespeicherte View-Groesse zurueckschalten (wenn veraendert)
(defun ssg-zoom-restore ()
  (if (and _ssg-view-size (/= (getvar "VIEWSIZE") _ssg-view-size))
    (command "_ZOOM" "_P")
  )
)


(prompt "\nssg_core.lsp geladen.")
(princ)