;;; POINTSIN.LSP
;;;
;;; Copyright 2006 Thomas Gail Haws
;;; This program is free software under the terms of the
;;; GNU (GNU--acronym for Gnu's Not Unix--sounds like canoe)
;;; General Public License as published by the Free Software Foundation,
;;; version 2 of the License.
;;;
;;; You can redistribute this software for any fee or no fee and/or
;;; modify it in any way, but it and ANY MODIFICATIONS OR DERIVATIONS
;;; continue to be governed by the license, which protects the perpetual
;;; availability of the software for free distribution and modification.
;;;
;;; You CAN'T put this code into any proprietary package.  Read the license.
;;;
;;; If you improve this software, please make a revision submittal to the
;;; copyright owner at www.hawsedc.com.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License on the World Wide Web for more details.
;;;
;;; DESCRIPTION
;;;
;;; POINTSIN is a civil engineering and survey tool that reads point data
;;; (ID, North, East, Elevation, Description) from a file
;;; and inserts an attributed Softdesk-style POINT block
;;; and a 3d point in AutoCAD for every point in the file.
;;;
;;; You can change the POINT block if you prefer.  The order and graphical arrangement
;;; of the attributes doesn't matter. The default POINT block attributes are one unit high.
;;; POINTSIN scales the POINT block to the dimension text height
;;; (dimscale * dimtext), so the default POINT block will look as big as the current
;;; dimension text height.
;;;
;;; You can delete or comment out the lines that insert a 3d point or the POINT block.
;;; You can also comment out the lines that create and set layers.
;;;
;;; Revisions (latest first)
;;; 20100308  TGH  4   hr.  Version 1.0.2 Added ability to put points on layers by description.
;;; 20070126  TGH  0.2 hr.  Version 1.0.1 Fixed problem with empty fields.
;;; 20061017  TGH  0.2 hr.  Removed reference to HAWS-ENDSTR function.
;;; 20060928  TGH  0.5 hr.  Fixed problem with comment handling.
;;; 20060915  TGH  2   hr.  Version 1.0PR released.
;;; 20060915  TGH  1   hr.  Added error trapper and comment delimeters.

(DEFUN C:POINTSIN () (POINTSIN))

(DEFUN
   POINTSIN (/ 3DPOINTLAYER 3DPLAYERHASDESCRIPTION FILEFORMAT FNAME
             PBLAYERHASDESCRIPTION POINTBLOCKLAYER POINTSLIST
            )
  (PI:ERRORTRAP)
  (SETQ FILEFORMAT (PI:GETFILEFORMAT))
  (SETQ FNAME (GETFILED "Points data file" (PI:GETDNPATH) "" 0))
  (SETQ POINTSLIST (PI:GETPOINTSLIST FNAME FILEFORMAT))
  ;;Set up the point block layer.  
  ;;If you want each block to go on a layer whose name includes the point description,
  ;;use the code "/d" where you want the point description included (NCS/AIA/US example on next line).
  ;; (SETQ POINTBLOCKLAYER '("V-NODE-/d" "cyan"))
  ;;Comment out the following 2 lines if you want to use the current layer.
  (SETQ POINTBLOCKLAYER '("V-NODE-/d" "cyan"))
  (SETQ POINTBLOCKLAYER (PI:LAYERPARSE POINTBLOCKLAYER))
  ;;Insert point blocks.  Comment out the following line if you don't want point blocks.
  (PI:INSERTPOINTBLOCKS POINTSLIST)
  ;;Set up the 3d point layer.  Comment out the following 2 lines if you want to use the current layer.
  ;;If you want each 3d point to go on a layer whose name includes the point description,
  ;;use the code "/d" where you want the point description included (NCS/AIA/US example on next line).
  ;; (SETQ 3DPOINTLAYER '("V-NODE-3D~~-/d" "cyan"))
  (SETQ 3DPOINTLAYER '("V-NODE-3D~~-/d" "yellow"))
  (SETQ 3DPOINTLAYER (PI:LAYERPARSE 3DPOINTLAYER))
  ;;Insert 3d points.  Comment out the following line if you don't want 3d points.
  (PI:INSERT3DPOINTS POINTSLIST)
  (PI:ERRORRESTORE)
)


(DEFUN
   PI:ERRORTRAP ()
  (SETQ
    *PI:OLDERROR* *ERROR*
    *ERROR* *PI:ERROR*
  )
)

(DEFUN
   *PI:ERROR* (MESSAGE)
  (COND
    ((/= MESSAGE "Function cancelled")
     (PRINC (STRCAT "\nTrapped error: " MESSAGE))
    )
  )
  (COMMAND)
  (IF (= (TYPE F1) (QUOTE FILE))
    (SETQ F1 (CLOSE F1))
  )
  (IF *PI:OLDERR*
    (SETQ
      *ERROR* *PI:OLDERR*
      *PI:OLDERR* NIL
    )
  )
  (PRINC)
)

(DEFUN
   PI:ERRORRESTORE ()
  (SETQ
    F1 NIL
    *ERROR* *PI:OLDERR*
    *PI:OLDERR* NIL
  )
)


(DEFUN
   PI:GETFILEFORMAT (/ STDCOMMENT OPTION)
  (TEXTPAGE)
  ;;Show the various formats
  (PROMPT
    "\nSelect a file format:
	1. PNEZD (comma delimited)
	2. PNEZD (tab delimited)
	3. PENZD (comma delimited)
	4. PENZD (tab delimited)
" )
  ;;Set the allowed inputs and get one from user.
  (INITGET "1 2 3 4")
  (SETQ OPTION (GETKWORD "\n\n1/2/3/4: "))
  ;;Define the various formats by calling out the fields in order,
  ;;then specifying the field delimiter and the comment delimiter(s)
  ;;The field delimiter is a one-character string.
  ;;The comment delimiter is an AutoCAD style wild card string
  (SETQ STDCOMMENT ":,`#,;,'")
  (COND
    ((= OPTION "1")
     (LIST
       (LIST "POINT" "NORTH" "EAST" "ELEV" "DESC")
       ","
       STDCOMMENT
     )
    )
    ((= OPTION "2")
     (LIST
       (LIST "POINT" "NORTH" "EAST" "ELEV" "DESC")
       "\t"
       STDCOMMENT
     )
    )
    ((= OPTION "3")
     (LIST
       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")
       ","
       STDCOMMENT
     )
    )
    ((= OPTION "4")
     (LIST
       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")
       "\t"
       STDCOMMENT
     )
    )
  )
)

;;; PI:LAYERPARSE
;;; Returns a layerlist with the name (first element) parsed into
;;; part before /d and part after /d.  If no /d, returns only one element.
(DEFUN
   PI:LAYERPARSE
   (LAYERLIST / NAMELIST NAMESTRING GROWINGSTRING COUNTER)
  (SETQ
    NAMESTRING
     (CAR LAYERLIST)
    GROWINGSTRING ""
    COUNTER 0
  )
  (WHILE (< COUNTER (STRLEN NAMESTRING))
    (SETQ COUNTER (1+ COUNTER))
    (IF (= (STRCASE (SUBSTR NAMESTRING COUNTER 2)) "/D")
      (SETQ
        NAMELIST
         (CONS GROWINGSTRING NAMELIST)
        GROWINGSTRING ""
        COUNTER
         (1+ COUNTER)
      )
      (SETQ
        GROWINGSTRING
         (STRCAT
           GROWINGSTRING
           (SUBSTR NAMESTRING COUNTER 1)
         )
      )
    )
  )
  (CONS
    (REVERSE (CONS GROWINGSTRING NAMELIST))
    (CDR LAYERLIST)
  )
)

;;; PI:MAKELAYER
;;; Sets current layer.  Makes layer if required.
;;; The format of layerlist is '(([NAME BEFORE DESC] [NAME AFTER DESC OR NIL IF NOT USING DESC]) COLOR)
;;; The format of pointlist is '((XEAST YNORTH) POINT DESC ELEV)
(DEFUN
   PI:MAKELAYER (LAYERLIST POINTLIST / DWGLAYER NAMELIST LAYERCOLOR)
  (COND
    (LAYERLIST
     (SETQ
       NAMELIST
        (CAR LAYERLIST)
       LAYERNAME
        (STRCAT
          (CAR NAMELIST)
          (IF (CADR NAMELIST)
            (STRCAT (CADDR POINTLIST) (CADR NAMELIST))
            ""
          )
        )
       LAYERCOLOR
        (CADR LAYERLIST)
     )
     (COND
       ((AND
          ;; Layer exists in drawing
          (SETQ DWGLAYER (TBLSEARCH "LAYER" LAYERNAME))
          ;; Layer is already proper color
          (= (CDR (ASSOC 62 DWGLAYER)) (CADR LAYERLIST))
          ;; Layer isn't frozen
          (/= 1 (LOGAND (CDR (ASSOC 70 DWGLAYER)) 1))
        )
        ;; Set that layer current without using command interpreter
        (SETVAR "CLAYER" LAYERNAME)
       )
       (T
        ;; Else make layer using (command)
        (COMMAND
          "._layer" "_thaw" LAYERNAME "_make" LAYERNAME "_on" ""
          "_color" LAYERCOLOR "" ""
         )
       )
     )
    )
  )
)

(DEFUN
   PI:GETPOINTSLIST
   (FNAME FILEFORMAT / FIELD I POINTLIST POINTSLIST RDLIN)
  (SETQ F1 (OPEN FNAME "r"))
  (WHILE (SETQ RDLIN (READ-LINE F1))
    (SETQ
      I 0
      POINTLIST NIL
    )
    ;;Create a point list for the line if it's not a comment.
    (COND
      ((NOT (WCMATCH (SUBSTR RDLIN 1 1) (CADDR FILEFORMAT)))
       (FOREACH
          FIELD (CAR FILEFORMAT)
         (SETQ I (1+ I))
         (SETQ
           POINTLIST
            (CONS
              (CONS
                FIELD
                (PI:RDFLD I RDLIN (CADR FILEFORMAT) 1)
              )
              POINTLIST
            )
         )
       )
       ;;Add point to list if there is a northing and easting
       (IF (AND
             (DISTOF (CDR (ASSOC "EAST" POINTLIST)))
             (DISTOF (CDR (ASSOC "NORTH" POINTLIST)))
           )
         (SETQ
           POINTSLIST
            (CONS
              (LIST
                (LIST
                  (ATOF (CDR (ASSOC "EAST" POINTLIST)))
                  (ATOF (CDR (ASSOC "NORTH" POINTLIST)))
                )
                (CDR (ASSOC "POINT" POINTLIST))
                (CDR (ASSOC "DESC" POINTLIST))
                (CDR (ASSOC "ELEV" POINTLIST))
              )
              POINTSLIST
            )
         )
       )
      )
    )
  )
  (SETQ F1 (CLOSE F1))
  POINTSLIST
)

(DEFUN
   PI:INSERTPOINTBLOCKS (POINTSLIST / AROLD AT AV EL EN ET N POINTLIST)
  (COMMAND "._undo" "_group")
  (SETQ AROLD (GETVAR "attreq"))
  (SETVAR "attreq" 0)
  ;;Insert a Softdesk style block
  (FOREACH
     ;; The format of pointlist is '((XEAST YNORTH) POINT DESC ELEV)
     POINTLIST POINTSLIST
    (PI:MAKELAYER POINTBLOCKLAYER POINTLIST)
    (COMMAND
      "._insert"
      "point"
      (CAR POINTLIST)
      (* (GETVAR "dimscale") (GETVAR "dimtxt"))
      ""
      0
    )
    (SETQ EN (ENTLAST))
    ;;Fill in attributes
    (WHILE (AND
             (SETQ EN (ENTNEXT EN))
             (/= "SEQEND"
                 (SETQ ET (CDR (ASSOC 0 (SETQ EL (ENTGET EN)))))
             ) ;_ end of /=
           ) ;_ end of and
      (COND
        ((= ET "ATTRIB")
         (SETQ
           AT (CDR (ASSOC 2 EL))
           AV (CDR (ASSOC 1 EL))
         ) ;_ end of setq
         (COND
           ((SETQ N (MEMBER AT '("ELEV" "DESC" "POINT")))
            (ENTMOD
              (SUBST
                (CONS 1 (NTH (LENGTH N) POINTLIST))
                (ASSOC 1 EL)
                EL
              ) ;_ end of SUBST
            ) ;_ end of ENTMOD
           )
         ) ;_ end of cond
         (ENTUPD EN)
        )
      ) ;_ end of cond
    ) ;_ end of while
  )
  (SETVAR "attreq" AROLD)
  (COMMAND "._undo" "_end")
)

(DEFUN
   PI:INSERT3DPOINTS (POINTSLIST / POINTLIST)
  (COMMAND "._undo" "_group")
  (FOREACH
     POINTLIST POINTSLIST
    (PI:MAKELAYER 3DPOINTLAYER POINTLIST)
    (COMMAND
      "._point"
      (REVERSE
        (CONS (ATOF (CADDDR POINTLIST)) (REVERSE (CAR POINTLIST)))
      )
    )
  )
  (COMMAND "._undo" "_end")
)

;;Read fields from a text string delimited by a field width or a delimiter
;;character.
;;Usage: (PI:RDFLD
;;         [field number]
;;         [string containing fields]
;;         [uniform field width, field delimiter character, or "W" for words separated by one or more spaces]
;;         [sum of options: 1 (non-numerical character field)
;;                          2 (unlimited length field at end of string)
;;         ]
;;       )
(DEFUN
   PI:RDFLD (FLDNO STRING FLDWID OPT / ISCHR ISLONG I J ATOMX CHAR
             CHARPREV LITERAL FIRSTQUOTE
            )
  (SETQ
    ISCHR
     (= 1 (LOGAND 1 OPT))
    ISLONG
     (= 2 (LOGAND 2 OPT))
  ) ;_ end of setq
  (COND
    ((= FLDWID "W")
     (SETQ
       I 0
       J 0
       ATOMX ""
       CHAR " "
     ) ;_ end of setq
     (WHILE (AND (/= I FLDNO) (< J (STRLEN STRING))) ;_ end of and
       ;;Save previous character unless it was literal
       (SETQ
         CHARPREV
          (IF LITERAL
            ""
            CHAR
          ) ;_ end of IF
         ;;Get new character
         CHAR
          (SUBSTR STRING (SETQ J (1+ J)) 1)
       ) ;_ end of setq
       ;;Find if new character is literal or a doublequote
       (COND
         ((= CHAR (SUBSTR STRING J 1) "\"")
          (IF (NOT LITERAL)
            (SETQ LITERAL T)
            (SETQ LITERAL NIL)
          ) ;_ end of if
          (IF (NOT FIRSTQUOTE)
            (SETQ FIRSTQUOTE T)
            (SETQ FIRSTQUOTE NIL)
          ) ;_ end of if
         )
         (T (SETQ FIRSTQUOTE NIL))
       ) ;_ end of cond
       (IF (AND
             (WCMATCH CHARPREV " ,\t")
             (NOT (WCMATCH CHAR " ,\t,\n"))
           )
         (SETQ I (1+ I))
       ) ;_ end of if
     ) ;_ end of while
     (WHILE (AND
              (OR ISLONG LITERAL (NOT (WCMATCH CHAR " ,\t,\n"))) ;_ end of or
              (<= J (STRLEN STRING))
            ) ;_ end of and
       (IF (NOT FIRSTQUOTE)
         (SETQ ATOMX (STRCAT ATOMX CHAR))
       ) ;_ end of if
       (SETQ CHAR (SUBSTR STRING (SETQ J (1+ J)) 1))
       (COND
         ((= CHAR "\"")
          (IF (NOT LITERAL)
            (SETQ LITERAL T)
            (SETQ LITERAL NIL)
          ) ;_ end of if
          (IF (NOT FIRSTQUOTE)
            (SETQ FIRSTQUOTE T)
            (SETQ FIRSTQUOTE NIL)
          ) ;_ end of if
         )
         (T (SETQ FIRSTQUOTE NIL))
       ) ;_ end of cond
     ) ;_ end of while
    )
    ((= (TYPE FLDWID) 'STR)
     (SETQ
       I 1
       J 0
       ATOMX ""
     ) ;_ end of setq
     (WHILE (AND
              (/= I FLDNO)
              (IF (> (SETQ J (1+ J)) 1000)
                (PROMPT "\nFields or delimiters missing?")
                T
              ) ;_ end of if
            ) ;_ end of and
       (IF (= (SETQ CHAR (SUBSTR STRING J 1)) "\"")
         (IF (NOT LITERAL)
           (SETQ LITERAL T)
           (SETQ LITERAL NIL)
         ) ;_ end of if
       ) ;_ end of if
       (IF (AND (NOT LITERAL) (= (SUBSTR STRING J 1) FLDWID))
         (SETQ I (1+ I))
       ) ;_ end of if
     ) ;_ end of while
     (WHILE
       (AND
         (OR (/= (SETQ CHAR (SUBSTR STRING (SETQ J (1+ J)) 1)) FLDWID)
             LITERAL
         ) ;_ end of or
         (<= J (STRLEN STRING))
       ) ;_ end of and
        (COND
          ((= CHAR "\"")
           (IF (NOT LITERAL)
             (SETQ LITERAL T)
             (SETQ LITERAL NIL)
           ) ;_ end of if
           (IF (NOT FIRSTQUOTE)
             (SETQ FIRSTQUOTE T)
             (SETQ FIRSTQUOTE NIL)
           ) ;_ end of if
          )
          (T (SETQ FIRSTQUOTE NIL))
        ) ;_ end of cond
        (IF (NOT FIRSTQUOTE)
          (SETQ ATOMX (STRCAT ATOMX CHAR))
        ) ;_ end of if
     ) ;_ end of while
     (IF (AND ISCHR (NOT ISLONG))
       (SETQ ATOMX (PI:RDFLD-UNPAD ATOMX))
     )
    )
    (T
     (SETQ
       ATOMX
        (SUBSTR
          STRING
          (1+ (* (1- FLDNO) FLDWID))
          (IF ISLONG
            1000
            FLDWID
          ) ;_ end of if
        ) ;_ end of substr
     ) ;_ end of setq
     (IF (AND ISCHR (NOT ISLONG))
       (SETQ ATOMX (PI:RDFLD-UNPAD ATOMX))
     )
    )
  ) ;_ end of cond
  (SETQ
    ATOMX
     (IF ISCHR
       ATOMX
       (DISTOF ATOMX)
     ) ;_ end of if
  ) ;_ end of setq
) ;_ end of defun

;;Strip white space from beginning and end of a string
(DEFUN
   PI:RDFLD-UNPAD (STR)
  (WHILE (WCMATCH (SUBSTR STR 1 1) " ,\t")
    (SETQ STR (SUBSTR STR 2))
  ) ;_ end of while
  (IF (/= STR "")
    (WHILE (WCMATCH (SUBSTR STR (STRLEN STR)) " ,\t")
      (SETQ STR (SUBSTR STR 1 (1- (STRLEN STR))))
    ) ;_ end of while
  )
  STR
)


(DEFUN
   PI:GETDNPATH (/ DNPATH)
  (SETQ DNPATH (GETVAR "dwgname")) ;_ end of setq
  (IF (WCMATCH (STRCASE DNPATH) "*`.DWG")
    (SETQ
      DNPATH
       (STRCAT (GETVAR "dwgprefix") DNPATH)
      DNPATH
       (SUBSTR DNPATH 1 (- (STRLEN DNPATH) 4))
    ) ;_ end of setq
  ) ;_ end of if
  DNPATH
) ;_ end of defun
;|«Visual LISP© Format Options»
(72 2 40 2 nil "end of " 60 2 2 2 1 nil nil nil T)
;*** DO NOT add text below the comment! ***|;