;; ============================================================================
;; LegalExport.lsp  —  Civil 3D / AutoCAD / BricsCAD geometry exporter
;; for the LegalWriter web app
;; ----------------------------------------------------------------------------
;; Loads with APPLOAD, exposes one command:  LEGALEXPORT
;;
;; What it does:
;;   1. Prompts for a closed LWPOLYLINE (or chain of LINE/ARC entities).
;;   2. Optionally prompts for a commencement-path polyline.
;;   3. Asks for a description search radius.
;;   4. Collects nearby TEXT, MTEXT and block attributes named DESC.
;;   5. Writes a .json file with the exact schema the web app expects.
;;
;; The output JSON looks like:
;;   {
;;     "version": 1,
;;     "dwgName": "PARCEL01.dwg",
;;     "dwgPath": "C:/Drawings/PARCEL01.dwg",
;;     "exportedAt": "2025-04-21T12:00:00",
;;     "units": "Feet",
;;     "descRadius": 5.0,
;;     "boundary":     [ { "type":"L"|"A", "n1":..,"e1":..,"n2":..,"e2":..,"bulge":.. }, ... ],
;;     "commencement": [ ... same shape ... ],
;;     "descriptions": [ { "n":..,"e":..,"desc":"..." }, ... ]
;;   }
;;
;; Compatibility: AutoCAD 2018+, Civil 3D 2018+, BricsCAD V20+.
;; ============================================================================

(defun lw:json-escape (s / out i ch)
  (setq out "" i 1)
  (while (<= i (strlen s))
    (setq ch (substr s i 1))
    (cond
      ((= ch "\\") (setq out (strcat out "\\\\")))
      ((= ch "\"") (setq out (strcat out "\\\"")))
      ((= ch "\n") (setq out (strcat out "\\n")))
      ((= ch "\r") nil)
      ((= ch "\t") (setq out (strcat out "\\t")))
      (t           (setq out (strcat out ch))))
    (setq i (1+ i)))
  out)

(defun lw:num (n) (rtos n 2 6))

