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

Lisp/Scheme | 1995-02-08 | 17.3 KB | 499 lines

; Next available MSG number is    68
; MODULE_ID XDATA_LSP_
;;;---------------------------------------------------------------------------;
;;;
;;;    XDATA.LSP
;;;
;;;    Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Autodesk, Inc.
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;.
;;;
;;;---------------------------------------------------------------------------;
;;;  DESCRIPTION
;;;
;;;   XDATA
;;;
;;;   Program that attaches extended data types to a selected entity.
;;;
;;;   After selecting an entity and entering an application name for the
;;;   extended data, the following types of extended data are prompted for:
;;;
;;;    1)  An ASCII string up to 255 bytes long (group code 1000).
;;;    2)  A layer name (group code 1003).
;;;    3)  An entity handle (group code 1005).
;;;    4)  3 real numbers (group code 1010).
;;;    5)  A 3D World space position (group code 1011).
;;;    6)  A 3D World space displacement (group code 1012).
;;;    7)  A 3D World space direction (group code 1013).
;;;    8)  A real number (group code 1040).
;;;    9)  A distance (group code 1041).
;;;   10)  A scale factor (group code 1042).
;;;   11)  A 16-bit integer (group code 1070).
;;;   12)  A 32-bit signed long integer (group code 1071).
;;;
;;;   Numbers 5, 6, 7, 9 and 10 are "transformable" data types, and
;;;   are either moved, scaled, rotated or mirrored along with the parent
;;;   entity, or possibly some combination of these, depending on the
;;;   group code and the nature of the operation on the parent entity.
;;;
;;;   Binary data chunks (group code 1004) are not supported.
;;;
;;;
;;;   XDLIST
;;;
;;;   Program that lists the Xdata associated with an application for the
;;;   selected entity.
;;;
;;;   For a complete description of extended data types see the "AutoCAD
;;;   Reference Manual."
;;;
;;;---------------------------------------------------------------------------;


;;;---------------------------------------------------------------------------;
;;; Internal error handling.
;;;---------------------------------------------------------------------------;

(defun xdataerr(s)
  (if (/= s "Funci≤n cancelada")
    (princ (strcat "\nError: " s))
  )
  (setq *error* olderr)
  (if ename (redraw ename 4))         ; de-highlight entity
  (princ)
)

;;;---------------------------------------------------------------------------;
;;; Get user input.
;;;---------------------------------------------------------------------------;

(defun getinput (/ cont esel)

  ;; Forces selection of an entity and sets ename to the name of the
  ;; selected entity.

  (while
    (not (setq esel (entsel)))
  )

  (if (= which 1)                     ; If XDATA() is happening...
    (progn
      (setq ename (car esel))         ; Get entity info...
      (redraw ename 3)                ; ...highlight entity
      (setq elist (entget ename (list "*"))) ; ...including xdata for all
                                      ; registered applications.

      ;; Force the entry of a registered application name (group code 1001).

      (setq cont T)
      (while cont
        (setq rname (xstrcase (getstring "\nNombre de la aplicaci≤n: ")))
        (if (/= rname "")
          (setq cont nil)
        )
      )
    )
  )
  (if (= which 2)                     ; If XDPRINT() is happening...
    (progn
      (setq ename (car esel))         ; Get entity info
      (redraw ename 3)                ; ...highlight entity
      (setq rname (xstrcase (getstring "\nNombre de la aplicaci≤n <*>: ")))
      (if (= rname "")                ; If null input, get all.
        (setq rname "*")
      )
      (setq elist (entget ename (list rname)))
    )
  )
)

;;;---------------------------------------------------------------------------;
;;; Get user values for extended entity data and build XD_LIST.
;;;---------------------------------------------------------------------------;

