Windows 95 v2.4 Fix/W95-v2.4fix.iso/ACADWIN/SAMPLE/BMAKE.LSP

Lisp/Scheme | 1995-07-14 | 18.9 KB | 577 lines

; Next available MSG number is    19
; MODULE_ID LSP_BMAKE_LSP_
;;;---------------------------------------------------------------------------;
;;;
;;;   BMAKE.LSP   Version 0.5
;;;
;;;   (C) Copyright 1988-1995 by Autodesk, Inc.
;;;
;;;   This program is copyrighted by Autodesk, Inc. and is  licensed
;;;   to you under the following conditions.  You may not distribute
;;;   or  publish the source code of this program in any form.   You
;;;   may  incorporate this code in object form in derivative  works
;;;   provided  such  derivative  works  are  (i.) are  designed and
;;;   intended  to  work  solely  with  Autodesk, Inc. products, and
;;;   (ii.)  contain  Autodesk's  copyright  notice  "(C)  Copyright
;;;   1988-1994 by Autodesk, Inc."
;;;
;;;   AUTODESK  PROVIDES THIS PROGRAM "AS IS" AND WITH  ALL  FAULTS.
;;;   AUTODESK  SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF  MER-
;;;   CHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK,  INC.
;;;   DOES  NOT  WARRANT THAT THE OPERATION OF THE PROGRAM  WILL  BE
;;;   UNINTERRUPTED OR ERROR FREE.
;;;
;;;   by Kieran V. McKeogh
;;;   28 Feb 1991
;;;
;;;---------------------------------------------------------------------------;
;;;  DESCRIPTION
;;;
;;;  Programming example of defining blocks using (entmake) with a dialog
;;;  interface.  Uses BMAKE.LSP/DCL.
;;;---------------------------------------------------------------------------;

;;; ===================== load-time error checking ============================

  (defun ai_abort (app msg)
     (defun *error* (s)
        (if old_error (setq *error* old_error))
        (princ)
     )
     (if msg
       (alert (strcat " Error de aplicaci≤n: "
                      app
                      " \n\n  "
                      msg
                      "  \n"
              )
       )
     )
     (exit)
  )

;;; Check to see if AI_UTILS is loaded, If not, try to find it,
;;; and then try to load it.
;;;
;;; If it can't be found or it can't be loaded, then abort the
;;; loading of this file immediately, preserving the (autoload)
;;; stub function.

  (cond
     (  (and ai_dcl (listp ai_dcl)))          ; it's already loaded.

     (  (not (findfile ;|MSG0|;"ai_utils.lsp"))                     ; find it
        (ai_abort "BMAKE"
                  (strcat "Imposible localizar el archivo AI_UTILS.LSP."
                          "\n Comprobar el directorio de soporte.")))

     (  (eq ;|MSG0|;"failed" (load ;|MSG0|;"ai_utils" ;|MSG0|;"failed"))            ; load it
        (ai_abort "BMAKE" "Imposible cargar el archivo AI_UTILS.LSP"))
  )

  (if (not (ai_acadapp))               ; defined in AI_UTILS.LSP
      (ai_abort "BMAKE" nil)           ; a Nil <msg> supresses
  )                                    ; ai_abort's alert box dialog.

;;; ==================== end load-time operations ===========================

