Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
AQ1989

Nhờ Lý Giải Thuật Toán Lisp

Các bài được khuyến nghị

AQ1989    5
 

(DEFUN c:NCSDL () (PI:POINTSIN))

 

(DEFUN

   PI:POINTSIN (/  FILEFORMAT FNAME NODELAYERFORMAT 

                POINTBLOCKLAYERFORMAT POINTFORMAT POINTSLIST

               )

  (SETQ POINTFORMAT (PI:GETPOINTFORMAT))

  (SETQ FILEFORMAT (PI:GETFILEFORMAT))

  (SETQ FNAME (GETFILED "CHON FILE TEXT" (PI:GETDNPATH) "" 0))

  (SETQ POINTSLIST (PI:GETPOINTSLIST FNAME FILEFORMAT POINTFORMAT))

  ;; Chèn điểm vào block

  (PI:INSERTPOINTBLOCKS POINTSLIST POINTFORMAT)

  ;; chèn điểm 3d

  (PI:INSERT3DPOINTS POINTSLIST POINTFORMAT)

)

; Chọn định dạng format kiểu dữ liệu

(DEFUN

   PI:GETPOINTFORMAT ()

  '(

    ;; format point ở dạng 3D " STT,X,Y,Z "

    ("XYZNAMES" "EAST" "NORTH" "ELEV")

    ;; Format pont ở định dang 2D "STT,X,Y"

    ;; '("XYZNAMES" "EAST" "NORTH" nil)

    ;; ========================================================================

    ;; Tạo Ghi chú điểm " Node "

    ("DESCNAME" . "DESC")

    ;; ========================================================================

    ;; Danh sách các tagname nối với  file block attribute point.dwg

    ("TAGNAMES" "NORTH" "EAST" "POINT" "DESC" "ELEV")

   )

  ;; ========================================================================

)

 

(DEFUN

   PI:SETVAR (VAR-NAME VAR-VAL)

  ;; Populate the settings list so it's complete and we know we are not setting an unknown (maverick) setting.

  (PI:GETVAR VAR-NAME)

  ;; Put the requested value in the settings list

  (SETQ

    *PI:SETTINGS*

     (SUBST

       (CONS VAR-NAME VAR-VAL)

       (ASSOC VAR-NAME *PI:SETTINGS*)

       *PI:SETTINGS*

     )

  )

)

; Chọn Định dạng format file text ( dữ liệu đầu vào)

(DEFUN

   PI:GETFILEFORMAT (/ STDCOMMENT OPTION)

  (TEXTPAGE)

  ;; Tạo bảng thông báo lựa chọn định dạng đầu vào text

  (PROMPT

    "\nCh\U+1ECDn d\U+1EA1ng d\U+1EEF li\U+1EC7u \U+0111\U+1EA7u v\U+00E0o:

1. STT X Y Z Code (Ph\U+00E2n c\U+00E1ch d\U+1EA5u ph\U+1EA9y)

2. STT X Y Z code (Ph\U+00E2n c\U+00E1ch tab)

3. STT X Y Z code (Ph\U+00E2n c\U+00E1ch space)

4. STT Y X Z code (Ph\U+00E2n c\U+00E1ch d\U+1EA5u ph\U+1EA9y)

5. STT Y X Z code (Ph\U+00E2n c\U+00E1ch tab)

6. STT Y X Z code (Ph\U+00E2n c\U+00E1ch space)

" )

  ;;Thiết lập các từ khóa theo định dạng cấu trúc file dữ liệu

  (INITGET "1 2 3 4 5 6")

  (SETQ OPTION (GETKWORD "\n\n1/2/3/4/5/6: "))

  ;; 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" "NORTH" "EAST" "ELEV" "DESC")

       "W"

       STDCOMMENT

     )

    )

    ((= OPTION "4")

     (LIST

       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")

       ","

       STDCOMMENT

     )

    )

    ((= OPTION "5")

     (LIST

       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")

       "\t"

       STDCOMMENT

     )

    )

    ((= OPTION "6")

     (LIST

       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")

       "W"

       STDCOMMENT

     )

    )

  )

)

