;;;  DIM.LSP   Extended Dimensioning routines esp. for Architects
;;;  for AutoCAD 12/13 Dos/Windows
;;;
;;;  Copyright (c) 1996,97 by Christoph Candido
;;;  E-Mail: h8540418@edv1.boku.ac.at
;;;
;;;  Permission to use, copy, modify, and distribute this software
;;;  for any purpose and without fee is hereby granted, provided
;;;  that the above copyright notice appears in all copies and that
;;;  both that copyright notice and this permission notice appear in
;;;  all supporting documentation.
;;;
;;;  THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
;;;  WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
;;;  PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;  Last Revision:
;;;    05.08.1997 CC  (dtrim)
;;;    06.08.1997 CC  (dtrim) calculate angle for aligned dim
;;;
(defun setsys ()
  (sysvar 
    '( ("TEXTEVAL" 1)
       ("CMDECHO" 0)
       ("DIMASO" 1)
       ("DIMZIN" 8)
     )
  )     
)

;;;  Routine: DIMH  16.12.96 (C) Candido
;;;
;;;  Horizontal linear dimensioning with fixed extension lines length.
;;;
(defun C:DIMH (/ oerr osys cmd)
  (setq oerr *error*
        *error* *dim_err*
        osys (setsys)
  )
  (if (not *EXTLEN*) (setq *EXTLEN* (get_extl)))
  (command "_.DIM")
  (setq cmd (getvar "CMDNAMES"))
  (setvar "CMDECHO" 1)
  (command "_HOR")
  (while (/= cmd (getvar "CMDNAMES"))
    (command pause)
  )
  (setvar "CMDECHO" 0)
  (command "_EXIT")
  (if *EXTLEN* (dtrim (entlast) *EXTLEN*))
  (if *DIMSUP* (dimsup (entlast)))
  (sysvar osys)
  (setq *error* oerr)
  (princ)
)

;;;  Routine: DIMV  16.12.96 (C) Candido
;;;
;;;  Vertical linear dimensioning with fixed extension lines length.
;;;
(defun C:DIMV (/ oerr osys cmd)
  (setq oerr *error*
        *error* *dim_err*
        osys (setsys)
  )
  (if (not *EXTLEN*) (setq *EXTLEN* (get_extl)))
  (command "_.DIM")
  (setq cmd (getvar "CMDNAMES"))
  (setvar "CMDECHO" 1)
  (command "_VER")
  (while (/= cmd (getvar "CMDNAMES"))
    (command pause)
  )
  (setvar "CMDECHO" 0)
  (command "_EXIT")
  (if *EXTLEN* (dtrim (entlast) *EXTLEN*))
  (if *DIMSUP* (dimsup (entlast)))
  (sysvar osys)
  (setq *error* oerr)
  (princ)
)

;;;  Routine: DIMA  16.12.96 (C) Candido
;;;
;;;  Aligned linear dimensioning with fixed extension lines length.
;;;
(defun C:DIMA (/ oerr osys cmd)
  (setq oerr *error*
        *error* *dim_err*
        osys (setsys)
  )
  (if (not *EXTLEN*) (setq *EXTLEN* (get_extl)))
  (command "_.DIM")
  (setq cmd (getvar "CMDNAMES"))
  (setvar "CMDECHO" 1)
  (command "_AL")
  (while (/= cmd (getvar "CMDNAMES"))
    (command pause)
  )
  (setvar "CMDECHO" 0)
  (command "_EXIT")
  (if *EXTLEN* (dtrim (entlast) *EXTLEN*))
  (if *DIMSUP* (dimsup (entlast)))
  (sysvar osys)
  (setq *error* oerr)
  (princ)
)

;;;  Routine: DIMC  16.12.96 (C) Candido
;;;
;;;  Continued dimensioning with fixed extension lines length.
;;;
(defun C:DIMC (/ oerr osys cmd)
  (setq oerr *error*
        *error* *dim_err*
        osys (setsys)
  )
  (if (not *EXTLEN*) (setq *EXTLEN* (get_extl)))
  (command "_.DIM")
  (setq cmd (getvar "CMDNAMES"))
  (setvar "CMDECHO" 1)
  (command "_CONT")
  (while (/= cmd (getvar "CMDNAMES"))
    (command pause)
  )
  (setvar "CMDECHO" 0)
  (command "_EXIT")
  (if *EXTLEN* (dtrim (entlast) *EXTLEN*))
  (if *DIMSUP* (dimsup (entlast)))
  (sysvar osys)
  (setq *error* oerr)
  (princ)
)