(defun getdata (/ xd_type)

  (setq xflag 0)

  ;; Check whether the selected entity has some extended data already.

  (if (assoc -3 elist)
    (progn
      (setq size_old (xdsize (assoc -3 elist)))
      (princ "\nEl objeto tiene ")
      (princ size_old )
      (princ " bytes de Xdata - se a±adirßn nuevos Xdata.\n")
    )
  )

  (setq xd_list (list '(1002 . "}"))) ; Initialize list of xdata for this app.

  (setq xd_type T)                    ; Initialize loop terminator.

  (while (not (or (eq xd_type "Salir") (eq xd_type "Salir") (eq xd_type nil)))
    (setq hand (getvar "handles"))
    (initget                          ; Initialize keyword list.
      (strcat "cAdena Capa 3real desPlazamiento pOsici≤n Identificador"
            " Direcci≤n Real disTancia Escala"
            " eNtero Long Salir"

      )
    )

    (setq xd_type (getkword (strcat   ; Prompt user to select keyword.
       "\n3real/Dir/desP/disT/Ident/eNt/Capa/Long/pOs/Real/Escala/cAdena/<Salir>: "))
    )

    ;; Add sub-list to xdata list.

    (cond
      ((eq xd_type "3real")
        (if (/= (setq input (getpoint "\n3 n·meros reales: ")) nil)
           (setq xd_list (cons (cons 1010 input) xd_list))
        )
      )
      ((eq xd_type "Direcci≤n")
        (if (/= (setq input (getpoint "\nDirecci≤n en SCU 3D: ")) nil)
          (setq xd_list (cons (cons 1013 input) xd_list))
        )
      )
      ((eq xd_type "desPlazamiento")
        (if (/= (setq input (getpoint "\nDesplazamiento en SCU 3D: ")) nil)
          (setq xd_list (cons (cons 1012 input) xd_list))
        )
      )
      ((eq xd_type "disTancia")
        (if (/= (setq input (getdist "\nDistancia: ")) nil)
          (setq xd_list (cons (cons 1041 input) xd_list))
        )
      )
      ((eq xd_type "Identificador")
        (if (or ( = (setq hand (getstring "\nIdentificador de base de datos: ")) "0")
                (handent hand)
            )
          (setq xd_list (cons (cons 1005 hand) xd_list))
          (if (/= hand "")
            (princ "\nIdentificador no vßlido - el identificador debe existir o tener el valor 0.")
          )
        )
      )
      ;; Values entered greater than 32767 cause AutoLISP to issue an
      ;; error message stating "Value must be between -32767 and 32767. "
      ;; Values less than 0 are trapped out by the (initget).  Though the
      ;; message may be confusing, the values are always correct.  This is
      ;; an AutoLISP limitation.
      ((eq xd_type "eNtero")
        (initget 4)
        (if (/= (setq input (getint "\nN║ entero de 16 bits: ")) nil)
          (setq xd_list (cons (cons 1070 input) xd_list))
        )
      )
      ((eq xd_type "Capa")
        (setq input (getstring "\nNombre de capa: "))
        (if (tblsearch ;|MSG0|;"layer" input)
          (setq xd_list (cons (cons 1003 input) xd_list))
          (if (/= input "")
            (princ "\nNombre de capa no vßlido - la capa debe existir.")
          )
        )
      )
      ((eq xd_type "Long")
        (if (/= (setq input (getint "\nN║ entero de 32 bits con signo: ")) nil)
          (setq xd_list (cons (cons 1071 input) xd_list))
        )
      )
      ((eq xd_type "pOsici≤n")
        (if (/= (setq input (getpoint "\nPosici≤n en el espacio SCU 3D: ")) nil)
          (setq xd_list (cons (cons 1011 input) xd_list))
        )
      )
      ((eq xd_type "Real")
        (if (/= (setq input (getreal "\nN·mero real: ")) nil)
          (setq xd_list (cons (cons 1040 input) xd_list))
        )
      )
      ((eq xd_type "Escala")
        (if (/= (setq input (getreal "\nFactor de escala: ")) nil)
          (setq xd_list (cons (cons 1042 input) xd_list))
        )
      )
      ((eq xd_type "cAdena")
        (setq xd_list (cons (cons 1000 (getstring T
          "\nCadena ASCII: ")) xd_list))
      )
      (t)
    )
  )

  ;; Was any xdata entered besides a registered application name ??

  (setq xflag (length xd_list))

  ;; Append opening brace to front of xdata list.

  (setq xd_list (cons '(1002 . "{") xd_list))

  ;; Append application name to front of xdata list.

  (setq xd_list (cons rname xd_list))

  ;; Append -3 group code to front of list containing xdata list.

  (setq xd_list (list -3 xd_list))

  ;; Find the total size of the new xdata.

  (setq size_new (xdsize xd_list))
)


;-----------------------------------------------------------------------------;
; XDATA
;-----------------------------------------------------------------------------;

(defun c:xdata (/ all elist ename old olderr new rname size_new xd_list
                  xd_list1 xd_list2 xd_list3 xd_ent regflag hand xflag
                  size_old which)



  (setq olderr *error*                ; Use special error handling function.
        *error* xdataerr)

  (setq which 1)                      ; Flag for (getinput)

  (setq regflag 0)                    ; Regapp flag.

  (getinput)                          ; Prompt for user input

  (redraw ename 4)                    ; De-highlight entity



  (if (regapp rname)                  ; Register the application name.
    (princ (strcat "\n" rname " nueva aplicaci≤n.\n"))
    (princ (strcat "\nAplicaci≤n " rname " ya registrada.\n"))
  )

  ;; Prompt for user values for xdata and build xdata list XD_LIST.

  (getdata)

  ;; The extended data list is now added to the entity data.  This is a
  ;; little more involved if the entity already has extended data.  A check
  ;; of available Xdata space must be made too.

  (if (< size_new (xdroom ename))     ; If there is room for more...
    (progn
      (if (assoc -3 elist)            ; and contains xdata already...
        (progn
          (setq xd_list (cdr xd_list)) ; New xdata.
          (setq xd_ent (cdr (assoc -3 elist))) ; Old xdata.
          ;; Find old xdata with same regapp
          (if (setq old (cddr (assoc rname xd_ent)))
            (progn
              (setq regflag 1)
              (setq new (cdr (reverse (cddr (assoc rname xd_list)))))
              (setq all (append new old)) ; Join old and new xdata with
                                      ; same application name.
              (setq xd_list1 (cons (cons 1002 "{") all)) ; Add open curly
              (setq xd_list2 (cons rname xd_list1)) ; Add regapp

              ;; Substitute back into existing xdata list.

              (setq xd_list3 (subst xd_list2 (assoc rname xd_ent)
                                             (assoc -3 elist)))
           )
            (progn                    ; This is a new regapp...
              (setq xd_list (append xd_ent xd_list)) ; Joins xdata.
              (setq xd_list3 (cons -3 xd_list))
            )
          )
          (setq elist (subst xd_list3 (assoc -3 elist) elist)) ; Joins entity
        )
        (setq elist (cons xd_list elist)) ; No xdata yet.
      )

    )
    (princ (strcat "\nEspacio insuficiente para Xdata en el objeto"
                   "- no se han a±adido nuevos Xdata.")
    )
  )

  ;; Finally update the entity in the database to contain the new xdata.

  (if (entmod elist)
    (if (and (= 1 regflag) (<= xflag 1))   ; old application name
      (princ "\nNo se han a±adido Xdata.")
      (princ "\nSe han a±adido nuevos Xdata.")
    )
  )

  (setq *error* olderr)               ; Reset the error function.
  (redraw ename 4)                    ; Dehighlight entity.

  (prin1)
)

;;;---------------------------------------------------------------------------;
;;;  XDLIST
;;;---------------------------------------------------------------------------;

(defun C:XDLIST (/ linecount xd_list app_list app_sub_list xd_code
                   xd_data rname elist ename)

  (setq olderr *error*                ; Redefine error handler.
        *error* xdataerr)

  (setq which 2)                      ; Flag for (getinput)

  (getinput)                          ; Get user input.

  (redraw ename 4)                    ; De-highlight entity.

  ;; See if there's any xdata in the selected entity associated with the
  ;; application name.

  (if (not (setq xd_list (assoc -3 elist)))
    (progn
      (princ "\nNo hay Xdata asociados con el nombre de la aplicaci≤n.")
    )
    (setq xd_list (cdr xd_list))      ; Strip -3 from xd_list
  )

  (setq linecount 0)                  ; # of lines printed

  (while xd_list                      ; There's any xdata left...
    (setq app_list (car xd_list))
    (textscr)
    (princ "\n\n* Nombre de aplicaci≤n registrado: ")
    (princ (car app_list))
    (setq app_list (cdr app_list))    ; Strip app name
    (while app_list
      (setq app_sub_list (car app_list))  ; Get sub list
      (setq xd_code (car app_sub_list))   ; Get group code
      (setq xd_data (cdr app_sub_list))   ; Get data

      ;; Conditions for all group codes.
      ;; Prints 'em all except binary chunks.
      (cond
        ((= 1000 xd_code)
          (princ "\n* C≤digo 1000, cadena ASCII: ")
          (princ xd_data)
        )
        ((= 1001 xd_code)
          (princ "\n* C≤digo 1001, nombre de aplicaci≤n registrado: ")
          (princ xd_data)
        )
        ((= 1002 xd_code)
          (princ "\n* C≤digo 1002, corchete abierto o cerrado: ")
          (princ xd_data)
        )
        ((= 1003 xd_code)
          (princ "\n* C≤digo 1003, nombre de capa: ")
         (princ xd_data)
        )
        ((= 1004 xd_code)
          (princ "\n* C≤digo 1004, datos binarios no impresos.")
        )
        ((= 1005 xd_code)
          (princ "\n* C≤digo 1005, identificador de base de datos: ")
          (princ xd_data)
        )
        ((= 1010 xd_code)
          (princ "\n* C≤digo 1010, 3 n·meros reales: ")
          (princ (strcat "("
                 (rtos (car xd_data)) " "
                 (rtos (cadr xd_data)) " "
                 (rtos (caddr xd_data)) ")"))
        )
        ((= 1011 xd_code)
          (princ "\n* C≤digo 1011, posici≤n en SCU 3D: ")
          (princ (strcat "("
                 (rtos (car xd_data)) " "
                 (rtos (cadr xd_data)) " "
                 (rtos (caddr xd_data)) ")"))
        )
        ((= 1012 xd_code)
          (princ "\n* C≤digo 1012, desplazamiento en SCU 3D: ")
          (princ (strcat "("
                 (rtos (car xd_data)) " "
                 (rtos (cadr xd_data)) " "
                 (rtos (caddr xd_data)) ")"))
        )
        ((= 1013 xd_code)
          (princ "\n* C≤digo 1013, direcci≤n en SCU 3D: ")
          (princ (strcat "("
                 (rtos (car xd_data)) " "
                 (rtos (cadr xd_data)) " "
                 (rtos (caddr xd_data)) ")"))
        )
        ((= 1040 xd_code)
          (princ "\n* C≤digo 1040, n·mero real: ")
          (princ (rtos xd_data))
        )
        ((= 1041 xd_code)
          (princ "\n* C≤digo 1041, distancia: ")
          (princ (rtos xd_data))
        )
        ((= 1042 xd_code)
          (princ "\n* C≤digo 1042, factor de escala: ")
          (princ (rtos xd_data))
        )
        ((= 1070 xd_code)
          (princ "\n* C≤digo 1070, n║ entero de 16 bits: ")
          (princ xd_data)
        )
        ((= 1071 xd_code)
          (princ "\n* C≤digo 1071, n║ entero de 32 bits con signo: ")
          (princ (rtos xd_data 2 0))
        )
        (t
          (princ "\n* C≤digo de Xdata desconocido: ")
          (princ xd_code)
          (princ " *")
        )
      )
      (setq app_list (cdr app_list))
      (setq linecount (1+ linecount))
      (if (>= linecount 20)           ; Pause at 20 lines printed.
        (progn
          (getstring "\n-mßs-")
          (setq linecount 0)
        )
      )
    )
  (setq xd_list (cdr xd_list))        ; Get next xdata list.
)


  (princ "\n\nEl objeto tiene ")
  (princ (xdroom ename))              ; Figure how much room is left.
  (princ " bytes de espacio Xdata disponible.")

  (setq *error* olderr)               ; Reset the error function.
  (prin1)                             ; Quiet exit.

)
;;;---------------------------------------------------------------------------;
(princ "\nC:XDATA cargada. Teclee XDATA y XDLIST para definir y ver datos. ")
(princ)