(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

(DEFUN

   PI:GETPOINTSLIST (FNAME FILEFORMAT POINTFORMAT / ATTVALUES COORD

                     FIELDNAME I INSPOINT 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)))

       ;; Read and label the fields in the order specified by FILEFORMAT

       (FOREACH

          FIELD (CAR FILEFORMAT)

         (SETQ I (1+ I))

         (SETQ

           POINTLIST

            (CONS

              (CONS

                FIELD

                (PI:RDFLD I RDLIN (CADR FILEFORMAT) 1)

              )

              POINTLIST

            )

         )

       )

       ;; Strip the labels from the fields and put them into internal order

       ;; specified by POINTFORMAT.

       (SETQ

         ;; Get insertion coordinates

         INSPOINT

          (MAPCAR

            '(LAMBDA (FIELDNAME / COORD)

               (COND

                 ((AND

                    ;; If the coordinate is defined

                    (SETQ

                      COORD

                       (CDR (ASSOC FIELDNAME POINTLIST))

                    )

                    ;; and if the file gave a value

                    (SETQ COORD (DISTOF COORD))

                  )

                  ;; use it.

                  COORD

                 )

                 ;; Use 0.0 for any missing or undefined coordinates.

                 (0.0)

               )

             )

            (CDR (ASSOC "XYZNAMES" POINTFORMAT))

          )

         ;; Get attribute values.

         ATTVALUES

          (MAPCAR

            '(LAMBDA (FIELDNAME / COORD)

               (CDR (ASSOC FIELDNAME POINTLIST))

             )

            (CDR (ASSOC "TAGNAMES" POINTFORMAT))

          )

       )

       ;; Add point to list.

       (SETQ POINTSLIST (CONS (CONS INSPOINT ATTVALUES) POINTSLIST))

      )

    )

  )

  (SETQ F1 (CLOSE F1))

  POINTSLIST

)

 

;;; 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 (LAYERFORMAT POINTLIST POINTFORMAT / DWGLAYER LAYERNAME

                 NAMELIST LAYERCOLOR

                )

  (COND

    (LAYERFORMAT

     (SETQ

       NAMELIST

        (CAR LAYERFORMAT)

       LAYERNAME

        (STRCAT

          (CAR NAMELIST)

          (IF (CADR NAMELIST)

            (STRCAT

              (NTH

                ;; Calculate the position of the description in the pointlist

                (LENGTH

                  (MEMBER

                    ;; Name of point description

                    (CDR (ASSOC "("DESCNAME" . "DESC")" POINTFORMAT))

                    (REVERSE

                      (CDR (ASSOC "TAGNAMES" POINTFORMAT))

                    )

                  )

                )

                POINTLIST

              )

              (CADR NAMELIST)

            )

            ""

          )

        )

       LAYERCOLOR

        (CADR LAYERFORMAT)

     )

     (COND

       ((AND

          ;; Layer exists in drawing

          (SETQ DWGLAYER (TBLSEARCH "LAYER" LAYERNAME))

          ;; Layer is already proper color

          (= (CDR (ASSOC 62 DWGLAYER)) (CADR LAYERFORMAT))

          ;; 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 "" ""

         )

       )

     )

    )

  )

)

 

;; Format of list for each point is:

;; The first member is the point list (list x y z)

;; The other members are attribute value strings as defined by the GETPOINTFORMAT function