;;;  Routine: DIMCUT  16.12.96 (C) Candido
;;;
;;;  Adapt (Trim/Extend) dimension extension lines.
;;;
(defun C:DIMCUT (/ oerr osys i ssl flag) 
  (setq oerr *error*
        *error* *dim_err*
        osys (setsys)
        i 0
  )      
  (if (not *EXTLEN*) (setq *EXTLEN* (get_extl)))
  (if (setq ssl (sslist (ssget '((0 . "DIMENSION")))))
    (progn
      (command "_.UNDO" "_Group")
      (foreach en ssl
        (setq flag (dxf 70 (entget en)))
        (if (not (apply 'or (mapcar '(lambda (x) (= x (logand x flag))) 
                                    '(2 3 4 5 6 70))))
          (progn
            (setq i (1+ i))
            (if *EXTLEN* (dtrim en *EXTLEN*))
            (if *DIMSUP* (dimsup en))
          )
        )
      )
      (command "_.UNDO" "_End")
      (princ (strcat "\n" (itoa i) " dimension(s) changed. "))
    )  
  )
  (sysvar osys)
  (setq *error* oerr)
  (princ)
)

;;;  Routine: DIMSUP  04.05.97 (C) Candido
;;;
;;;  Superscript dimension text digits after decimal point.
;;;
(defun C:DIMSUP (/ oerr osys ss i en delim)
  (setq oerr *error*
     *error* *dim_err*
        osys (setsys)
  )
  (initget 128 "None")
  (while 
    (and (not 
           (member
             (setq delim (getkword "\nMeter-Delimiter/None/<.>: "))
             '(nil "None")
           )  
         )
         (wcmatch delim "@")
    )
    (princ "\n* only one nonalphabetical character allowed! * ")
    (initget 128 "None")
  )
  (if (not delim) (setq delim "."))
  (if (= "None" delim) (setq delim ""))
  (setq ss (ssget '((0 . "DIMENSION"))) 
         i 0
  )
  (command "_.UNDO" "_End" "_.UNDO" "_Group")
  (if ss
    (progn
      (command "_.DIM" "_Update" ss "" "_Exit")
      (while (setq en (ssname ss i))
        (dimsup en delim)
        (setq i (1+ i))
      )
    )
  )
  (command "_.UNDO" "_End")
  (sysvar osys)  
  (setq *error* oerr)
  (princ)
)

(defun dimsup (en0 delim / ent0 blkent en ent txt l1 num l2 n prfx sufx i c 
                           ntxt l)
  (setq   ent0 (entget en0 '("*"))
        blkent (tblsearch "block" (cdr (assoc 2 ent0)))
            en (cdr (last blkent))
  )
  (while (not (member (cdr (assoc 0 (setq ent (entget en '("*")))))
                      '("TEXT" "MTEXT")))
    (setq en (entnext en))
  )
  (setq txt (cdr (assoc 1 ent))
         l1 (strlen txt)
        num (getnum txt)
  )
  (if num
    (progn
      (setq  l2 (strlen num)
            num (distof num)
              n (fix num)
           prfx (itoa n)
      )
      (if (> n 100)
        (setq l (strlen prfx)
              prfx (strcat (substr prfx 1 (- l 2)) delim
                           (substr prfx (1- l))
                   )
        )
      )  
      (setq ntxt (strcat (substr txt 1 (- l1 l2)) prfx)
            sufx ""
               i l1
      )                 
      (if (/= n num) 
        (progn
          (while (/= "." (setq c (substr txt i 1)))
            (setq sufx (strcat c sufx)
                     i (1- i)
            )
          )
          (if (= "TEXT" (cdr (assoc 0 ent)))
            (setq ntxt (strcat ntxt "%%190" sufx "%%212"))
            (setq ntxt (strcat ntxt "\\S" sufx ";"))
          )
        )  
      )  
      (setq ent (subst (cons 1 ntxt) (assoc 1 ent) ent))
      (entmod ent)
      (entupd en0)
    )
  )    
  (princ)
)

;;; Get extension lines length:
(defun get_extl (/ l)
  (setq l 300.00)
)

(defun to2d (pt)
  (list (car pt) (cadr pt))
)

;;; Trim dimension extension lines:
;;; rev. 05.08.1997  CC
;;;      06.08.1997  CC
;;;

(defun dtrim (en l / ent ang p1 p2 p3 p4 ang2)
  ;; en is entity to trim
  ;; ext-line length to use is variable l, passed by calling routine such as 
  ;; DIMCUT and uses the value currently in variable *EXTLEN*

  (setq ent (entget en)
         p1 (to2d (cdr (assoc 10 ent)))
         p2 (to2d (cdr (assoc 14 ent)))
         p3 (to2d (cdr (assoc 13 ent)))
        ang (if (= 1 (logand 1 (cdr (assoc 70 ent))))
              (angle p3 p2)                 ; if aligned, calculate angle
              (cdr (assoc 50 ent))
            )
         p4 (inters p1 (polar p1 ang 1) 
                    p3 (polar p3 (+ ang (/ pi 2)) 1) 
                    nil
            )
  )
  ;; the direction of the new extension lines depends on the first
  ;; extension line or, if there is no first extension line, on the
  ;; second. If there are no extension lines at all, the direction will 
  ;; be calculated to (- ang (/ pi 2)) ... ang = angle of dimension line.  
     
  (if (not (equal p3 p4 0.0001))
    (setq p3 (polar p4 (angle p4 p3) l))
  )
  (if (not (equal p1 p2 0.0001))
    (setq p2 (polar p1 (angle p1 p2) l))
  )  
  (setq ent (subst (cons 14 p2) (assoc 14 ent) ent)
        ent (subst (cons 13 p3) (assoc 13 ent) ent)
  )
  (entmod ent)
)




;;; Error function:
(defun *dim_err* (s)
  (setvar "CMDECHO" 0)
  (if (/= "" (getvar "CMDNAMES"))
    (command "_EXIT")
  )
  (command "_.UNDO" "_End")  
  (sysvar osys)
  (setq *error* oerr)
  (princ)
)  

;;;  Function: SYSVAR
;;;
;;;  Set and restore system variables.
;;;
(defun sysvar (l)
  (mapcar 
    '(lambda (x / var val vlist)
       (setq var (if (listp x) (car x) x)
             val (if (listp x) (eval (cadr x)) nil)
           vlist (list var (getvar var))
       )
       (if val (setvar var val))
       vlist
     )
     l      
  )
)

;;;  convert selection set to list,
;;;  Note: it's also wise to use ai_ssget, because some ents could be
;;;        on locked layers
;;;  Ex: (sslist (ai_ssget (ssget))) => list of selected unlocked ents
;;;  or  (mapcar 'entupd (sslist (ssget "X" '((8 . "TEMP")))))
;;;       - regens all entities on layer TEMP
(defun SSLIST (ss / n lst)
  (if (= (type ss) 'PICKSET)
    (repeat (setq n (sslength ss))
      (setq n (1- n)
            lst (cons (ssname ss n) lst)))))

;;;  Get DXF group code value:
(defun dxf (grp ele) (cdr (assoc grp ele)))


;;;  Extract number from end of text string:
(defun getnum (st / l numtxt)
  (setq l (strlen st))
  (while (and (/= 0 l)
              (/= "+" (substr st l 1))
              (distof (substr st l))
         )     
    (setq numtxt (substr st l))
    (setq l (1- l))
  )
  numtxt
)

(princ "\n******************************************")
(princ "\nCopyright (c) 1996,97 by Christoph Candido")
(princ "\nE-Mail: h8540418@edv1.boku.ac.at")
(princ "\n******************************************")
(princ "\nExtended dimensioning routines: ")
(princ "\n")
(princ "\nDIMH   ... horizontal linear dimensioning")
(princ "\nDIMV   ... vertical linear dimensioning")
(princ "\nDIMA   ... aligned linear dimensioning")
(princ "\nDIMC   ... continued linear dimensioning")
(princ "\nDIMCUT ... trim/extend dimension extension lines")
(princ "\nDIMSUP ... superscript digits after decimal point")
(princ)