Monster Media 1993 #2/Image.iso/cad/jun93.zip/DTAB.LSP

Lisp/Scheme | 1993-03-30 | 6KB | 206 lines

;==========================================================
; DTAB.LSP Copyright 1993 by Looking Glass Microproducts
;==========================================================
; Justify Text its Decimal Point
;=============================================================
(defun C:DTAB (/ ERROR PUSHVARS POPVARS SYSVARS OLD-ERROR NOTRANS
               ITEM SS1 FILTER DTAB ONE_DTAB REPLACE BS SP BP PER
)
   (setq
      BS  "\010" ; back space
      SP  "\040" ; space
      BP  "\011" ; back period
      PER "."   ; period
   )
   ;==========================================================
   ; Error Handler
   (defun ERROR (S)
      (if (not
             (member
                S
                '("Function cancelled" "console break")
             )
          )
         (princ S)
      )
      (if UNDOIT
         (progn
            (princ "\nUndoing...")
            (command
               "_undo" "_end" "_undo" 1
            )
         )
      )
      (POPVARS)
      (princ)
   )
   ;==========================================================
   ; Set and Save System Variables
   (defun PUSHVARS (VLIST)
      (foreach PAIR VLIST
         (setq
            SYSVARS (cons
                       (cons
                          (strcase (car PAIR))
                          (getvar
                             (car PAIR)
                          )
                       )
                       SYSVARS
                    )
         )
         (if (cdr PAIR) (setvar (car PAIR) (cdr PAIR)))
      )
   )
   ;==========================================================
   ; Restore System Variables
   (defun POPVARS ()
      (foreach PAIR SYSVARS (setvar (car PAIR) (cdr PAIR)))
      (setq
         *error* OLD-ERROR
      )
      (setq SYSVARS nil)
   )
   ;==========================================================
   ; Disallow transparent invocation of routine.
   (defun NOTRANS ()
      (cond
         ((zerop (logand (getvar "cmdactive") (+ 1 2 4 8))))
         ((alert
             "This command may not be invoked transparently."
          )
         )
      )
   )
   ;==========================================================
   ; Item from association list
   (defun ITEM (A B) (cdr (assoc A B)))
   ;============================================================
   ; Something for the eyes on the status line
   (defun ENTERTAIN (PRMPT I SUFFIX)
      (setvar "modemacro" (strcat PRMPT (itoa I) SUFFIX))
   )
   ;=========================================================
   ; Apply func to every entity in ss
   (defun MAPSET (FUNC SS PRMPT / I L SUFFIX ENAME MM)
      (if SS
         (progn
            (setq
               FUNC   (eval FUNC)
               I      0
               L      (sslength SS)
               SUFFIX (strcat ":" (itoa L))
               MM     (getvar "modemacro")
            )
            (repeat
               L
               (setq ENAME (ssname SS 0) I (1+ I))
               (ssdel
                  ENAME
                  SS
               )
               (if PRMPT (ENTERTAIN PRMPT I SUFFIX))
               (FUNC
                  ENAME
               )
            )
            (setvar "modemacro" MM)
         )
      )
   )
   ;========================================================
   ; Return copy of selection set
   (defun SSCOPY (SS)
      (if SS (progn (command "_select" SS "") (ssget "p")))
   )
   ;==========================================================
   ; Replace item in association list
   (defun REPLACE (NEW_ITEM ALIST / OLD_ITEM)
      (if (setq OLD_ITEM (assoc (car NEW_ITEM) ALIST))
         (subst
            NEW_ITEM
            OLD_ITEM
            ALIST
         )
         (append ALIST (list NEW_ITEM))
      )
   )
   ;==========================================================
   ; Decimal tab one text entity
   (defun ONE_DTAB (ENAME / ENT VALUE I PREFIX)
      (setq ENT (entget ENAME) VALUE (ITEM 1 ENT))
      ; Strip leading control characters
      (while (< (substr VALUE 1 1) SP)
         (setq
            VALUE (substr VALUE 2)
         )
      )
      ; Add a backperiod plus backspace for each character before the period
      (setq PREFIX BP I 1)
      (while (/= (substr VALUE I 1) PER)
         (setq
            PREFIX (strcat BS PREFIX)
            I      (1+ I)
         )
      )
      (setq VALUE (strcat PREFIX VALUE))
      (entmod
         (REPLACE (cons 1 VALUE) ENT)
      )
   )
   ;==========================================================
   ; Main Routine
   (defun DTAB (/ SS2)
      (if (null SS1)
         (setq SS1 (ssget FILTER))
         (princ
            (strcat "\n" (itoa (sslength SS1)) " found.")
         )
      )
      (cond
         ((null SS1))
         (t
            (setvar "highlight" 0)
            (setq SS2 (SSCOPY SS1))
            (MAPSET
               'ONE_DTAB
               SS1
               "Justifying "
            )
            (command "_select" SS2 "")
            (setq SS1 nil SS2 nil)
         )
      )
   )
   ;==========================================================
   ; Body of c:dtab
   (if (NOTRANS)
      (progn
         (setq OLD-ERROR *error* *error* ERROR UNDOIT t)
         (setvar
            "cmdecho" 0
         )
         (setq
            FILTER '((0 . "TEXT")
                      (1 . "*`.*")
                      (72 . 0)
                      (73 . 0)
                   )
            SS1    (ssget "I" FILTER)
         )
         (command "_undo" "_group")
         (PUSHVARS
            '(("modemacro") ("highlight"))
         )
         (DTAB)
         (POPVARS)
         (command "_undo" "_end")
      )
   )
   (princ)
)
(princ
   "  DTAB.LSP (Copyright 1993 by Looking Glass Microproducts) loaded."
)
(princ)