(DEFUN

   PI:GETBLOCKLAYERFORMAT (POINTFORMAT / LAYERFORMATSTRING)

  ;; Set up the point block layer scheme.  

  ;; 1. 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 LAYERFORMATSTRING '("V-NODE-/d" "cyan"))(PROMPT "\nBlock layer names by description is activated.  All descriptions must be legal layer names.  Search this text in the source code to deactivate.")

  ;; 2. If you want all point blocks to be put on the same layer, take out the /d.

  (SETQ LAYERFORMATSTRING '("V-NODE-IMPT" "cyan"))(PROMPT "\nOption to put all point blocks on same layer is active.  Search this text in the source code to change behavior.")

  ;; 3. If you want all point blocks to be put on the current layer, comment out both lines above as well as the following line.

  (PI:LAYERPARSE LAYERFORMATSTRING)

 

)

 

(DEFUN

   PI:GETNODELAYERFORMAT (POINTFORMAT / LAYERFORMATSTRING)

  ;; Set up the point node layer scheme.  

  ;; 1. If you want each node 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 LAYERFORMATSTRING '("V-NODE-3D~~-/d" "yellow"))(PROMPT "\nNode layer names by description is activated.  All descriptions must be legal layer names.  Search this text in the source code to deactivate.")

  ;; 2. If you want all point nodes to be put on the same layer, take out the /d.

  (SETQ LAYERFORMATSTRING '("V-NODE-3D~~-IMPT" "yellow"))

  ;; 3. If you want all point blocks to be put on the current layer, comment out both lines above as well as the following line.

  (PI:LAYERPARSE LAYERFORMATSTRING)

)

 

(DEFUN

   PI:INSERTPOINTBLOCKS

   (POINTSLIST POINTFORMAT / AROLD POINTBLOCKLAYERFORMAT)

  (SETQ POINTBLOCKLAYERFORMAT (PI:GETBLOCKLAYERFORMAT POINTFORMAT))

  (COMMAND "._undo" "_group")

  (SETQ AROLD (GETVAR "attreq"))

  (SETVAR "attreq" 0)

  ;;Insert a Softdesk style block

  (FOREACH

     ;; The format of pointlist is defined in GETPOINTSLIST

     POINTLIST POINTSLIST

    (PI:INSERTPOINTBLOCK

      POINTLIST

      POINTFORMAT

      POINTBLOCKLAYERFORMAT

    )

  )

  (SETVAR "attreq" AROLD)

  (COMMAND "._undo" "_end")

)

 

(DEFUN

   PI:INSERTPOINTBLOCK (POINTLIST POINTFORMAT POINTBLOCKLAYERFORMAT / AT

                        AV EL EN ET N NEWVALUE SHORTLIST

                       )

  (PI:MAKELAYER POINTBLOCKLAYERFORMAT POINTLIST POINTFORMAT)

  (COMMAND

    "._insert"

    "point"

    "none"

    ;; Chop off the z coordinate for 2D block insertion.

    ;; (REVERSE (CDR (REVERSE (CAR POINTLIST))))

    ;; Or keep the z coordinate for 3D block insertion.

    (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

            SHORTLIST

             (MEMBER

               AT

               (REVERSE (CDR (ASSOC "TAGNAMES" POINTFORMAT)))

             )

          )

          (SETQ

            N (LENGTH SHORTLIST)

            NEWVALUE (NTH N POINTLIST)

          )

          ;; Round elevation attribute to current drawing LUPREC value

          ;;(IF

          ;;  (= AT "ELEV")

          ;;  (SETQ NEWVALUE (RTOS (ATOF NEWVALUE) 2))

          ;;)

          (ENTMOD

            (SUBST (CONS 1 NEWVALUE) (ASSOC 1 EL) EL) ;_ end of SUBST

          ) ;_ end of ENTMOD

         )

       ) ;_ end of cond

       (ENTUPD EN)

      )

    ) ;_ end of cond

  ) ;_ end of while

)

