;;; ==========================================================================
;;; BL-EXPORT.lsp - BREAKLINE CAD standard exporter
;;;
;;; Writes your drawing's LAYER, LINETYPE, BLOCK and TEXT STYLE tables to a
;;; single BREAKLINE export file, so we can draft your jobs in your standard
;;; instead of ours. Run it once. Run it again only if your standard changes.
;;;
;;;   Command:  BLEXPORT
;;;
;;; This routine READS ONLY. It creates nothing, changes nothing, deletes
;;; nothing, and does not save your drawing. Every value comes out of the
;;; drawing's symbol tables.
;;;
;;; Runs in AutoCAD and BricsCAD. Deliberately uses no ActiveX (vla-*) so it
;;; also runs under accoreconsole for headless checking.
;;;
;;; BREAKLINE - breakline.au
;;; ==========================================================================

(setq BL:SCHEMA "1.0")

;;; ------------------------------------------------------------------ utils

;; JSON string escape. AutoCAD forbids " and \ in layer names, but font file
;; names and linetype descriptions are free text, so escape defensively.
(defun bl:esc (s / out)
  (setq s (if s (vl-princ-to-string s) "") out "")
  (foreach c (vl-string->list s)
    (setq out
      (strcat out
        (cond ((= c 34) "\\\"")           ; "
              ((= c 92) "\\\\")           ; \
              ((= c 9)  "\\t")
              ((< c 32) "")               ; drop other control characters
              (t (chr c))))))
  out)

(defun bl:q (s) (strcat "\"" (bl:esc s) "\""))