;; Convert a (selected) polyline or line/arc set into a list of segment
;; property-lists: ((TYPE N1 E1 N2 E2 BULGE) ...). North = Y, East = X.
(defun lw:polyline-segs (ent / obj n i pts segs p1 p2 b)
  (setq obj (vlax-ename->vla-object ent))
  (cond
    ((or (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
         (= (cdr (assoc 0 (entget ent))) "POLYLINE"))
      (setq n (vlax-curve-getEndParam ent) i 0 segs '())
      (while (< i n)
        (setq p1 (vlax-curve-getPointAtParam ent i)
              p2 (vlax-curve-getPointAtParam ent (1+ i))
              b  (vla-getBulge obj i))
        (if (and p2 (or (/= (car p1) (car p2)) (/= (cadr p1) (cadr p2))))
          (setq segs (cons
            (list (if (equal b 0.0 1e-9) "L" "A")
                  (cadr p1) (car p1)
                  (cadr p2) (car p2)
                  b) segs)))
        (setq i (1+ i)))
      (reverse segs))
    ((= (cdr (assoc 0 (entget ent))) "LINE")
      (list (list "L"
        (cadr (cdr (assoc 10 (entget ent)))) (car (cdr (assoc 10 (entget ent))))
        (cadr (cdr (assoc 11 (entget ent)))) (car (cdr (assoc 11 (entget ent))))
        0.0)))
    ((= (cdr (assoc 0 (entget ent))) "ARC")
      (lw:arc-to-seg ent))
    (t nil)))

(defun lw:arc-to-seg (ent / d cen r a1 a2 sp ep delta b)
  (setq d   (entget ent)
        cen (cdr (assoc 10 d))
        r   (cdr (assoc 40 d))
        a1  (cdr (assoc 50 d))
        a2  (cdr (assoc 51 d)))
  (setq sp (polar cen a1 r) ep (polar cen a2 r))
  (setq delta (- a2 a1))
  (if (< delta 0) (setq delta (+ delta (* 2 pi))))
  ;; AutoCAD ARC sweeps CCW from a1 to a2; bulge for CCW > 0
  (setq b (/ (sin (/ delta 4.0)) (cos (/ delta 4.0))))
  (list (list "A" (cadr sp) (car sp) (cadr ep) (car ep) b)))

(defun lw:seg->json (s)
  (strcat "    {\"type\":\"" (nth 0 s)
          "\",\"n1\":" (lw:num (nth 1 s))
          ",\"e1\":"   (lw:num (nth 2 s))
          ",\"n2\":"   (lw:num (nth 3 s))
          ",\"e2\":"   (lw:num (nth 4 s))
          ",\"bulge\":" (lw:num (nth 5 s))
          "}"))

(defun lw:segs->json (segs)
  (if (null segs) "[]"
    (strcat "[\n"
      (apply 'strcat
        (mapcar (function (lambda (s)
          (strcat (lw:seg->json s)
                  (if (eq s (last segs)) "\n" ",\n"))))
          segs))
      "  ]")))

;; Collect description points within bounding box of the boundary plus radius.
(defun lw:collect-descs (segs radius / box minN minE maxN maxE ss n i ent d e ip txt out)
  (setq minN 1e99 minE 1e99 maxN -1e99 maxE -1e99)
  (foreach s segs
    (setq minN (min minN (nth 1 s) (nth 3 s))
          minE (min minE (nth 2 s) (nth 4 s))
          maxN (max maxN (nth 1 s) (nth 3 s))
          maxE (max maxE (nth 2 s) (nth 4 s))))
  (setq minN (- minN radius) minE (- minE radius)
        maxN (+ maxN radius) maxE (+ maxE radius))
  (setq ss (ssget "_C" (list minE minN) (list maxE maxN)
                  '((0 . "TEXT,MTEXT,INSERT")))
        out '())
  (if ss
    (progn
      (setq i 0 n (sslength ss))
      (while (< i n)
        (setq ent (ssname ss i)
              d   (entget ent)
              e   (cdr (assoc 0 d))
              ip  (cdr (assoc 10 d)))
        (cond
          ((or (= e "TEXT") (= e "MTEXT"))
            (setq txt (cdr (assoc 1 d)))
            (if (and txt (/= txt ""))
              (setq out (cons (list (cadr ip) (car ip) txt) out))))
          ((= e "INSERT")
            (setq txt (lw:get-attrib ent "DESC"))
            (if txt
              (setq out (cons (list (cadr ip) (car ip) txt) out)))))
        (setq i (1+ i)))))
  (reverse out))

(defun lw:get-attrib (ent tag / e a out)
  (setq e (entnext ent) out nil)
  (while (and e (not out))
    (setq a (entget e))
    (if (and (= (cdr (assoc 0 a)) "ATTRIB")
             (= (strcase (cdr (assoc 2 a))) (strcase tag)))
      (setq out (cdr (assoc 1 a))))
    (setq e (entnext e)))
  out)

(defun lw:descs->json (descs)
  (if (null descs) "[]"
    (strcat "[\n"
      (apply 'strcat
        (mapcar (function (lambda (d)
          (strcat "    {\"n\":" (lw:num (nth 0 d))
                  ",\"e\":"     (lw:num (nth 1 d))
                  ",\"desc\":\"" (lw:json-escape (nth 2 d)) "\"}"
                  (if (eq d (last descs)) "\n" ",\n"))))
          descs))
      "  ]")))

(defun c:LEGALEXPORT ( / bndEnt comEnt radius bndSegs comSegs descs
                       fname f units now)
  (princ "\n[LegalWriter] Select boundary polyline (or LINE/ARC chain start):")
  (setq bndEnt (car (entsel "\nBoundary entity: ")))
  (if (null bndEnt) (progn (princ "\nCancelled.") (exit)))
  (setq bndSegs (lw:polyline-segs bndEnt))
  (if (null bndSegs)
    (progn (princ "\nUnsupported entity type. Use LWPOLYLINE, LINE, or ARC.") (exit)))

  (initget "Yes No")
  (if (= (getkword "\nInclude commencement path? [Yes/No] <No>: ") "Yes")
    (progn
      (princ "\nSelect commencement polyline:")
      (setq comEnt (car (entsel "\nCommencement entity: ")))
      (if comEnt (setq comSegs (lw:polyline-segs comEnt))))
    (setq comSegs nil))

  (setq radius (getreal "\nDescription search radius <5.0>: "))
  (if (null radius) (setq radius 5.0))

  (setq descs (lw:collect-descs bndSegs radius))

  (setq fname (getfiled "Save geometry JSON" "" "json" 1))
  (if (null fname) (progn (princ "\nCancelled.") (exit)))

  ;; ISO timestamp using $cdate (YYYYMMDD.HHMMSS)
  (setq now (rtos (getvar "CDATE") 2 6))
  (setq units (cond ((= (getvar "INSUNITS") 6) "Meters")
                    (t "Feet")))

  (setq f (open fname "w"))
  (write-line "{" f)
  (write-line "  \"version\": 1," f)
  (write-line (strcat "  \"dwgName\": \""
                      (lw:json-escape (getvar "DWGNAME")) "\",") f)
  (write-line (strcat "  \"dwgPath\": \""
                      (lw:json-escape (getvar "DWGPREFIX")) "\",") f)
  (write-line (strcat "  \"exportedAt\": \"" now "\",") f)
  (write-line (strcat "  \"units\": \"" units "\",") f)
  (write-line (strcat "  \"descRadius\": " (lw:num radius) ",") f)
  (write-line (strcat "  \"boundary\": " (lw:segs->json bndSegs) ",") f)
  (if comSegs
    (write-line (strcat "  \"commencement\": " (lw:segs->json comSegs) ",") f))
  (write-line (strcat "  \"descriptions\": " (lw:descs->json descs)) f)
  (write-line "}" f)
  (close f)
  (princ (strcat "\n[LegalWriter] Wrote " fname))
  (princ "\nNow upload this file at the LegalWriter web app.")
  (princ))

(princ "\n[LegalWriter] Loaded. Type LEGALEXPORT to begin.")
(princ)