(DEFUN

   PI:INSERT3DPOINTS

   (POINTSLIST POINTFORMAT / NODELAYERFORMAT POINTLIST)

  (SETQ NODELAYERFORMAT (PI:GETNODELAYERFORMAT POINTFORMAT))

  (COMMAND "._undo" "_group")

  (FOREACH

     POINTLIST POINTSLIST

    (PI:MAKELAYER NODELAYERFORMAT POINTLIST POINTFORMAT)

    (COMMAND "._point" (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 (STRCAT "\nFields or delimiters missing in this line?" STRING))

                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

)

 

 

  • Vote giảm 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Doan Van Ha    2.678

 

 
(DEFUN c:NCSDL () (PI:POINTSIN))
 
(DEFUN
   PI:POINTSIN (/  FILEFORMAT FNAME NODELAYERFORMAT 
                POINTBLOCKLAYERFORMAT POINTFORMAT POINTSLIST
               )
  (SETQ POINTFORMAT (PI:GETPOINTFORMAT))
  (SETQ FILEFORMAT (PI:GETFILEFORMAT))
  (SETQ FNAME (GETFILED "CHON FILE TEXT" (PI:GETDNPATH) "" 0))
  (SETQ POINTSLIST (PI:GETPOINTSLIST FNAME FILEFORMAT POINTFORMAT))
  ;; Chèn điểm vào block
  (PI:INSERTPOINTBLOCKS POINTSLIST POINTFORMAT)
  ;; chèn điểm 3d
  (PI:INSERT3DPOINTS POINTSLIST POINTFORMAT)
)
; Chọn định dạng format kiểu dữ liệu
(DEFUN
   PI:GETPOINTFORMAT ()
  '(
    ;; format point ở dạng 3D " STT,X,Y,Z "
    ("XYZNAMES" "EAST" "NORTH" "ELEV")
    ;; Format pont ở định dang 2D "STT,X,Y"
    ;; '("XYZNAMES" "EAST" "NORTH" nil)
    ;; ========================================================================
    ;; Tạo Ghi chú điểm " Node "
    ("DESCNAME" . "DESC")
    ;; ========================================================================
    ;; Danh sách các tagname nối với  file block attribute point.dwg
    ("TAGNAMES" "NORTH" "EAST" "POINT" "DESC" "ELEV")
   )
  ;; ========================================================================
)
 
(DEFUN
   PI:SETVAR (VAR-NAME VAR-VAL)
  ;; Populate the settings list so it's complete and we know we are not setting an unknown (maverick) setting.
  (PI:GETVAR VAR-NAME)
  ;; Put the requested value in the settings list
  (SETQ
    *PI:SETTINGS*
     (SUBST
       (CONS VAR-NAME VAR-VAL)
       (ASSOC VAR-NAME *PI:SETTINGS*)
       *PI:SETTINGS*
     )
  )
)
; Chọn Định dạng format file text ( dữ liệu đầu vào)
(DEFUN
   PI:GETFILEFORMAT (/ STDCOMMENT OPTION)
  (TEXTPAGE)
  ;; Tạo bảng thông báo lựa chọn định dạng đầu vào text
  (PROMPT
    "\nCh\U+1ECDn d\U+1EA1ng d\U+1EEF li\U+1EC7u \U+0111\U+1EA7u v\U+00E0o:
1. STT X Y Z Code (Ph\U+00E2n c\U+00E1ch d\U+1EA5u ph\U+1EA9y)
2. STT X Y Z code (Ph\U+00E2n c\U+00E1ch tab)
3. STT X Y Z code (Ph\U+00E2n c\U+00E1ch space)
4. STT Y X Z code (Ph\U+00E2n c\U+00E1ch d\U+1EA5u ph\U+1EA9y)
5. STT Y X Z code (Ph\U+00E2n c\U+00E1ch tab)
6. STT Y X Z code (Ph\U+00E2n c\U+00E1ch space)
" )
  ;;Thiết lập các từ khóa theo định dạng cấu trúc file dữ liệu
  (INITGET "1 2 3 4 5 6")
  (SETQ OPTION (GETKWORD "\n\n1/2/3/4/5/6: "))
  ;; 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" "NORTH" "EAST" "ELEV" "DESC")
       "W"
       STDCOMMENT
     )
    )
    ((= OPTION "4")
     (LIST
       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")
       ","
       STDCOMMENT
     )
    )
    ((= OPTION "5")
     (LIST
       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")
       "\t"
       STDCOMMENT
     )
    )
    ((= OPTION "6")
     (LIST
       (LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")
       "W"
       STDCOMMENT
     )
    )
  )
)
(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
(DEFUN
   PI:GETPOINTSLIST (FNAME FILEFORMAT POINTFORMAT / ATTVALUES COORD
                     FIELDNAME I INSPOINT 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)))
       ;; Read and label the fields in the order specified by FILEFORMAT
       (FOREACH
          FIELD (CAR FILEFORMAT)
         (SETQ I (1+ I))
         (SETQ
           POINTLIST
            (CONS
              (CONS
                FIELD
                (PI:RDFLD I RDLIN (CADR FILEFORMAT) 1)
              )
              POINTLIST
            )
         )
       )
       ;; Strip the labels from the fields and put them into internal order
       ;; specified by POINTFORMAT.
       (SETQ
         ;; Get insertion coordinates
         INSPOINT
          (MAPCAR
            '(LAMBDA (FIELDNAME / COORD)
               (COND
                 ((AND
                    ;; If the coordinate is defined
                    (SETQ
                      COORD
                       (CDR (ASSOC FIELDNAME POINTLIST))
                    )
                    ;; and if the file gave a value
                    (SETQ COORD (DISTOF COORD))
                  )
                  ;; use it.
                  COORD
                 )
                 ;; Use 0.0 for any missing or undefined coordinates.
                 (0.0)
               )
             )
            (CDR (ASSOC "XYZNAMES" POINTFORMAT))
          )
         ;; Get attribute values.
         ATTVALUES
          (MAPCAR
            '(LAMBDA (FIELDNAME / COORD)
               (CDR (ASSOC FIELDNAME POINTLIST))
             )
            (CDR (ASSOC "TAGNAMES" POINTFORMAT))
          )
       )
       ;; Add point to list.
       (SETQ POINTSLIST (CONS (CONS INSPOINT ATTVALUES) POINTSLIST))
      )
    )
  )
  (SETQ F1 (CLOSE F1))
  POINTSLIST
)
 
