home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / acad / autolisp / econo3 / econo3.lsp
Lisp/Scheme  |  1991-10-13  |  22KB  |  491 lines
  1. ;;; -*-  Mode: LISP -*- (C) Benjamin Olasov 1990
  2. ;;;  Linework Economizer v. 3.0
  3.  
  4. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5. ;;; File: ECONO.LSP     Copyright (C) Ben Olasov 1990                       ;;;
  6. ;;; Inquiries:                                                              ;;;
  7. ;;;                                                                         ;;;
  8. ;;;       Ben Olasov     LISPenard Technologies                             ;;;
  9. ;;;                      New York, NY                                       ;;;
  10. ;;;                                                                         ;;;
  11. ;;;                      Voice:    (212) 274-8506     (212) 979-3732        ;;;
  12. ;;;                      FAX:      (212) 979-3686     (212) 979-3611        ;;;
  13. ;;;                      Arpanet:  olasov@cs.columbia.edu                   ;;;
  14. ;;;                      Internet: ben@syska.com                            ;;;
  15. ;;;                                                                         ;;;
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17.  
  18. ;; Lispenard Technologies provides this program 'as is', without warranty of 
  19. ;; any kind, either expressed or implied, including, but not limited to the 
  20. ;; implied warranties of merchantability and fitness for a particular purpose. 
  21. ;; This program remains the intellectual property of Lispenard Technologies, 
  22. ;; and is not to be resold or distributed without the written consent of 
  23. ;; Lispenard Technologies. 
  24. ;;
  25. ;; In no event shall Lispenard Technologies be liable to anyone for special, 
  26. ;; collateral, incidental, or consequential damages in connection with or 
  27. ;; arising out of purchase or use of these materials.  The entire risk as to
  28. ;; the quality and performance of the program is with the user.  Should the 
  29. ;; program prove defective, the user assumes the entire cost of all necessary 
  30. ;; servicing, repair or correction.
  31. ;; 
  32. ;; Inquiries regarding conditions of use, and requests for modification of 
  33. ;; this code for use in other than the English language, should be directed 
  34. ;; to Lispenard Technologies, 33 Lispenard Street, New York, NY  10013.
  35. ;; 
  36. ;; Lispenard Technologies reserves the right to revise and improve its 
  37. ;; products as it sees fit.  Any comments contained in this code describe the
  38. ;; state of this product at the time of its publication, and may not reflect
  39. ;; the product at all times in the future. 
  40. ;;
  41. ;; AutoLisp and AutoCad are registered trademarks of AutoDesk, Inc.
  42.  
  43. (VMON)
  44. (gc)
  45.  
  46. (princ "\nLoading- please wait...")
  47.  
  48. (expand 100)
  49.  
  50. (defun C:ECONO ()
  51.        (start_timer)
  52.        (create_layer_table)
  53.        (if (= explode_plines? "Y")
  54.            (explode_plines))
  55.        (economize_by_layer)
  56.        (if (= compress? "Y")
  57.            (compress_by_layer))
  58.        (restore_layers)
  59.        (if (= compress? "Y")
  60.            (explode_1segment_plines))
  61.        (stop_timer))
  62.  
  63. (defun start_timer ()
  64.        (setq deleted 0
  65.              c_date (getvar "cdate")
  66.              s_date (getvar "tdusrtimer")
  67.              dwg (getvar "dwgname")
  68.              explode_plines? (strcase (userstr (if explode_plines? explode_plines? "Y")
  69.                                                "Explode polylines before beginning?"))
  70.              compress? (strcase (userstr (if compress? compress? "Y")
  71.                                          "Join touching lines into multi-segment polylines?")))
  72.        (princ (strcat "\nStarting to process drawing " dwg " on " (parse_time c_date))))
  73. (defun stop_timer ()
  74.        (setq e_date (getvar "tdusrtimer")
  75.              t_secs (* 86400.0 (- e_date s_date))
  76.              hrs (fix (/ t_secs 3600.0))
  77.              mns (fix (/ (- t_secs (* hrs 3600.0)) 60.0))
  78.              secs (- t_secs (+ (* hrs 3600.0) (* mns 60.0))))
  79.        (if (null (setq fil (open (strcat dwg ".eco") "a")))
  80.            (progn (princ (strcat "\nCouldn't open " dwg ".eco for writing.
  81. Writing to current directory instead."))
  82.                   (setq fil (open (strcat dwg ".eco") "a"))))
  83.        (princ "\nECONOMIZE active for ")
  84.        (princ (strcat "\nStarted processing drawing " dwg " on " (parse_time c_date)) fil)
  85.        (princ "\nECONOMIZE v. 2.1 active for " fil)
  86.        (if (> hrs 0.0)
  87.            (princ (strcat (itoa hrs) " hour" (if (> hrs 1) "s" "") ", ") fil))
  88.        (if (> mns 0.0)
  89.            (princ (strcat (itoa mns) " minute" (if (> mns 1) "s" "") ", ") fil))
  90.        (princ (strcat (rtos secs 2 3) " seconds.") fil)
  91.        (princ (strcat "\nFile: " dwg ": Deleted a total of " (itoa deleted) " redundant lines.") fil)
  92.        (princ "\n--------" fil)
  93.        (close fil)
  94.        (if (> hrs 0.0)
  95.            (princ (strcat (itoa hrs) " hour" (if (> hrs 1) "s" "") ", ")))
  96.        (if (> mns 0.0)
  97.            (princ (strcat (itoa mns) " minute" (if (> mns 1) "s" "") ", ")))
  98.        (princ (strcat (rtos secs 2 3) " seconds."))
  99.        (princ (strcat "\nFile: " dwg ": Deleted a total of " (itoa deleted) " redundant lines."))
  100.        (princ))
  101.  
  102. (defun economize_by_layer ()
  103.        (setq c_lay (getvar "clayer"))
  104. ;       (setvar "regenmode" 0)
  105.        (setvar "cmdecho" 0)
  106.        (setvar "blipmode" 0)
  107.        (setvar "osmode" 0)
  108.        (foreach lyr (mapcar 'car lyrs)
  109.                 (if (and (setq lines (ssget "x" (list (cons 0 "LINE")
  110.                                                (cons 8 lyr)))
  111.                                *lines* lines)
  112.                           (setq lines_l (sslength lines)))
  113.                     (process_lines lyr)))
  114.         (command "layer" "t" "*" "on" "*" "s" c_lay ""))
  115.  
  116. (defun create_layer_table ()
  117.        (setq c_lay (getvar"clayer")
  118.              lyr_data (tblnext "layer" t)
  119.              lyr_nm (cdr (assoc 2 lyr_data))
  120.              lyr_thawed? (cdr (assoc 70 lyr_data))
  121.              lyr_on? (cdr (assoc 62 lyr_data))
  122.              lyrs (list (list lyr_nm lyr_thawed? lyr_thawed?)))
  123.        (while (setq lyr_data (tblnext "layer"))
  124.               (setq lyr_nm (cdr (assoc 2 lyr_data))
  125.                     lyr_thawed? (cdr (assoc 70 lyr_data))
  126.                     lyr_on? (cdr (assoc 62 lyr_data))
  127.                     lyrs (cons (list lyr_nm lyr_thawed? lyr_on?) lyrs))))
  128.  
  129. (defun freeze_all_but (layr)
  130.        (command "layer" "t" layr "on" layr "s" layr)   ;; Thaw working layer
  131.        (foreach l (aux_remove layr (mapcar 'car lyrs)) ;; Freeze all others
  132.                 (command "f" l))
  133.        (command ""))
  134.  
  135. ; (70 . 64) thawed
  136. ; (70 . 65) frozen
  137. ; (62 . 7)  on 
  138. ; (62 . -7) off 
  139.  
  140. (defun restore_layers ()
  141.        (command "layer")
  142.        (setq c_lay_data (assoc c_lay lyrs)
  143.              lyr_thawed? (cadr c_lay_data)
  144.              lyr_on? (caddr c_lay_data))
  145.        (if (= lyr_thawed? 65)
  146.            (command "f" c_lay)
  147.            (command "t" c_lay))
  148.        (if (> lyr_on? 0)
  149.            (command "on" c_lay)
  150.            (command "off" c_lay))
  151.        (command "s" c_lay)
  152.        (foreach lr (aux_remove c_lay_data lyrs);; read layer data 
  153.                 (setq lyr_nm (car lr)          ;; from layer property table
  154.                       lyr_thawed? (cadr lr)
  155.                       lyr_on? (caddr lr))
  156.                 (if (= lyr_thawed? 65)
  157.                     (command "f" lyr_nm)
  158.                     (command "t" lyr_nm))
  159.                 (if (> lyr_on? 0)
  160.                     (command "on" lyr_nm)
  161.                     (command "off" lyr_nm)))
  162.        (command ""))
  163.  
  164. (defun process_lines (layr / incr)
  165.        (freeze_all_but layr)
  166.        (if lines (progn (terpri)
  167.                         (setq incr 0
  168.                               ssl (sslength lines)
  169.                               l_deleted 0)
  170.                         (repeat ssl
  171.                                 (setq ln (ssname lines incr))
  172.                                 (princ (strcat "\rProcessing line "
  173.                                                (itoa (1+ incr)) " of "
  174.                                                (itoa lines_l)
  175.                                                " on layer " layr))
  176.                                 (if (and ln (ssmemb ln *lines*))
  177.                                     (compile ln))
  178.                                 (setq incr (1+ incr)))))
  179.        (princ (strcat "\t\tDeleted " (itoa l_deleted) " redundant lines.")))
  180.  
  181. (defun compile (lin / ld *lin_ss ptlst ext_pts i sl)
  182.        (if lin
  183.            (progn (setq lin* lin
  184.                         ld (get_line_data lin)
  185.                         lin_ss (ssget "c" *p1* *p2*)
  186.                         *lin_ss* (ss2enamlist lin_ss)
  187.                         *lin_ss (filter_non-colinear_segments lin *lin_ss*)
  188.                         ptlst (create_ptlst *lin_ss))
  189.                   (if (and *lin_ss
  190.                            (> (sslength *lin_ss) 1))
  191.                       (progn (setq ext_pts (extreme_pts ptlst)
  192.                                    lin1 (ssname *lin_ss 0)
  193.                                    *lin1 (entget lin1)
  194.                                    lyr (cdr (assoc 8 *lin1)))
  195.                              (if (and *lin_ss 
  196.                                       (setq *ssl (sslength *lin_ss)))   
  197.                                  (progn (setq deleted (+ deleted *ssl)
  198.                                               l_deleted (+ l_deleted *ssl))
  199.                                         (command "erase" *lin_ss "")
  200.                                         (command "layer" "m" lyr "")
  201.                                         (command "line" (car ext_pts)
  202.                                                         (cadr ext_pts) ""))) 
  203.                              T)))))
  204.  
  205. (defun create_ptlst (ss / i sl l1 *l1 n1 n2 pts)
  206.        (cond ((null ss) nil)
  207.              ((/= (type ss) 'PICKSET) nil)
  208.              ((< (setq sl (sslength ss)) 2) nil)
  209.              (T (setq i 1
  210.                       sl (sslength ss)
  211.                       l1 (ssname ss 0)
  212.                       *l1 (entget l1)
  213.                       n1 (cdr (assoc 10 *l1))
  214.                       n2 (cdr (assoc 11 *l1))
  215.                       pts (list n1 n2))
  216.                 (repeat (1- sl)
  217.                         (setq l1 (ssname ss i)
  218.                               *l1 (entget l1)
  219.                               n1 (cdr (assoc 10 *l1))
  220.                               n2 (cdr (assoc 11 *l1)))
  221.                         (if (null (member n1 pts))
  222.                             (setq pts (append pts (list n1))))
  223.                         (if (null (member n2 pts))
  224.                             (setq pts (append pts (list n2))))
  225.                         (setq i (1+ i)))
  226.                 pts)))
  227.  
  228. (defun filter_non-colinear_segments (lin enamlst / l sl)
  229.        (cond ((or (null enamlst)
  230.                   (null lin)) nil)
  231.              (T (foreach l enamlst
  232.                          (if (and l  ;; if line isn't parallel to test line, 
  233.                                   (not (colinear lin l))) ;; delete it from set
  234.                              (ssdel l lin_ss)    ;; of lines to be processed
  235.                              (ssdel l *lines*))) ;; else, assume it will be erased.
  236.        lin_ss)))
  237.  
  238. (defun extreme_pts (pt_list)
  239.        (cond ((or (null pt_list)
  240.                   (< (length pt_list) 2)) nil) ;; termination condition
  241.              ((= (length pt_list) 2) pt_list)  ;; only 2 pts in list
  242.              (T (setq n1 (car pt_list)         ;; find extreme points
  243.                       n2 (cadr pt_list))
  244.                 (cond ((v-orient n1 n2)
  245.                        (setq plst (mapcar 'xy pt_list)
  246.                              rev_p (mapcar 'reverse plst)
  247.                              y_coords (mapcar 'car rev_p)
  248.                              min_y (apply 'min y_coords)
  249.                              max_y (apply 'max y_coords)
  250.                              _n1 (assoc min_y rev_p)
  251.                              _n2 (assoc max_y rev_p)
  252.                              *n1 (reverse _n1)
  253.                              *n2 (reverse _n2)))
  254.                       ((h-orient n1 n2)
  255.                        (setq plst (mapcar 'xy pt_list)
  256.                              x_coords (mapcar 'car plst)
  257.                              min_x (apply 'min x_coords)
  258.                              max_x (apply 'max x_coords)
  259.                              *n1 (assoc min_x plst)
  260.                              *n2 (assoc max_x plst)))
  261.                       ((setq direct (diagonal n1 n2))
  262.                        (setq plst (mapcar 'xy pt_list)
  263.                              rev_p (mapcar 'reverse plst)
  264.                              x_coords (mapcar 'car plst)
  265.                              y_coords (mapcar 'car rev_p)
  266.                              min_x (apply 'min x_coords)
  267.                              max_x (apply 'max x_coords)
  268.                              min_y (apply 'min y_coords)
  269.                              max_y (apply 'max y_coords))
  270.                        (if (= direct 'LLUR) ; if we got this far, DIRECT is non-nil
  271.                            (setq  *n1 (list min_x min_y)
  272.                                   *n2 (list max_x max_y))
  273.                            (setq  *n1 (list max_x min_y)  
  274.                                   *n2 (list min_x max_y)))))
  275.                      (list *n1 *n2))))
  276.  
  277. (defun get_line_data (line)
  278.        (setq elist (entget line)
  279.              *p1* (cdr (assoc 10 elist))
  280.              *p2* (cdr (assoc 11 elist))
  281.              *ang1* (angle *p1* *p2*)
  282.              h_pi* (/ pi 2.0)))
  283.  
  284. (defun colinear (lin1 lin2 / line1 line2)
  285.        (if (and lin1 lin2
  286.                 (setq line1 (entget lin1))
  287.                 (setq line2 (entget lin2))
  288.                 (setq l1p1 (cdr (assoc 10 line1)))
  289.                 (setq l1p2 (cdr (assoc 11 line1)))
  290.                 (setq l2p1 (cdr (assoc 10 line2)))
  291.                 (setq l2p2 (cdr (assoc 11 line2)))
  292.                 (setq ang1 (rad2deg (angle l1p1 l1p2)))
  293.                 (setq ang2a (rad2deg (angle l2p1 l2p2)))
  294.                 (setq ang2b (rad2deg (angle l2p2 l2p1))))
  295.            (progn (if (not (equal l1p1 l2p1))
  296.                       (setq ang3 (rad2deg (angle l1p1 l2p1)))
  297.                       (setq ang3 nil))
  298.                   (if (not (equal l1p1 l2p2))
  299.                       (setq ang4 (rad2deg (angle l1p1 l2p2)))
  300.                       (setq ang3 nil))
  301.                   (and (or (= ang1 ang2a) ; pass the test for parallelism
  302.                            (= ang1 ang2b))
  303.                        (or (= ang2a ang3) ; pass the test that one point
  304.                            (= ang2b ang3) ; on the segment is colinear with
  305.                            (= ang2a ang4) ; the test segment
  306.                            (= ang2b ang4))))))
  307.  
  308. (defun ~= (actual_value test_value tolerance)  ;;fuzzy equality
  309.        (if (and actual_value test_value tolerance)
  310.            (<= (abs (- actual_value test_value)) tolerance)))
  311.  
  312. (defun DEG2RAD (ang)
  313.        (* pi (/ ang 180.000000)))
  314.  
  315. (defun RAD2DEG (ang)
  316.        (* ang (/ 360 (* pi 2.000000))))
  317.  
  318. (defun pos-in-list (item lst)
  319.         (if (null (member item lst))
  320.             nil
  321.             (- (length lst) (length (cdr (member item lst))))))
  322.  
  323. (defun 2D-TO-3D (pt elev)   ;; Construct 3D point with elev as Z coordinate
  324.        (if pt (append (xy pt) (list elev))
  325.               (append (getpoint "\nFirst point: ") (list elev))))
  326.  
  327. (defun XY (pt) ;; convert 3D point to 2D
  328.        (list (car pt) (cadr pt)))
  329.  
  330. ;; find closest point in node list "nodes" to point "pt"'
  331. (defun closest (pt nodes)
  332.        (nth
  333.           (1- (pos-in-list
  334.                  (apply 'min (mapcar '(lambda (node) (distance pt node)) nodes))
  335.                              (mapcar '(lambda (node) (distance pt node)) nodes)))
  336.         nodes))
  337.  
  338. (defun v-orient (p1 p2) ;;are two points in a basically vertical relationship?
  339.         (> (abs (- (cadr p1) (cadr p2))) 
  340.            (abs (- (car p1) (car p2))))) 
  341.  
  342. (defun vertical (p1 p2)
  343.        (= (car p1) (car p2)))
  344.  
  345. (defun horizontal (p1 p2)
  346.        (= (cadr p1) (cadr p2)))
  347.  
  348. (defun h-orient (p1 p2) ;;are two points in a horizontal relationship?
  349.         (< (abs (- (cadr p1) (cadr p2))) 
  350.            (abs (- (car p1) (car p2))))) 
  351.  
  352. (defun diagonal (p1 p2 / ang1)
  353.        (setq ang1 (rad2deg (angle p1 p2)))
  354.        (cond ((or (= ang1 45.0)
  355.                   (= ang1 225.0)) 'LLUR)  ;; return direction of vector
  356.              ((or (= ang1 135.0)
  357.                   (= ang1 315.0)) 'LRUL)  ;; return direction of vector
  358.              (T nil)))                    ;; else, nil
  359.  
  360. (defun left-to-right (p1 p2) ;;is vector P1 P2 pointing to right?
  361.           (and (h-orient p1 p2)
  362.                (<= (car p1) (car p2))))
  363.  
  364. (defun right-to-left (p1 p2)  ;;is vector P1 P2 pointing to left?
  365.           (and (h-orient p1 p2)
  366.                (> (car p1) (car p2))))
  367.  
  368. (defun top-to-bottom (p1 p2) ;;is vector P1 P2 pointing down?
  369.           (and (v-orient p1 p2)
  370.                (> (cadr p1) (cadr p2))))
  371.  
  372. (defun bottom-to-top (p1 p2)  ;;is vector P1 P2 pointing up?
  373.           (and (v-orient p1 p2)
  374.                (<= (cadr p1) (cadr p2))))
  375.  
  376. ;; convert a selection set to a list of entity lists
  377. (defun ss2enamlist (ss / entlist ctr)
  378.        (if ss (progn
  379.            (setq ctr 0)
  380.            (repeat (sslength ss)
  381.                    (progn (setq entlist (cons (ssname ss ctr) entlist))
  382.                           (setq ctr (1+ ctr)))))) (if entlist entlist))
  383.  
  384. ;(defun ~= (actual_value test_value tolerance)  ;;fuzzy equality
  385. ;       (and (<= actual_value (+ test_value tolerance))
  386. ;            (>= actual_value (- test_value tolerance))))
  387.  
  388. (defun aux_remove (atm lst) 
  389.        (cond ((null lst) nil) 
  390.              ((null (member atm lst)) lst)
  391.              ((equal atm (car lst)) (cdr lst))
  392.              (t (append (reverse (cdr (member atm (reverse lst))))
  393.                         (cdr (member atm lst))))))
  394.  
  395. (defun parse_time (cdate / date_str year month day hour min secs date)
  396.        (if cdate
  397.            (setq date_str (rtos cdate 2 6)
  398.                  year (substr date_str 3 2)
  399.                  month (substr date_str 5 2) 
  400.                  day (substr date_str 7 2)
  401.                  hour (substr date_str 10 2)
  402.                  min (substr date_str 12 2)
  403.                  secs (substr date_str 14 2)
  404.                  date (strcat month "/" day "/" year "  " hour ":" min ":" secs))))
  405.  
  406. (defun explode (str / firstchr *str*)  ;; iterative text explosion
  407.       (if (null str) nil
  408.           (repeat (strlen str)
  409.                   (progn
  410.                       (setq *str* (cons (setq firstchr (substr str 1 1)) *str*))
  411.                       (setq str (substr str 2))))) (reverse *str*))
  412.  
  413. (defun concat (lst / str)
  414.        (if (or (null lst)
  415.                (/= (type lst) 'LIST)) nil
  416.            (apply 'strcat lst)))
  417.  
  418. ;;;  Compresser v. 2.0
  419.  
  420. (defun explode_plines ()
  421.        (setvar "cmdecho" 0)
  422.        (setq plns (ssget "x" '((0 . "POLYLINE"))))
  423.        (if plns (progn (setq lngth (sslength plns)
  424.                              i 0)
  425.                        (terpri)
  426.                        (repeat lngth
  427.                                (setq pln (ssname plns i))
  428.                                (princ (strcat "\rExploding polyline "
  429.                                       (itoa (1+ i))
  430.                                       " of " (itoa lngth)))
  431.                                (command "explode" pln)
  432.                                (setq i (1+ i)))))
  433.        (princ))
  434.  
  435. (defun explode_1segment_plines ()
  436.        (setvar "cmdecho" 0)
  437.        (setq plns (ssget "x" '((0 . "POLYLINE"))))
  438.        (if plns (progn (setq lngth (sslength plns)
  439.                              i 0)
  440.                        (terpri)
  441.                        (repeat lngth
  442.                                (setq pln (ssname plns i))
  443.                                (princ (strcat "\rAnalyzing polyline "
  444.                                       (itoa (1+ i))
  445.                                       " of " (itoa lngth)))
  446.                                (setq num_verts (length (collect_vertices pln)))
  447.                                (if (< num_verts 3)
  448.                                    (progn (princ "\rExploding")
  449.                                           (command "explode" pln)))
  450.                                (setq i (1+ i)))))
  451.        (princ))
  452.  
  453. (defun compress_by_layer ()
  454.        (foreach lyr (mapcar 'car lyrs)
  455.                 (if (and (setq lines (ssget "x" (list (cons 0 "LINE")
  456.                                                (cons 8 lyr)))
  457.                                *lines* lines)
  458.                           (setq lines_l (sslength lines)))
  459.                     (compress_lines lyr))))
  460.  
  461. (defun compress_lines (layr)
  462.        (freeze_all_but layr)
  463.        (princ (strcat "\nCompiling lines on layer " layr "\n"))
  464.        (while (and (setq lines (ssget "x" (list (cons 0 "LINE") (cons 8 layr))))
  465.                    (> (setq ssl (sslength lines)) 0)
  466.                    (setq line1 (ssname lines 0)))
  467.                (princ "\rProcessing ")
  468.                (princ line1)
  469.                (command "pedit" line1 "y" "j" lines "" "x")))
  470.  
  471. (defun collect_vertices (ent / *ent* pt pts)
  472.        (if (= (cdr (assoc 0 (setq *ent* (entget ent)))) "POLYLINE")
  473.            (progn (setq ent (entnext ent))
  474.                   (while (setq *ent* (entget ent) pt (cdr (assoc 10 *ent*)))
  475.                          (setq pts (cons pt pts)
  476.                                ent (entnext ent))))
  477.            (princ "\ncollect_vertices: not a POLYLINE."))
  478.        (if pts pts))
  479.  
  480. (defun userstr (dflt prmpt / var) ;;DFLT and PRMPT are strings
  481.        (setq var (getstring (if (and dflt (/= dflt ""))
  482.                                 (strcat prmpt " <" dflt ">: ")
  483.                                 (strcat prmpt ": "))))
  484.        (cond ((/= var "") var)
  485.              ((and dflt (= var "")) dflt)
  486.              (T (*error* "no default given"))))
  487.  
  488. (princ "\nC:ECONO loaded - type ECONO to use.")
  489. (princ)
  490.  
  491.