;;;---------------------------------------------------------------------------;
;;; 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 "Funci≤n cancelada.")
      (princ (strcat "\nError: " s))
    )
    (if olderr (setq *error* olderr)) ; Restore old *error* handler
    (princ)
  )
  ;;
  ;; If unnamed is toggled on, disable Block Name edit box and vice versa.
  ;;
  (defun do_unnamed()
    (rs_error)
    (mode_tile ;|MSG0|;"bname" (setq unnamed (atoi (get_tile ;|MSG0|;"unnamed"))))
  )
  ;;
  ;; Check validity of the Block name.
  ;;
  (defun do_bname()
    (check_name (setq bname (xstrcase (get_tile ;|MSG0|;"bname"))))
  )
  ;;
  ;;  Figure defaults, for initial dialogue and when returning from object
  ;;  selection or point picking.
  ;;
  (defun defaults()
    (if bname
      (set_tile ;|MSG0|;"bname" bname)
    )
    (if (= 0 retain)
      (set_tile ;|MSG0|;"retain" ;|MSG0|;"0")
      (progn
        (set_tile ;|MSG0|;"retain" ;|MSG0|;"1")
        (setq retain 1)
      )
    )
    (if (= 1 unnamed)
      (progn
        (mode_tile ;|MSG0|;"bname" 1)
        (set_tile ;|MSG0|;"unnamed" ;|MSG0|;"1")
      )
    )
    (if x_pt
      (set_tile ;|MSG0|;"x_pt" x_pt)
      (progn
        (set_tile ;|MSG0|;"x_pt" (rtos 0.0000 2))
        (setq x_pt (rtos 0.0000 2))
      )
    )
    (if y_pt
      (set_tile ;|MSG0|;"y_pt" y_pt)
      (progn
        (set_tile ;|MSG0|;"y_pt" (rtos 0.0000 2))
        (setq y_pt (rtos 0.0000 2))
      )
    )
    (if z_pt
      (set_tile ;|MSG0|;"z_pt" z_pt)
      (progn
        (set_tile ;|MSG0|;"z_pt" (rtos 0.0000 2))
        (setq z_pt (rtos 0.0000 2))
      )
    )
    (set_tile ;|MSG0|;"how_many"
              (if (/= selection_set nil)
                (rtos (sslength selection_set) 2 0)
                ;|MSG0|;"0"
              )
    )
  )
  ;;
  ;;  X coordinate action.
  ;;
  (defun do_x_pt()
    (check_real (setq x_pt (get_tile ;|MSG0|;"x_pt")) ;|MSG0|;"x_pt")   ; if valid input
  )
  ;;
  ;;  Y coordinate action.
  ;;
  (defun do_y_pt()
    (check_real (setq y_pt (get_tile ;|MSG0|;"y_pt")) ;|MSG0|;"y_pt")   ; if valid input
  )
  ;;
  ;;  Z coordinate action.
  ;;
  (defun do_z_pt()
    (check_real (setq z_pt (get_tile ;|MSG0|;"z_pt")) ;|MSG0|;"z_pt")   ; if valid input
  )
  ;;
  ;; Reset the error tile to null.
  ;;
  (defun rs_error()
    (set_tile ;|MSG0|;"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 ;|MSG0|;"error"
                  (strcat "No vßlido "
                          (strcase (substr coord 1 1))
                          " coordenada."
                  )
        )
        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 ;|MSG0|;"*[] `#`@`.`?`*`~`[`,`'!%^&()+={}|`\\:;\"<>/]*")
      (progn
        (set_tile ;|MSG0|;"error" "Caracteres no vßlidos en el nombre del bloque.")
        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 ;|MSG0|;"x_pt")))
      ((not (check_real y_pt ;|MSG0|;"y_pt")))
      ((not (check_real z_pt ;|MSG0|;"z_pt")))

      ;; If block name is null, give message.
      ((and (/= 1 unnamed)
            (or (not bname) (= "" bname))
       )
        (set_tile ;|MSG0|;"error" "Nombre de bloque nulo no permitido.")
      )

      ;; 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 ;|MSG0|;"bname_exists" dcl_id)) (exit))
        (action_tile ;|MSG0|;"yes" ;|MSG0|;"(done_dialog 2)")
        (action_tile ;|MSG0|;"no" ;|MSG0|;"(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 "\nError de programaci≤n en bexist()."))
    )
  )
  ;;
  ;; 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)))) ;|MSG0|;"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 ;|MSG0|;"error" "Error - este bloque hace referencia a si mismo.")
      )
      ;;
      ((and self_list (self_ref bname self_list))
        (set_tile ;|MSG0|;"error" "Error - este bloque hace referencia a si mismo.")
      )
      (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 ;|MSG0|;"block" n)))) ; first entity
      (while en1
        (if (and (= ;|MSG0|;"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 ;|MSG0|;"list_blocks" dcl_id)) (exit))
    (if (not pat) (setq pat ;|MSG0|;"*"))
    (set_tile ;|MSG0|;"pattern" pat)
    (pat_match pat)
    (action_tile ;|MSG0|;"bl_match" ;|MSG0|;"(set_tile \"bl_match\" \"\")")
    (action_tile ;|MSG0|;"pattern" ;|MSG0|;"(pat_match (setq pat (xstrcase $value)))")
    (action_tile ;|MSG0|;"accept" ;|MSG0|;"(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 ;|MSG0|;"maxsort") (length bl_match)) ; Alphabetise the list
      (setq bl_match (sort bl_match))             ; in accordance with maxsort
    )
    (start_list ;|MSG0|;"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 (= ;|MSG0|;"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 ;|MSG0|;"*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 ;|MSG0|;"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 ;|MSG0|;"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 ;|MSG0|;"*"))))      ; 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 (= ;|MSG0|;"POLYLINE" ent_type)
           (and (= ;|MSG0|;"INSERT" ent_type) (= 1 (cdr (assoc '66 ent_list))))
       )
        (if (= ;|MSG0|;"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 (/= ;|MSG0|;"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 . ;|MSG0|;"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
      )
    )
  )

  ;; Main BMAKE routine

  (defun bmake_main (/ dcl_id olderr what_next )
    (if (< (setq dcl_id (load_dialog ;|MSG0|;"bmake.dcl")) 0) (exit))
    (setq olderr  *error*
          *error* bmake_error)
    (get_table ;|MSG0|;"block")               ; Make a list of blocks in the drawing.
    (setq what_next 5)
    (while (< 2 what_next)            ; Start the dialogue.
      (if (not (new_dialog ;|MSG0|;"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 ;|MSG0|;"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 ;|MSG0|;"bname"       ;|MSG0|;"(do_bname)")
      (action_tile ;|MSG0|;"unnamed"     ;|MSG0|;"(do_unnamed)")
      (action_tile ;|MSG0|;"pick_pt"     ;|MSG0|;"(done_dialog 4)")
      (action_tile ;|MSG0|;"x_pt"        ;|MSG0|;"(do_x_pt)")
      (action_tile ;|MSG0|;"y_pt"        ;|MSG0|;"(do_y_pt)")
      (action_tile ;|MSG0|;"z_pt"        ;|MSG0|;"(do_z_pt)")
      (action_tile ;|MSG0|;"sel_objs"    ;|MSG0|;"(done_dialog 3)")
      (action_tile ;|MSG0|;"list_blocks" ;|MSG0|;"(list_blocks)")
      (action_tile ;|MSG0|;"retain"      ;|MSG0|;"(setq retain (atoi $value))")
      (action_tile ;|MSG0|;"accept"      ;|MSG0|;"(bexist)")
      (action_tile ;|MSG0|;"cancel"      ;|MSG0|;"(done_dialog 0)")
      (action_tile ;|MSG0|;"help"        ;|MSG0|;"(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 . ;|MSG0|;"<AND")
                           (-4 . ;|MSG0|;"<NOT")(0 . ;|MSG0|;"VIEWPORT")(-4 . ;|MSG0|;"NOT>")
                           (-4 . ;|MSG0|;"<NOT")(0 . ;|MSG0|;"SHAPE")(-4 . ;|MSG0|;"NOT>")
                        (-4 . ;|MSG0|;"AND>"))
                )
          )
          (rs_error)
        )
        ;; If base point was picked...
        ((= what_next 4)
          (initget 1)
          (setq pick_pt (getpoint "Punto de base para la inserci≤n: "))
          (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)
  )

  (if (ai_notrans) (bmake_main))      ; BMAKE can't be used transparently
  (princ)
)

;;;---------------------------------------------------------------------------;
;;; This is printed on loading.
;;;---------------------------------------------------------------------------;
(princ "\nC:BMAKE cargado. Iniciar el comando con BMAKE.")
(princ)