;;; 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 (LAYERFORMAT POINTLIST POINTFORMAT / DWGLAYER LAYERNAME
                 NAMELIST LAYERCOLOR
                )
  (COND
    (LAYERFORMAT
     (SETQ
       NAMELIST
        (CAR LAYERFORMAT)
       LAYERNAME
        (STRCAT
          (CAR NAMELIST)
          (IF (CADR NAMELIST)
            (STRCAT
              (NTH
                ;; Calculate the position of the description in the pointlist
                (LENGTH
                  (MEMBER
                    ;; Name of point description
                    (CDR (ASSOC "("DESCNAME" . "DESC")" POINTFORMAT))
                    (REVERSE
                      (CDR (ASSOC "TAGNAMES" POINTFORMAT))
                    )
                  )
                )
                POINTLIST
              )
              (CADR NAMELIST)
            )
            ""
          )
        )
       LAYERCOLOR
        (CADR LAYERFORMAT)
     )
     (COND
       ((AND
          ;; Layer exists in drawing
          (SETQ DWGLAYER (TBLSEARCH "LAYER" LAYERNAME))
          ;; Layer is already proper color
          (= (CDR (ASSOC 62 DWGLAYER)) (CADR LAYERFORMAT))
          ;; 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 "" ""
         )
       )
     )
    )
  )
)
 