;; rtos mode 2 is plain decimal, independent of the drawing's LUNITS setting,
;; so a survey drawing set to feet-and-inches still exports parseable numbers.
(defun bl:num (n)
  (cond ((null n) "null")
        ((= (type n) 'INT)  (itoa n))
        ((= (type n) 'REAL) (rtos n 2 6))
        (t (bl:q n))))

(defun bl:bool (v) (if v "true" "false"))

;; "key": value
(defun bl:kv (k v) (strcat (bl:q k) ":" v))

(defun bl:obj (pairs) (strcat "{" (bl:join pairs ",") "}"))

(defun bl:join (lst sep / out)
  (setq out "")
  (foreach s lst
    (setq out (if (= out "") s (strcat out sep s))))
  out)

;; Safe symbol-table lookup: returns the default when the group code is absent,
;; which happens on older drawings and across CAD packages.
(defun bl:get (ent code default / v)
  (if (setq v (assoc code ent)) (cdr v) default))

;; getvar on a system variable the host does not have is an ERROR, not nil, and
;; would abort the export. PRODUCT exists in both AutoCAD and BricsCAD but this
;; routine is meant to survive whatever a client is running, so ask carefully.
(defun bl:sysvar (name default / r)
  (setq r (vl-catch-all-apply 'getvar (list name)))
  (if (or (vl-catch-all-error-p r) (null r)) default r))

;;; ------------------------------------------------------------------ tables

;; Layer flags (code 70): 1 = frozen, 4 = locked.
;; Colour (code 62) is NEGATIVE when the layer is off - the magnitude is still
;; the colour, so report both rather than losing one.
(defun bl:layers (/ tb nm e col out)
  (setq out '())
  (setq tb (tblnext "LAYER" t))
  (while tb
    (setq nm (bl:get tb 2 ""))
    (setq e (entget (tblobjname "LAYER" nm)))
    (setq col (bl:get e 62 7))
    (setq out
      (cons
        (bl:obj
          (list
            (bl:kv "name"       (bl:q nm))
            (bl:kv "colour"     (bl:num (abs col)))
            (bl:kv "trueColour" (bl:num (bl:get e 420 nil)))   ; 24-bit, nil if ACI
            (bl:kv "linetype"   (bl:q (bl:get e 6 "CONTINUOUS")))
            (bl:kv "lineweight" (bl:num (bl:get e 370 -3)))    ; -3 = default
            (bl:kv "on"         (bl:bool (>= col 0)))
            (bl:kv "frozen"     (bl:bool (= 1 (logand 1 (bl:get e 70 0)))))
            (bl:kv "locked"     (bl:bool (= 4 (logand 4 (bl:get e 70 0)))))
            (bl:kv "plot"       (bl:bool (/= 0 (bl:get e 290 1))))))
        out))
    (setq tb (tblnext "LAYER")))
  (reverse out))

(defun bl:ltypes (/ tb nm out)
  (setq out '())
  (setq tb (tblnext "LTYPE" t))
  (while tb
    (setq nm (bl:get tb 2 ""))
    (setq out
      (cons
        (bl:obj
          (list
            (bl:kv "name"        (bl:q nm))
            (bl:kv "description" (bl:q (bl:get tb 3 "")))
            (bl:kv "patternLen"  (bl:num (bl:get tb 40 0.0)))))
        out))
    (setq tb (tblnext "LTYPE")))
  (reverse out))

;; Block flags (code 70): 1 = anonymous, 2 = has attributes, 4 = xref,
;; 8 = xref overlay. Anonymous blocks (*U, *D, hatch and dimension guts) are
;; skipped - they are not part of anyone's standard.
(defun bl:blocks (/ tb nm flags out)
  (setq out '())
  (setq tb (tblnext "BLOCK" t))
  (while tb
    (setq nm (bl:get tb 2 "") flags (bl:get tb 70 0))
    (if (and (/= 1 (logand 1 flags))
             (/= "*" (substr nm 1 1)))
      (setq out
        (cons
          (bl:obj
            (list
              (bl:kv "name"          (bl:q nm))
              (bl:kv "hasAttributes" (bl:bool (= 2 (logand 2 flags))))
              (bl:kv "isXref"        (bl:bool (= 4 (logand 4 flags))))))
          out)))
    (setq tb (tblnext "BLOCK")))
  (reverse out))

;; Style flags (code 70): 1 = shape file (not a text style), 4 = vertical.
(defun bl:styles (/ tb nm out)
  (setq out '())
  (setq tb (tblnext "STYLE" t))
  (while tb
    (setq nm (bl:get tb 2 ""))
    (if (and (/= 1 (logand 1 (bl:get tb 70 0))) (/= nm ""))
      (setq out
        (cons
          (bl:obj
            (list
              (bl:kv "name"        (bl:q nm))
              (bl:kv "font"        (bl:q (bl:get tb 3 "")))
              (bl:kv "bigFont"     (bl:q (bl:get tb 4 "")))
              (bl:kv "height"      (bl:num (bl:get tb 40 0.0)))
              (bl:kv "widthFactor" (bl:num (bl:get tb 41 1.0)))))
          out)))
    (setq tb (tblnext "STYLE")))
  (reverse out))

;;; ------------------------------------------------------------------ write

(defun bl:array (items) (strcat "[" (bl:join items ",") "]"))

;; The whole export. Returns the number of layers written, or nil on failure.
;; Kept separate from the command so it can be driven headlessly:
;;   (bl:export "C:/temp/out.bljson")
(defun bl:export (path / f layers ltypes blocks styles)
  (setq layers (bl:layers)
        ltypes (bl:ltypes)
        blocks (bl:blocks)
        styles (bl:styles))

  (setq f (open path "w"))
  (if (null f)
    (progn
      (princ (strcat "\nBREAKLINE: cannot write to " path))
      (princ "\nPick somewhere you have permission to save, and try again.")
      nil)
    (progn
      (write-line "{" f)
      (write-line (strcat "  " (bl:kv "format" (bl:q "BREAKLINE-CAD-EXPORT")) ",") f)
      (write-line (strcat "  " (bl:kv "schema" (bl:q BL:SCHEMA)) ",") f)
      (write-line (strcat "  " (bl:kv "product" (bl:q (bl:sysvar "PRODUCT" "unknown"))) ",") f)
      (write-line (strcat "  " (bl:kv "application" (bl:q (bl:sysvar "ACADVER" "unknown"))) ",") f)
      (write-line (strcat "  " (bl:kv "drawing" (bl:q (bl:sysvar "DWGNAME" ""))) ",") f)
      (write-line (strcat "  " (bl:kv "insUnits" (bl:num (bl:sysvar "INSUNITS" 0))) ",") f)
      (write-line (strcat "  " (bl:kv "layers"    (bl:array layers)) ",") f)
      (write-line (strcat "  " (bl:kv "linetypes" (bl:array ltypes)) ",") f)
      (write-line (strcat "  " (bl:kv "blocks"    (bl:array blocks)) ",") f)
      (write-line (strcat "  " (bl:kv "textStyles" (bl:array styles))) f)
      (write-line "}" f)
      (close f)
      (princ (strcat "\nBREAKLINE: wrote " (itoa (length layers)) " layers, "
                     (itoa (length ltypes)) " linetypes, "
                     (itoa (length blocks)) " blocks, "
                     (itoa (length styles)) " text styles"))
      (princ (strcat "\n           to " path))
      (length layers))))

(defun c:BLEXPORT (/ *error* old-err path dwg)
  (defun *error* (msg)
    (if (and msg (not (wcmatch (strcase msg) "*QUIT*,*CANCEL*")))
      (princ (strcat "\nBREAKLINE: stopped - " msg)))
    (princ "\nNothing in your drawing was changed.")
    (princ))

  (princ "\nBREAKLINE CAD standard exporter - reads your layer table, changes nothing.")

  ;; Default beside the drawing; unsaved drawings fall back to the temp folder.
  (setq dwg (getvar "DWGPREFIX"))
  (if (or (null dwg) (= dwg "")) (setq dwg (getenv "TEMP")))
  (setq path (strcat dwg "BREAKLINE-cad-standard.bljson"))

  (setq path (getfiled "Save BREAKLINE export" path "bljson" 1))
  (if (null path)
    (princ "\nBREAKLINE: cancelled. Nothing was written.")
    (bl:export path))
  (princ))

(princ "\nBL-EXPORT.lsp loaded.  Type BLEXPORT to export your CAD standard.")
(princ)