;;; YERINDEOLCEK - Her objeyi kendi noktasinda olcekle
;;; eplisp 2.0.0 - https://eplisp.com/tr/
;;; Ucretsiz. AutoCAD ve GstarCAD icin. Yuklemek icin: APPLOAD
;;; Hicbir garanti verilmez; sonuclari kontrol ederek kullanin.
;;; Komutlar: YERINDEOLCEK

;;; ------------------------------------------------------------
;;; ep core: shared helpers for every eplisp tool
;;; Prefix "ep:" keeps these names away from other LISP files.
;;; ------------------------------------------------------------

(vl-load-com)

;;; Sysvar save / restore + undo group + error handler.
;;; Usage inside a command:
;;;   (defun c:X (/ *error*)
;;;     (defun *error* (m) (ep:on-error m))
;;;     (ep:begin '("CMDECHO" "OSMODE"))
;;;     ...
;;;     (ep:finish)
;;;     (princ))
(defun ep:begin (vars)
  (setq ep:*sv* (mapcar '(lambda (v) (cons v (getvar v))) vars))
  (if (not (assoc "CMDECHO" ep:*sv*))
    (setq ep:*sv* (cons (cons "CMDECHO" (getvar "CMDECHO")) ep:*sv*))
  )
  (setvar "CMDECHO" 0)
  (command "_.UNDO" "_BEGIN")
  (setq ep:*undo* T)
)

(defun ep:finish ()
  (if ep:*undo*
    (progn
      (setq ep:*undo* nil)
      (if command-s
        (command-s "_.UNDO" "_END")
        (command "_.UNDO" "_END")
      )
    )
  )
  (foreach p ep:*sv*
    (if (cdr p) (setvar (car p) (cdr p)))
  )
  (setq ep:*sv* nil)
)

(defun ep:on-error (msg)
  (if (and msg
           (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*,*abort*")))
    (princ (strcat "\nHata: " msg))
  )
  (ep:finish)
  (princ)
)

;;; ------------------------------------------------------------
;;; Numbers and strings
;;; ------------------------------------------------------------

;;; Decimal separator used in reports (Turkish Excel expects a comma).
(setq ep:*dec* ",")
;;; CSV column separator (Turkish Excel expects a semicolon).
(setq ep:*sep* ";")

;;; Number -> string with the report decimal separator.
(defun ep:num (x prec / s)
  (setq s (rtos x 2 prec))
  (if (/= ep:*dec* ".")
    (ep:replace-all s "." ep:*dec*)
    s
  )
)

(defun ep:replace-all (str old new / pos out)
  (setq out "")
  (while (setq pos (vl-string-search old str))
    (setq out (strcat out (substr str 1 pos) new)
          str (substr str (+ pos 1 (strlen old))))
  )
  (strcat out str)
)

(defun ep:trim (s)
  (if s (vl-string-trim " \t" s) "")
)

(defun ep:pad (s n)
  (if (not s) (setq s ""))
  (while (< (strlen s) n) (setq s (strcat s " ")))
  s
)

;;; Current drawing name without extension, or a fallback.
(defun ep:dwg-base (fallback / n)
  (setq n (getvar "DWGNAME"))
  (if (or (not n) (= n ""))
    fallback
    (if (wcmatch (strcase n) "*.DWG")
      (substr n 1 (- (strlen n) 4))
      n
    )
  )
)

;;; ------------------------------------------------------------
;;; Geometry
;;; ------------------------------------------------------------

(defun ep:2d (p) (list (car p) (cadr p)))

;;; Length of any curve (LINE, ARC, CIRCLE, LWPOLYLINE with arcs,
;;; POLYLINE, ELLIPSE, SPLINE). Returns nil for non-curves.
(defun ep:curve-length (ent / typ ed)
  (setq ed (entget ent) typ (cdr (assoc 0 ed)))
  (cond
    ((not (member typ '("LINE" "ARC" "CIRCLE" "LWPOLYLINE" "POLYLINE" "ELLIPSE" "SPLINE")))
      nil
    )
    ((= typ "LINE")
      (distance (cdr (assoc 10 ed)) (cdr (assoc 11 ed)))
    )
    (T
      (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))
    )
  )
)

;;; Selection set -> list of enames.
(defun ep:ss-list (ss / i out)
  (setq i 0 out nil)
  (if ss
    (repeat (sslength ss)
      (setq out (cons (ssname ss i) out) i (1+ i))
    )
  )
  (reverse out)
)

;;; Angle of the current UCS X axis in WCS (for text rotation).
(defun ep:ucs-angle ()
  (angle '(0 0 0) (trans '(1 0 0) 1 0 T))
)

;;; ------------------------------------------------------------
;;; Layers
;;; ------------------------------------------------------------

(defun ep:ensure-layer (name color)
  (if (not (tblsearch "LAYER" name))
    (entmake (list '(0 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
                   (cons 2 name)
                   '(70 . 0)
                   (cons 62 color)
                   '(6 . "Continuous")))
  )
  name
)

;;; ------------------------------------------------------------
;;; CSV output
;;; rows: list of rows, each row a list of strings.
;;; ------------------------------------------------------------

(defun ep:csv-field (s)
  (if (not s) (setq s ""))
  (if (or (vl-string-search ep:*sep* s) (vl-string-search "\"" s))
    (strcat "\"" (ep:replace-all s "\"" "\"\"") "\"")
    s
  )
)

(defun ep:csv-line (row / out first)
  (setq out "" first T)
  (foreach f row
    (setq out (strcat out (if first "" ep:*sep*) (ep:csv-field f))
          first nil)
  )
  out
)

;;; Asks for a file name (default: drawing folder + name) and writes rows.
;;; Returns the path, or nil if the user cancelled.
(defun ep:csv-save (title default-name rows / path f)
  (setq path (getfiled title
                       (strcat (getvar "DWGPREFIX") default-name)
                       "csv" 1))
  (if path
    (progn
      (setq f (open path "w"))
      (if f
        (progn
          (foreach r rows (write-line (ep:csv-line r) f))
          (close f)
          (princ (strcat "\nCSV kaydedildi: " path))
          path
        )
        (progn
          (princ (strcat "\nDosya yazilamadi: " path))
          nil
        )
      )
    )
    (progn (princ "\nCSV kaydi atlandi.") nil)
  )
)

;;; ------------------------------------------------------------
;;; Table drawn into the drawing as LINE + TEXT entities.
;;; Works in every CAD program (no TABLE object, no ActiveX).
;;; rows : list of rows (list of strings); first row is the header.
;;; ------------------------------------------------------------

(defun ep:text (p h s lay rot)
  (entmake (list '(0 . "TEXT")
                 (cons 8 lay)
                 (cons 10 p)
                 (cons 11 p)
                 (cons 40 h)
                 (cons 1 s)
                 (cons 50 rot)
                 (cons 7 (getvar "TEXTSTYLE"))
                 '(72 . 0)
                 '(73 . 2)))
)

(defun ep:line (p1 p2 lay)
  (entmake (list '(0 . "LINE") (cons 8 lay) (cons 10 p1) (cons 11 p2)))
)

;;; Converts a point given relative to an origin in the UCS into WCS.
(defun ep:uw (origin dx dy)
  (trans (list (+ (car origin) dx) (- (cadr origin) dy) 0.0) 1 0)
)

(defun ep:draw-table (origin rows h lay / widths ncol i w row-h total-w
                      total-h y x r c rot pad)
  (setq ncol (apply 'max (mapcar 'length rows))
        pad  (* h 0.6)
        row-h (* h 2.0)
        rot  (ep:ucs-angle))
  ;; Column widths from the longest text in each column.
  (setq widths nil i 0)
  (repeat ncol
    (setq w 0)
    (foreach r rows
      (if (nth i r) (setq w (max w (strlen (nth i r)))))
    )
    (setq widths (append widths (list (+ (* w h 0.85) (* pad 2.0))))
          i (1+ i))
  )
  (setq total-w (apply '+ widths)
        total-h (* row-h (length rows)))
  ;; Horizontal lines
  (setq y 0.0)
  (repeat (1+ (length rows))
    (ep:line (ep:uw origin 0.0 y) (ep:uw origin total-w y) lay)
    (setq y (+ y row-h))
  )
  ;; Vertical lines
  (setq x 0.0)
  (ep:line (ep:uw origin 0.0 0.0) (ep:uw origin 0.0 total-h) lay)
  (foreach w widths
    (setq x (+ x w))
    (ep:line (ep:uw origin x 0.0) (ep:uw origin x total-h) lay)
  )
  ;; Cell texts
  (setq y (/ row-h 2.0))
  (foreach r rows
    (setq x 0.0 c 0)
    (foreach w widths
      (if (and (nth c r) (/= (nth c r) ""))
        (ep:text (ep:uw origin (+ x pad) y) h (nth c r) lay rot)
      )
      (setq x (+ x w) c (1+ c))
    )
    (setq y (+ y row-h))
  )
  (princ (strcat "\nTablo cizildi: "
                 (itoa (length rows)) " satir"))
)

;;; Asks where to put the table and the text height, then draws it.
(defun ep:place-table (rows lay / pt h def)
  (initget "Evet Hayir")
  (if (/= (getkword "\nTablo cizime eklensin mi? [Evet/Hayir] <Evet>: ")
          "Hayir")
    (progn
      (setq pt (getpoint "\nTablonun sol ust kosesi (Enter = atla): "))
      (if pt
        (progn
          (setq def (getvar "TEXTSIZE"))
          (setq h (getdist pt (strcat "\nYazi yuksekligi <" (rtos def 2 2) ">: ")))
          (if (not h) (setq h def))
          (ep:ensure-layer lay 7)
          (ep:draw-table pt rows h lay)
        )
      )
    )
  )
)

;;; ------------------------------------------------------------
;;; Entity editing
;;; ------------------------------------------------------------

;;; Sets DXF group `code` of an entity to `val` (adds it when missing).
(defun ep:set-dxf (ent code val / ed old)
  (setq ed (entget ent))
  (if (setq old (assoc code ed))
    (setq ed (subst (cons code val) old ed))
    (setq ed (append ed (list (cons code val))))
  )
  (entmod ed)
  (entupd ent)
)

(defun ep:dxf (ent code) (cdr (assoc code (entget ent))))

;;; TEXT with a given justification (72 horizontal, 73 vertical).
;;; 72: 0 left 1 center 2 right   73: 0 base 1 bottom 2 middle 3 top
(defun ep:text-j (p h s lay rot j72 j73)
  (entmake (list '(0 . "TEXT")
                 (cons 8 lay)
                 (cons 10 p)
                 (cons 11 p)
                 (cons 40 h)
                 (cons 1 s)
                 (cons 50 rot)
                 (cons 7 (getvar "TEXTSTYLE"))
                 (cons 72 j72)
                 (cons 73 j73)))
)

;;; First number in a string: "L=12,5 m" -> 12.5, "-3" -> -3.0, none -> nil
(defun ep:first-number (s / i n ch out started dot)
  (setq i 1 n (strlen s) out "" started nil dot nil)
  (while (<= i n)
    (setq ch (substr s i 1))
    (cond
      ((wcmatch ch "#")
        (if (and (not started) (> i 1) (= (substr s (1- i) 1) "-"))
          (setq out "-")
        )
        (setq out (strcat out ch) started T)
      )
      ((and started (not dot) (member ch '("." ","))
            (< i n) (wcmatch (substr s (1+ i) 1) "#"))
        (setq out (strcat out ".") dot T)
      )
      (started (setq i n))
    )
    (setq i (1+ i))
  )
  (if started (atof out) nil)
)

;;; Attributes of an INSERT as ((TAG . value) ...)
(defun ep:attribs-get (ins / e ed out)
  (setq out nil e (entnext ins))
  (while (and e (= (cdr (assoc 0 (setq ed (entget e)))) "ATTRIB"))
    (setq out (cons (cons (strcase (cdr (assoc 2 ed))) (cdr (assoc 1 ed))) out)
          e (entnext e))
  )
  (reverse out)
)

;;; Writes values into the attributes whose tags match.
(defun ep:attribs-set (ins vals / e ed v)
  (setq e (entnext ins))
  (while (and e (= (cdr (assoc 0 (setq ed (entget e)))) "ATTRIB"))
    (if (setq v (assoc (strcase (cdr (assoc 2 ed))) vals))
      (entmod (subst (cons 1 (cdr v)) (assoc 1 ed) ed))
    )
    (setq e (entnext e))
  )
  (entupd ins)
)

;;; Inserts a block that exists in the drawing. pt in UCS, rot in radians
;;; (relative to the UCS X axis). Attributes get their default values.
;;; Needs ATTREQ / AUNITS / ANGBASE / ANGDIR saved by ep:begin.
(defun ep:insert (name pt scale rot lay / e)
  (setvar "ATTREQ" 0)
  (setvar "AUNITS" 0)
  (setvar "ANGBASE" 0.0)
  (setvar "ANGDIR" 0)
  (command "_.-INSERT" name "_S" scale "_R" (angtos rot 0 8) "_non" pt)
  (setq e (entlast))
  (if (and lay e (= (cdr (assoc 0 (entget e))) "INSERT"))
    (ep:set-dxf e 8 lay)
  )
  e
)

(setq ep:*insert-vars* '("ATTREQ" "AUNITS" "ANGBASE" "ANGDIR" "OSMODE"))

;;; Asks for a block name (default = last used); typing S lets the user
;;; pick a sample block instead. Returns a block name that exists, or nil.
(defun ep:ask-block (default / s e)
  (setq s (getstring T (strcat "\nBlok adi (S = ornek blok sec)"
                               (if default (strcat " <" default ">") "") ": ")))
  (cond
    ((= s "") (setq s default))
    ((= (strcase s) "S")
      (setq e (entsel "\nOrnek bloku secin: "))
      (setq s (if (and e (= (ep:dxf (car e) 0) "INSERT")) (ep:dxf (car e) 2) nil))
    )
  )
  (cond
    ((not s) nil)
    ((tblsearch "BLOCK" s) s)
    (T (princ (strcat "\nCizimde boyle bir blok yok: " s)) nil)
  )
)

;;; LWPOLYLINE from 2D WCS points.
(defun ep:lwpoly (pts closed lay)
  (entmake (append (list '(0 . "LWPOLYLINE")
                         '(100 . "AcDbEntity")
                         (cons 8 lay)
                         '(100 . "AcDbPolyline")
                         (cons 90 (length pts))
                         (cons 70 (if closed 1 0)))
                   (mapcar '(lambda (p) (cons 10 (list (car p) (cadr p)))) pts)))
)

;;; LINE endpoints in the current UCS.
(defun ep:line-ucs (e / ed)
  (setq ed (entget e))
  (list (trans (cdr (assoc 10 ed)) 0 1) (trans (cdr (assoc 11 ed)) 0 1))
)

;;; Projection of p onto the infinite line a-b (2D).
(defun ep:project (p a b / dx dy l2 k)
  (setq dx (- (car b) (car a)) dy (- (cadr b) (cadr a))
        l2 (+ (* dx dx) (* dy dy)))
  (if (< l2 1e-12)
    a
    (progn
      (setq k (/ (+ (* (- (car p) (car a)) dx) (* (- (cadr p) (cadr a)) dy)) l2))
      (list (+ (car a) (* k dx)) (+ (cadr a) (* k dy)) 0.0)
    )
  )
)

;;; Is p on segment a-b (within tol)?
(defun ep:on-seg (p a b tol)
  (< (abs (- (+ (distance (ep:2d a) (ep:2d p)) (distance (ep:2d p) (ep:2d b)))
             (distance (ep:2d a) (ep:2d b))))
     tol)
)

;;; Temporary preview of a point chain (cleared by REDRAW).
(defun ep:preview (pts / i)
  (setq i 0)
  (while (< i (1- (length pts)))
    (grdraw (nth i pts) (nth (1+ i) pts) 7 1)
    (setq i (1+ i))
  )
)

;;; Collects points with a rubber-band preview. Keywords: Close / Undo.
;;; Returns (points closed-flag); points are in the UCS.
(defun ep:collect-points (first-prompt / pts pt closed done)
  (setq pts nil closed nil done nil)
  (if (setq pt (getpoint first-prompt))
    (progn
      (setq pts (list pt))
      (while (not done)
        (initget "Kapat Geri")
        (setq pt (getpoint (last pts) "\nSonraki nokta [Kapat/Geri] (Enter = bitir): "))
        (cond
          ((null pt) (setq done T))
          ((= pt "Kapat")
            (if (> (length pts) 2) (setq closed T done T)
              (princ "\nKapatmak icin en az 3 nokta gerekir.")))
          ((= pt "Geri")
            (if (> (length pts) 1)
              (progn
                (setq pts (reverse (cdr (reverse pts))))
                (redraw)
                (ep:preview pts)
              )
            )
            (setq pt nil)
          )
          ((> (distance pt (last pts)) 1e-9)
            (grdraw (last pts) pt 7 1)
            (setq pts (append pts (list pt)))
          )
        )
      )
      (redraw)
    )
  )
  (list pts closed)
)

;;; YERINDEOLCEK - Her objeyi kendi yerlestirme noktasina gore olcekler (bloklar, yazilar).

;;; Base point of an object: justification point for aligned texts,
;;; insertion point for blocks and texts, nil otherwise.
(defun yo:base (e / ed typ)
  (setq ed (entget e) typ (cdr (assoc 0 ed)))
  (cond
    ((and (= typ "TEXT") (or (/= 0 (cdr (assoc 72 ed))) (/= 0 (cdr (assoc 73 ed)))))
      (cdr (assoc 11 ed)))
    ((member typ '("INSERT" "TEXT" "MTEXT" "CIRCLE" "ARC" "POINT")) (cdr (assoc 10 ed)))
    (T nil)
  )
)

(defun c:YERINDEOLCEK (/ *error* ss f n skip b)
  (defun *error* (m) (ep:on-error m))
  (princ "\nOlceklenecek bloklari / yazilari secin: ")
  (if (setq ss (ssget '((0 . "INSERT,TEXT,MTEXT,CIRCLE,ARC,POINT"))))
    (progn
      (initget 6)
      (if (setq f (getreal "\nOlcek katsayisi: "))
        (progn
          (ep:begin '("OSMODE"))
          (setvar "OSMODE" 0)
          (setq n 0 skip 0)
          (foreach e (ep:ss-list ss)
            (if (setq b (yo:base e))
              (progn
                (command "_.SCALE" e "" (trans b e 1) f)
                (setq n (1+ n))
              )
              (setq skip (1+ skip))
            )
          )
          (princ (strcat "\n" (itoa n) " obje olceklendi."))
          (ep:finish)
        )
      )
    )
  )
  (princ)
)


(princ "\n[eplisp] yuklendi. Komutlar: YERINDEOLCEK")
(princ)