;; Format of list for each point is:
;; The first member is the point list (list x y z)
;; The other members are attribute value strings as defined by the GETPOINTFORMAT function
(DEFUN
   PI:GETBLOCKLAYERFORMAT (POINTFORMAT / LAYERFORMATSTRING)
  ;; Set up the point block layer scheme.  
  ;; 1. 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 LAYERFORMATSTRING '("V-NODE-/d" "cyan"))(PROMPT "\nBlock layer names by description is activated.  All descriptions must be legal layer names.  Search this text in the source code to deactivate.")
  ;; 2. If you want all point blocks to be put on the same layer, take out the /d.
  (SETQ LAYERFORMATSTRING '("V-NODE-IMPT" "cyan"))(PROMPT "\nOption to put all point blocks on same layer is active.  Search this text in the source code to change behavior.")
  ;; 3. If you want all point blocks to be put on the current layer, comment out both lines above as well as the following line.
  (PI:LAYERPARSE LAYERFORMATSTRING)
 
)
 
(DEFUN
   PI:GETNODELAYERFORMAT (POINTFORMAT / LAYERFORMATSTRING)
  ;; Set up the point node layer scheme.  
  ;; 1. If you want each node 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 LAYERFORMATSTRING '("V-NODE-3D~~-/d" "yellow"))(PROMPT "\nNode layer names by description is activated.  All descriptions must be legal layer names.  Search this text in the source code to deactivate.")
  ;; 2. If you want all point nodes to be put on the same layer, take out the /d.
  (SETQ LAYERFORMATSTRING '("V-NODE-3D~~-IMPT" "yellow"))
  ;; 3. If you want all point blocks to be put on the current layer, comment out both lines above as well as the following line.
  (PI:LAYERPARSE LAYERFORMATSTRING)
)
 
(DEFUN
   PI:INSERTPOINTBLOCKS
   (POINTSLIST POINTFORMAT / AROLD POINTBLOCKLAYERFORMAT)
  (SETQ POINTBLOCKLAYERFORMAT (PI:GETBLOCKLAYERFORMAT POINTFORMAT))
  (COMMAND "._undo" "_group")
  (SETQ AROLD (GETVAR "attreq"))
  (SETVAR "attreq" 0)
  ;;Insert a Softdesk style block
  (FOREACH
     ;; The format of pointlist is defined in GETPOINTSLIST
     POINTLIST POINTSLIST
    (PI:INSERTPOINTBLOCK
      POINTLIST
      POINTFORMAT
      POINTBLOCKLAYERFORMAT
    )
  )
  (SETVAR "attreq" AROLD)
  (COMMAND "._undo" "_end")
)
 
(DEFUN
   PI:INSERTPOINTBLOCK (POINTLIST POINTFORMAT POINTBLOCKLAYERFORMAT / AT
                        AV EL EN ET N NEWVALUE SHORTLIST
                       )
  (PI:MAKELAYER POINTBLOCKLAYERFORMAT POINTLIST POINTFORMAT)
  (COMMAND
    "._insert"
    "point"
    "none"
    ;; Chop off the z coordinate for 2D block insertion.
    ;; (REVERSE (CDR (REVERSE (CAR POINTLIST))))
    ;; Or keep the z coordinate for 3D block insertion.
    (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
            SHORTLIST
             (MEMBER
               AT
               (REVERSE (CDR (ASSOC "TAGNAMES" POINTFORMAT)))
             )
          )
          (SETQ
            N (LENGTH SHORTLIST)
            NEWVALUE (NTH N POINTLIST)
          )
          ;; Round elevation attribute to current drawing LUPREC value
          ;;(IF
          ;;  (= AT "ELEV")
          ;;  (SETQ NEWVALUE (RTOS (ATOF NEWVALUE) 2))
          ; ;)
          (ENTMOD
            (SUBST (CONS 1 NEWVALUE) (ASSOC 1 EL) EL) ;_ end of SUBST
          ) ;_ end of ENTMOD
         )
       ) ;_ end of cond
       (ENTUPD EN)
      )
    ) ;_ end of cond
  ) ;_ end of while
)
(DEFUN
   PI:INSERT3DPOINTS
   (POINTSLIST POINTFORMAT / NODELAYERFORMAT POINTLIST)
  (SETQ NODELAYERFORMAT (PI:GETNODELAYERFORMAT POINTFORMAT))
  (COMMAND "._undo" "_group")
  (FOREACH
     POINTLIST POINTSLIST
    (PI:MAKELAYER NODELAYERFORMAT POINTLIST POINTFORMAT)
    (COMMAND "._point" (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 (STRCAT "\nFields or delimiters missing in this line?" STRING))
                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
)

 

Lý giải cái gì? Bạn quẳng lisp lên không một lời giải thích, bắt mọi người hại não à?

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
AQ1989    5

 sorry bạn nếu mình có thiếu sót. Lisp này đã hoàn thiện rồi. Đây là 1 lisp chuyển điểm từ file text lên cad. Hiện tại mình đang muôn hiểu rõ hơn về thuật toán( công thức) lisp này. Do mới bập bè về lisp nên còn nhiều hạn chế. Chưa hiểu được hết nên rất mong được sự giúp đở của các bạn.

  • Vote giảm 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Doan Van Ha    2.678

 sorry bạn nếu mình có thiếu sót. Lisp này đã hoàn thiện rồi. Đây là 1 lisp chuyển điểm từ file text lên cad. Hiện tại mình đang muôn hiểu rõ hơn về thuật toán( công thức) lisp này. Do mới bập bè về lisp nên còn nhiều hạn chế. Chưa hiểu được hết nên rất mong được sự giúp đở của các bạn.

Nếu hỏi 1 hàm, và tôi biết, tôi sẽ chỉ tường tận.

Nếu hỏi 100 hàm (như trong lisp ở trên) thì chỉ có sách mới chỉ cho bạn thôi. Tôi chưa từng gặp một câu hỏi nào kiểu như bạn: muốn ăn gỏi kiến thức trong tích tắc!

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
phongtran86    21

Nếu hỏi 1 hàm, và tôi biết, tôi sẽ chỉ tường tận.

Nếu hỏi 100 hàm (như trong lisp ở trên) thì chỉ có sách mới chỉ cho bạn thôi. Tôi chưa từng gặp một câu hỏi nào kiểu như bạn: muốn ăn gỏi kiến thức trong tích tắc!

đúng là ăn gỏi anh ạ. Em nhiều khi khúc mắc 1 hàm, đc các anh gợi ý, tìm hiểu đọc mới vỡ ra chứ k ai chỉ 100% cho mình dc cả

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
phamthanhbinh    3.123

đúng là ăn gỏi anh ạ. Em nhiều khi khúc mắc 1 hàm, đc các anh gợi ý, tìm hiểu đọc mới vỡ ra chứ k ai chỉ 100% cho mình dc cả

Hề hề hề,

Muốn ăn gỏi thì dễ thôi mà. Bạn cứ đọc qua một lượt, nếu thấy hiểu hết là Ok, Gặp cái chi chưa hiểu thì chỉ post nguyên một cái đó lên thôi. Mọi người sẽ giải đáp và khi bạn hiểu lại ăn tiếp khúc sau. Tuy chậm nhưng đỡ hóc bạn ạ. Các cụ day nhai kỹ no lâu là thế.....

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

Nhờ có bác Phamthanhbinh chỉ bảo và các bác trên diễn đàn hỗ trợ. Em cũng tạo cho mình 1 ít công cụ đủ dùng cho mình.

P/s: Hum trước em vào SG, em mất số dth bác Bình nên không gọi cho bác được.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
phamthanhbinh    3.123

Nhờ có bác Phamthanhbinh chỉ bảo và các bác trên diễn đàn hỗ trợ. Em cũng tạo cho mình 1 ít công cụ đủ dùng cho mình.

P/s: Hum trước em vào SG, em mất số dth bác Bình nên không gọi cho bác được.

Hề hề hề,

Hổng sao cả, lần sau có vào thì cứ ới qua số điện thoại 0902918229 hoặc ới trên diễn đàn này cũng được mà. Vui là chính quýnh quáng là một chục ấy mà.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×