Liren Large Software Subsidy 13/13.iso/p/p024/6.img/BONUS1.LIB/BMAKE.LSP

Text File | 1993-02-09 | 16.0 KB | 539 lines

;;;---------------------------------------------------------------------------;
;;;
;;;   BMAKE.LSP   ¬⌐Ñ╗ 0.5
;;;
;;;   (C) ¬⌐┼v 1988-1992  Autodesk ñ╜Ñq
;;;
;;;   Ñ╗╡{ªíñwÑ╤ Autodesk ñ╜Ñq╡∙ÑU¬⌐┼v, ╢╚⌐≤ñU¡z▒í¬pñUÑi▒┬╗P▒zíu│\ÑiívíC
;;;   ╗╒ñUñú▒oÑHÑ⌠ª≤º╬ªí╡oªµ⌐╬ÑX¬⌐ª╣╡{ªí¬║íu¡∞⌐l╜Xív; ª²ñ╣│\▒zªb»S⌐w¡lÑ═
;;;   ¬║ñuº@ñW╡▓ªXª╣╡{ªí¬║íuÑ╪¬║╜Xív¿╧Ñ╬íCª│├÷│o├■¡lÑ═ñuº@¬║▒°Ñ≤ªpñU:
;;;
;;;   ( i)  │]¡pñW╗Pñuº@ñW¼╥»┬║Θ░w╣∩ Autodesk ñ╜Ñq¬║▓ú½~íC
;;;   (ii)  ╕ⁿª│íu¬⌐┼v  (C) 1988-1992  Autodesk ñ╜Ñqív¬║¬⌐┼v│qºiíC
;;;
;;;
;;;
;;;   AUTODESKñ╜Ñq┤ú¿╤ª╣╡{ªí╢╚¿╤º@íu├■ªⁿív¬║░╤ª╥, ª╙ÑBñú▒╞░úª│Ñ⌠ª≤┐∙╗~¬║
;;;   Ñi»αíCAUTODESKñ╜Ñq»Sª╣º_╗{Ñ⌠ª≤»S⌐wÑ╬│~ñº╛A║┘⌐╩, ÑHñ╬░╙╖~╛P░Γ⌐╥┴⌠ºt
;;;   ÑX¿π¬║½O├╥íCAUTODESKñ╜ÑqªP«╔ÑτñúÑX¿πª╣╡{ªí░⌡ªµ«╔ñ@⌐wñú╖|íuññ┬_ív⌐╬
;;;   íuº╣Ñ■╡L╗~ív¬║½O├╥íC
;;;
;;;
;;;   by Kieran V. McKeogh
;;;   28 Feb 1991
;;;
;;;---------------------------------------------------------------------------;
;;;  DESCRIPTION
;;;
;;;  Programming example of defining blocks using (entmake) with a dialogue
;;;  interface.  Uses Bmake.dcl.
;;;
;;;  REVISION
;;;
;;;---------------------------------------------------------------------------;


;;;---------------------------------------------------------------------------;
;;; The Main Function which pops up the dialogue with the defaults.  A while
;;; loop is used to allow the dialogue to be hidden for point and object
;;; selection.
;;;---------------------------------------------------------------------------;
(defun c:bmake (/ bname unnamed x_pt y_pt z_pt retain selection_set)
  ;;
  ;;  Main error routine.
  ;;
  (defun bmake_error (s)                ; If an error (such as CTRL-C) occurs
    (if (/= s "Function cancelled")
      (princ (strcat "\n┐∙╗~: " s))
    )
    (if olderr (setq *error* olderr)) ; Restore old *error* handler
    (princ)
  )
  ;;
  ;;  Standard Help function
  ;;
  (defun do_help (cmd)
    (if (= (type acad_helpdlg) 'EXSUBR)
      (acad_helpdlg "acad.hlp" cmd)
      (alert "ºΣñú¿∞íu╗▓ºU╣∩╕▄íví╨ xload acadapp íC")
    )
    (princ)
  )
  ;;
  ;; If unnamed is toggled on, disable Block Name edit box and vice versa.
  ;;
  (defun do_unnamed()
    (rs_error)
    (mode_tile "bname" (setq unnamed (atoi (get_tile "unnamed"))))
  )
  ;;
  ;; Check validity of the Block name.
  ;;
  (defun do_bname()
    (check_name (setq bname (strcase (get_tile "bname"))))
  )
  ;;
  ;;  Figure defaults, for initial dialogue and when returning from object
  ;;  selection or point picking.
  ;;
  (defun defaults()
    (if bname
      (set_tile "bname" bname)
    )
    (if (= 0 retain)
      (set_tile "retain" "0")
      (progn
        (set_tile "retain" "1")
        (setq retain 1)
      )
    )
    (if (= 1 unnamed)
      (progn
        (mode_tile "bname" 1)
        (set_tile "unnamed" "1")
      )
    )
    (if x_pt
      (set_tile "x_pt" x_pt)
      (progn
        (set_tile "x_pt" (rtos 0.0000 2))
        (setq x_pt (rtos 0.0000 2))
      )
    )
    (if y_pt
      (set_tile "y_pt" y_pt)
      (progn
        (set_tile "y_pt" (rtos 0.0000 2))
        (setq y_pt (rtos 0.0000 2))
      )
    )
    (if z_pt
      (set_tile "z_pt" z_pt)
      (progn
        (set_tile "z_pt" (rtos 0.0000 2))
        (setq z_pt (rtos 0.0000 2))
      )
    )
    (set_tile "how_many"
              (if (/= selection_set nil)
                (rtos (sslength selection_set) 2 0)
                "0"
              )
    )
  )
  ;;
  ;;  X coordinate action.
  ;;
  (defun do_x_pt()
    (check_real (setq x_pt (get_tile "x_pt")) "x_pt")   ; if valid input
  )
  ;;
  ;;  Y coordinate action.
  ;;
  (defun do_y_pt()
    (check_real (setq y_pt (get_tile "y_pt")) "y_pt")   ; if valid input
  )
  ;;
  ;;  Z coordinate action.
  ;;
  (defun do_z_pt()
    (check_real (setq z_pt (get_tile "z_pt")) "z_pt")   ; if valid input
  )
  ;;
  ;; Reset the error tile to null.
  ;;
  (defun rs_error()
    (set_tile "error" "")
  )
  ;;
  ;;  This function checks the validity of the coordinates.  It returns the
  ;;  real number or nil.
  ;;
  (defun check_real (real_number coord)
    (if (distof real_number 2)
      (progn
        (rs_error)
        real_number
      )
      (progn
        (set_tile "error"
                  (strcat (strcase (substr coord 1 1))
                          " «y╝╨╡L«─íC"
                  )
        )
        nil
      )
    )
  )
  ;;
  ;;  This function checks the validity of the Block name.  If legitimate, the
  ;;  Block name is returned, nil otherwise.
  ;;
  (defun check_name(name)
    (if (wcmatch name "*[] `#`@`.`?`*`~`[`,`'!%^&()+={}|`\\:;\"<>/]*")
      (progn
        (set_tile "error" "íu╣╧╕sªW║┘ívññª│╡L«─ªrñ╕íC")
        nil
      )
      (progn
        (rs_error)
        name
      )
    )
  )
  ;;
  ;;  This function is called on OK in the main dialogue.  It confirms that all
  ;;  input is correct and whether the block name already exists...
  ;;
  (defun bexist()
    (setq reference 0)
    (cond
      ;; Check each coordinate.
      ((not (check_real x_pt "x_pt")))
      ((not (check_real y_pt "y_pt")))
      ((not (check_real z_pt "z_pt")))

      ;; If block name is null, give message.
      ((and (/= 1 unnamed)
            (or (not bname) (= "" bname))
       )
        (set_tile "error" "ñúñ╣│\íuNull ╣╧╕sªW║┘ívíC")
      )

      ;; Self-referencing check, check_ref returns T on a self reference.
      ((and selection_set (check_ref)))

      ;; If the name exists, question via dialogue to overwrite it.
      ((and (member bname table_list) (/= 1 unnamed))
        (if (not (new_dialog "bname_exists" dcl_id)) (exit))
        (action_tile "yes" "(done_dialog 2)")
        (action_tile "no" "(done_dialog 0)")
        (if (= (start_dialog) 2) (done_dialog 2))
      )

      ;; If a new named block, check validity of name.
      ((/= unnamed 1)
        (if (check_name bname)
          (done_dialog 2)
          T
        )
      )
      ;; If unnamed, just make it.
      ((= 1 unnamed) (done_dialog 2))
      ;; if none of above then error.
      (t (princ "\níubexist()ívññª│╡{ªíñW¬║┐∙╗~íC"))
    )
  )
  ;;
  ;; Check to see if the block contains a self reference.
  ;;
  (defun check_ref (/ ref)
    (setq a 0)
    (setq self_list '())
    ;; make a list of all insert entities in the selection set.
    (while (< a (setq ss_length (sslength selection_set)))
      (if (= (cdr (assoc '0 (entget (ssname selection_set a)))) "INSERT")
        (setq self_list
              (cons (cdr (assoc '2 (entget (ssname selection_set a))))
                    self_list
              )
        )
      )
      (setq a (1+ a))
    )
    (cond
      ;; if bname is in the selection set, report error.
      ((and self_list (member bname self_list))
        (set_tile "error" "┐∙╗~ í╨ ª╣╣╧╕síuª█┼Θ░╤ª╥ívíC")
      )
      ;;
      ((and self_list (self_ref bname self_list))
        (set_tile "error" "┐∙╗~ í╨ ª╣╣╧╕síuª█┼Θ░╤ª╥ívíC")
      )
      (t nil)
    )
  )
  ;;
  ;; This recursive function takes two arguments, a Block name and a list of
  ;; Block names.  It checks to see whether any of the Blocks in the list
  ;; contain  a reference to the first argument.  Recursion is used to take
  ;; care of possible nested references.  Candidate for rainy day optimisation.
  ;;
  (defun self_ref (self others / ref other_list)
    (setq other_list '())
    (foreach n others
      (setq en1 (cdr (assoc '-2 (tblsearch "block" n)))) ; first entity
      (while en1
        (if (and (= "INSERT" (cdr (assoc '0 (entget en1))))
                 (not (member
                        (setq other_name (cdr (assoc '2 (entget en1))))
                        others
                      )
                 )
             )
          (setq other_list (cons other_name other_list))
        )
        (setq en1 (entnext en1))
      )
      (if (and other_list
               (member self other_list)
          )
        (setq ref t)
        (self_ref self other_list)
      )
    )
    ref                              ; return t on a self reference, else nil.
  )
  ;;
  ;; This function, when passed a symbol table name, returns a list of
  ;; entries in that table.
  ;;
  (defun get_table (table_name)
    (setq table_item (tblnext table_name T))
    (setq table_list '())
    (while (and table_item)
      (setq just_name (cdr (assoc 2 table_item)))
      (setq table_list (cons just_name table_list))
      (setq table_item (tblnext table_name))
    )
  )
  ;;
  ;; Displays a nested dialogue containing an edit box for wildcards and
  ;; a list box of the associated blocks in the drawing.
  ;;
  (defun list_blocks()
    (setq bl_match '())
    (if (not (new_dialog "list_blocks" dcl_id)) (exit))
    (if (not pat) (setq pat "*"))
    (set_tile "pattern" pat)
    (pat_match pat)
    (action_tile "bl_match" "(set_tile \"bl_match\" \"\")")
    (action_tile "pattern" "(pat_match (setq pat (strcase $value)))")
    (action_tile "accept" "(done_dialog 0)")
    (start_dialog)
  )
  ;;
  ;; This function displays the block list based on the pattern.
  ;;
  (defun pat_match (pat)
    (setq bl_match '())
    (foreach n table_list
      (if (wcmatch n pat)
        (setq bl_match (cons n bl_match))
      )
    )
    (if (>= (getvar "maxsort") (length bl_match)) ; Alphabetise the list
      (setq bl_match (sort bl_match))             ; in accordance with maxsort
    )
    (start_list "bl_match")
    (mapcar 'add_list bl_match)
    (end_list)
  )
  ;;
  ;; Alphabetize a list.
  ;;
  (defun sort (list1 / item1 item2)
    (setq item1 (car list1))
    (foreach item2 (cdr list1)
      (if (> item2 item1)
        (setq item1 item2)
      )
    )
    (if list1
      (append
        (sort
          (append  (cdr (member item1 list1))
                   (cdr (member item1 (reverse list1))))
        )
        (list item1)
      )
    )
  )
  ;;
  ;; Routine that makes the block.
  ;;
  (defun entmake_block()
    (setq a 0)
    (setq att 0)

    ;; Check selection set for an ATTDEF.
    (if selection_set
      (while (< a (sslength selection_set))
        (if (= "ATTDEF" (cdr (assoc '0 (entget (ssname selection_set a)))))
          (setq att 1 a (+ (sslength selection_set) a))
        )
      (setq a (1+ a))
    ))

    ;; Set header_name and 70 flag depending on named/unnamed and whether an
    ;; ATTDEF exists.
    (cond
      ((= unnamed 1)
        (setq header_name "*U")
        (if (= 1 att) (setq flag70 (+ 1 2)) (setq flag70 1))
      )
      ((setq header_name bname)
        (if (= 1 att) (setq flag70 (+ 64 2)) (setq flag70 64))
      )
    )
    ;; Block header information.
    (setq header (list
      (cons 0 "block")
      (cons 2 header_name)
      (cons 70 flag70)
      (cons 3 "")
      (list 10 0.0 0.0 0.0)
    ))
    (setq a 0)

    ;; Start (entmake)ing the entities...
    (if (entmake header)
      (progn
        (if selection_set
          (while (< a (sslength selection_set))
            (ent_copy (ssname selection_set a)
                      (- (atof x_pt))
                      (- (atof y_pt))
                      (- (atof z_pt)))
            (setq a (1+ a))
          )
        )
      )
    )
    (entmake (list (cons 0 "endblk")))    ; Entmake the block end.

    (if (= 0 retain)              ; Delete entities after entmake is sucessful.
      (progn
        (setq a 0)
        (if selection_set
          (while (< a (sslength selection_set))
            (entdel (ssname selection_set a))
            (setq a (1+ a))
          )
        )
      )
    )
  )
  ;;
  ;; Routine that copies an entity to a new location.  Pass the ename and the
  ;; X, Y, and Z coordinates of the displacement vector and a new entity is
  ;; created.
  ;;
  (defun ent_copy(ent x2 y2 z2)
    (setq ent_type (cdr (assoc 0 (entget ent))))
    (setq ent_list (cdr (entget ent (list "*"))))      ; don't forget the xdata.

    ;; A cond with two choices, a complex entity or a regular entity.
    (cond
      ;; Complex entities like Polyline and Insert with attributes.
      ((or (= "POLYLINE" ent_type)
           (and (= "INSERT" ent_type) (= 1 (cdr (assoc '66 ent_list))))
       )
        (if (= "POLYLINE" ent_type)
          (entmake ent_list)     ; Make polyline header with no changes.
          (entmake               ; Insert needs it's 10 group updated.
            (subst (mapcar '+ (list 0 x2 y2 z2) (assoc 10 ent_list))
                   (assoc 10 ent_list)
                   ent_list
            )
          )
        )
        (while (/= "SEQEND" (cdr (assoc '0 (entget (entnext ent)))))
          (entmake
            (subst (mapcar '+ (list 0 x2 y2 z2)
                              (assoc 10 (cdr (entget (entnext ent))))
                   )
                   (assoc 10 (cdr (entget (entnext ent))))
                   (cdr (entget (entnext ent)))
            )
          )
          (setq ent (entnext ent))
        )
        (entmake '((0 . "SEQEND")))
      )
      (t
        (foreach n '(10 11 12 13 14 15 16)
          (if (assoc n ent_list)
            (progn
              (setq ent_list
                    (subst (mapcar '+ (list 0 x2 y2 z2) (assoc n ent_list));new
                           (assoc n ent_list)                              ;old
                           ent_list                                       ;list
                    )
              )
            )
          )
        )
        (entmake ent_list)              ; make the copy
      )
    )
  )
  (if (< (setq dcl_id (load_dialog "bmake.dcl")) 0) (exit))
  (setq olderr  *error*
        *error* bmake_error)
  (get_table "block")                ; Make a list of blocks in the drawing.
  (setq what_next 5)
  (while (< 2 what_next)             ; Start the dialogue.
    (if (not (new_dialog "bmake" dcl_id)) (exit))
    ;; Set up defaults, for initial load and when returning from object
    ;; selection or point picking.
    (defaults)
    (if (= 5 what_next) (mode_tile "bname" 2)) ; set focus to block name.
    ;; Define what happens when each control is picked.  Mode_tile is
    ;; used to set focus to the next relevant action, cuts down mouse
    ;; handling in the dialogue.
    (action_tile "bname"       "(do_bname)")
    (action_tile "unnamed"     "(do_unnamed)")
    (action_tile "pick_pt"     "(done_dialog 4)")
    (action_tile "x_pt"        "(do_x_pt)")
    (action_tile "y_pt"        "(do_y_pt)")
    (action_tile "z_pt"        "(do_z_pt)")
    (action_tile "sel_objs"    "(done_dialog 3)")
    (action_tile "list_blocks" "(list_blocks)")
    (action_tile "retain"      "(setq retain (atoi $value))")
    (action_tile "accept"      "(bexist)")
    (action_tile "cancel"      "(done_dialog 0)")
    (action_tile "help"        "(do_help \"block\")")

    (setq what_next (start_dialog))   ; Throw up the dialogue.

    (cond                                   ; Decide what to do next.
      ;; If select objects was picked...
      ((= what_next 3)
        (setq selection_set
              ;; disallow viewports and shapes as these cannot be (entmake)d
              ;; currently.
              (ssget '((-4 . "<AND")
                         (-4 . "<NOT")(0 . "VIEWPORT")(-4 . "NOT>")
                         (-4 . "<NOT")(0 . "SHAPE")(-4 . "NOT>")
                      (-4 . "AND>"))
              )
        )
        (setq ssflag 1)
        (rs_error)
      )
      ;; If base point was picked...
      ((= what_next 4)
        (initget 1)
        (setq pick_pt (getpoint "┤íñ▐íu░≥╖╟┬Iív: "))
        (setq x_pt (rtos (car pick_pt) 2 4))
        (setq y_pt (rtos (cadr pick_pt) 2 4))
        (setq z_pt (rtos (caddr pick_pt) 2 4))
      )
    )
  )
  ;; If OK was picked.
  (if (= what_next 2)
       (entmake_block)
  )
  (setq *error* olderr)
  (princ)
)

;;;---------------------------------------------------------------------------;
;;; This is printed on loading.
;;;---------------------------------------------------------------------------;
(princ "\níuC:BMAKEívñw╕ⁿñJ; ╜╨ÑH BMAKE ▒╥░╩½ⁿÑOíC")
(princ)