home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / autocad / dtl.arc / DTL.LSP < prev   
Lisp/Scheme  |  1988-07-25  |  7KB  |  173 lines
  1. ;=======================================================================
  2. ; Allegro TABLET TOOLS LISP file
  3. ; DTL.LSP
  4. ;
  5. ; Extracts a section of a drawing for a detail.
  6. ; Lines, Arcs, & Circles are trimmed to the box boundary.
  7. ; P-LINES and equal scale blocks are exploded one level in the detail
  8. ; before trimming.
  9. ;
  10. ; (c) 1988 Robert McNeel & Assoc., 1310 Ward St., Seattle, WA, 98109
  11. ; This routine is submitted for private non-resale use by end users.
  12. ;=======================================================================
  13. (princ "\nInitial load .. please wait\n")
  14. ;=======================================================================
  15. (defun val (x e) (cdr (assoc x e)))
  16. (defun enttype (e) (cdr (assoc 0 e)))
  17. (defun entname (e) (cdr (assoc -1 e)))
  18. (setq >90 (/ pi 2) >270 (* 3 (/ pi 2)))
  19. ;=======================================================================
  20. ; Find the 'endpoints ' of the LINES, ARCS, & CIRCLES in ss that are
  21. ;   outside a rectangle described by the opposite corners pll and pur.
  22. ;   and submits them to the command function.
  23. ;-----------------------------------------------------------------------
  24. (defun osends (ss pll pur / z eps)
  25.   (ends ss)     ;this puts the 'endpoints' in a list, eps
  26.   (foreach z eps    ;this checks if they are outside the rectangle
  27.     (if (or (< (caadr z) (car pll))
  28.         (< (cadadr z) (cadr pll))
  29.         (> (caadr z) (car pur))
  30.         (> (cadadr z) (cadr pur))
  31.       )
  32.       (command z)
  33.     )
  34.   )
  35. )
  36. ;-----------------------------------------------------------------------
  37. ; Finds the 'endpoints' of LINES, ARCS, & CIRCLES in ss.
  38. ; 'Endpoints' are:
  39. ;   LINES:    endpoints
  40. ;   ARCS:   endpoints and quadrant points
  41. ;   CIRCLES:  quadrant points
  42. ; The endpoint lists are consed into the list eps (global).
  43. ;-----------------------------------------------------------------------
  44. (defun ends (ss / i ent cen)
  45.   (setq len (sslength ss) i 0)  ;get number of entities
  46.   (while (< i len)        ;loop thru them
  47.     (setq ent (entget (ssname ss i))) ;get assoc list
  48.     (cond       ;Check for LINES, ARCS, & CIRCLES and cons
  49.             ; the appropriate points into eps.
  50.             ;Other entity types are ignored.
  51.           ;LINES
  52.       ((= (enttype ent) "LINE")
  53.         (setq eps (cons (list (entname ent) (val 10 ent)) eps))
  54.         (setq eps (cons (list (entname ent) (val 11 ent)) eps)) )
  55.           ;ARCS
  56.       ((= (enttype ent) "ARC")
  57.         (setq cen (val 10 ent))
  58.         (setq eps (cons 
  59.           (list (entname ent) 
  60.             (polar cen 0 (val 40 ent))) eps))
  61.         (setq eps (cons 
  62.           (list (entname ent)
  63.             (polar cen >90 (val 40 ent))) eps))
  64.         (setq eps (cons 
  65.           (list (entname ent) 
  66.           (polar cen pi (val 40 ent))) eps))
  67.         (setq eps (cons 
  68.           (list (entname ent) 
  69.           (polar cen >270 (val 40 ent))) eps))
  70.         (setq eps (cons 
  71.           (list (entname ent) 
  72.             (polar cen (val 50 ent) (val 40 ent))) eps))
  73.         (setq eps (cons 
  74.           (list (entname ent) 
  75.             (polar cen (val 51 ent) (val 40 ent))) eps))
  76.         (setq eps (cons 
  77.           (list (entname ent) 
  78.           (osnap (polar cen (val 51 ent) (val 40 ent)) "mid")) eps)) )
  79.         ;CIRCLES
  80.       ((= (enttype ent) "CIRCLE")
  81.         (setq cen (val 10 ent))
  82.         (setq eps (cons 
  83.           (list (entname ent) 
  84.           (polar cen 0 (val 40 ent))) eps))
  85.         (setq eps (cons 
  86.           (list (entname ent)
  87.           (polar cen >90 (val 40 ent))) eps))
  88.         (setq eps (cons 
  89.           (list (entname ent) 
  90.           (polar cen pi (val 40 ent))) eps))
  91.         (setq eps (cons 
  92.           (list (entname ent) 
  93.           (polar cen >270 (val 40 ent))) eps)) )
  94.     )
  95.     (setq i (1+ i))   ;Next entity
  96.   )
  97. )
  98. ;-----------------------------------------------------------------------
  99. ;Explodes all p-lines in selection set s
  100. ;-----------------------------------------------------------------------
  101. (defun exp_pl (s / i len ent)
  102.   (setq i 0 len (sslength s))
  103.   (while (< i len)
  104.     (setq ent (entget (ssname s i)))
  105.     (cond
  106.       ((= (enttype ent) "POLYLINE")
  107.         (command "explode" (entname ent))
  108.       )
  109.       ((= (enttype ent) "INSERT")
  110.         (if (= (val 41 ent) (val 42 ent) (val 43 ent))  ;check equal scale
  111.           (command "explode" (entname ent))
  112.         )
  113.       )
  114.     )
  115.     (setq i (+ 1 i))
  116.   )
  117. )
  118. ;-----------------------------------------------------------------------
  119. ;erases parts of exploded p-lines that are outside target area
  120. ;-----------------------------------------------------------------------
  121. (defun era_xtra (e)
  122.   (setq ssx (ssadd))
  123.   (while (setq e (entnext e))
  124.     (if (not (ssmemb e ss))
  125.       (ssadd e ssx)
  126.     )
  127.   )
  128.   (command "erase" ssx "") 
  129. )
  130. ;-----------------------------------------------------------------------
  131. ; Gets the geometry and calls routines to do the trimming.
  132. ;-----------------------------------------------------------------------
  133. (defun c:dtl (/ px py pxx pyy xs ss b ssx)
  134.   (setvar "cmdecho" 0)
  135.   (if (and
  136.       ;This defines a rectangle to be copied out to a detail
  137.     (setq px (getpoint "\nFirst corner: "))
  138.     (setq py (getcorner px "\nOther corner: "))
  139.       ;This is the position of the lower left corner of the detail
  140.     (setq pxx (getpoint px "\nNew first corner position: "))
  141.       ;This is a size adjust factor for scaling the detail
  142.     (setq xs (getreal "\nScale factor for detail: ")) )
  143.     (progn
  144.       ;copy out the stuff selected
  145.   (command "copy" "c" px py "" px pxx)
  146.   (command "pline" px (list (car px) (cadr py)) ;draw an outline of
  147.       py (list (car py) (cadr px)) "c")         ; the base area.
  148.           ;these are the new entities that may need trimming.
  149.   (setq ss (ssget "c" pxx (polar pxx (angle px py) (distance px py))))
  150.           ;first explode p-lines because if you trim them, you get too
  151.           ;many new entities to deal with.  (could do blocks to)
  152.   (setq last (entlast)) ;save end of database
  153.   (exp_pl ss) ;this explodes them
  154.     ;then get all the new parts into ss
  155.   (setq ss (ssget "c" pxx (polar pxx (angle px py) (distance px py))))
  156.     ;and erase ones that are clear outside rectangle
  157.   (era_xtra last)
  158.   (command "scale" ss "" pxx xs)    ;Scale the detail
  159.           ;new other corner point of detail
  160.   (setq pyy (polar pxx (angle px py) (* xs (distance px py))))
  161.   (command "pline" pxx (list (car pxx) (cadr pyy))  ;Box around the
  162.       pyy (list (car pyy) (cadr pxx)) "c")          ;detail
  163.   (command "trim" (setq b (entlast)) "")  ;Last P-line is cutting edge
  164.   (osends ss pxx pyy)   ;This finds the ends that are outside the box
  165.               ; and trims them.
  166.   (command "")    ;Terminate trim
  167.   (redraw b)
  168.     )
  169.   )
  170.   (setvar "cmdecho" 1)
  171.   (princ)
  172. )
  173.