home *** CD-ROM | disk | FTP | other *** search
/ Share Gallery 1 / share_gal_1.zip / share_gal_1 / GR / GR505.ZIP / LSP.EXE / RDIM.LSP < prev    next >
Text File  |  1987-07-12  |  13KB  |  339 lines
  1. ;   Dimentioning routine:                 Mark Vodhanel
  2. ;   Acad 2.5x                            CIS (72456,463)
  3. ;
  4. ;                                        2-01-87
  5. ;
  6. ;     This routine allows the user to set a reference point and other
  7. ; features that will be remembered until reset.  The dimentioning in this
  8. ; routine is of an abreviated type that will allow more information to
  9. ; be placed in the drawing when only one or two reference planes
  10. ; are needed.
  11. ;
  12. ;     When invoked, this program will check to see if the current text
  13. ; style is "DIMTXT", if it isn't "DIMTXT" will be created and made current.
  14. ; You will then be given a short list of defaults that you can either
  15. ; accept and procceed or stop and change.  These are:  the reference
  16. ; point, dimention axis rotation, and scaleing factor for the text &
  17. ; arrows.  The reference point should be the intersection of the two
  18. ; planes that you want to use as a reference, or, if you are only using
  19. ; one plane, it can be any point along this plane.  The dimention axis
  20. ; rotation can be a reference plane or any line parallel to it.  The
  21. ; Scaling factor, as is, is about right for full scale drawings, but
  22. ; can be changed to accomodate other scales ie: .5 scaling factor
  23. ; for 2/1 scale drawings.
  24. ;
  25. ;     You will next be asked for the origin point for the extension
  26. ; line.  Pick the desired point and drag the dimention line to where
  27. ; you want it, if you are using two dimention planes you automatically
  28. ; refer to one or the other by the angle the extension line is dragged.
  29. ;
  30. ;    Next come the dimention control defaults which may be changed
  31. ; on the fly and are more or less self explanitory.  If you want
  32. ; a space between the preceding text and the dimention just type a
  33. ; space as the first character, and, similarly, a space may be added
  34. ; between the dimention and the appending text by typing a space
  35. ; as the last character in answering the appending text prompt.
  36. ;
  37. ;    All the text and arrows and extension lines are put on layer
  38. ; "DIM" which is created if not already there.  The text color is
  39. ; changed to color 3 and the extemsion lines & arrows are changed to
  40. ; color 1 as it is setup now.  All of this is easily changed - see
  41. ; the default functions below.
  42. ;
  43. ;                   Comments are welcomed.
  44. ;
  45. ;
  46. ;
  47. ;       <RDIMR> takes it out of memory
  48. ;       <RDIM>  invokes it
  49. ;
  50. ;
  51. ;
  52. ;
  53. ;
  54. (defun c:RDIMR ()
  55.         (setq atomlist (member 'c:clean atomlist))
  56.         'Done
  57. )
  58. ;
  59. ;
  60. (defun set-defaults ()
  61.    (if (boundp 'default-flag) () (progn
  62.       (setq
  63.          scale       1             ; Scale factor
  64.          style-name "DIMTXT"       ; Text style name
  65.          base       (list 0.0 0.0) ; Reference point
  66.          precision   3             ; Precision
  67.          fraction   "N"            ; N or denominator of fraction - string
  68.          rotang      0.0           ; Rotation angle
  69.          d-layer    "DIM"          ; Layer to put dimentions on
  70.          txt-clr    "3"            ; Color for dimentioning text
  71.          ext-clr    "1"            ; Color for arrow & extsn lines
  72.          pr-text    " "            ; Preceding text
  73.          ap-text    " "            ; Appending text
  74.          default-flag "set")))
  75. )
  76. ;
  77. ;
  78. (defun dim-scale()
  79.    (if (boundp 'scale-flag) () (progn
  80.       (setq
  81.          arrw-w      (* 0.060 scale)   ; Arrow width
  82.          arrw-h      (* 0.120 scale)   ; Arrow hieght
  83.          arrw-l      (* 0.300 scale)   ; Arrow length
  84.          txt-w       (* 0.125 scale)   ; Text width
  85.          txt-h       (* 0.125 scale)   ; Text height
  86.          ext-gap     (* 0.125 scale)   ; Gap between extension line & origin
  87.          endext-pos  (* 0.300 scale)   ; Dist from arrw to end extsn line
  88.          text-offset (* 0.050 scale)   ; Distance above the extension line
  89.          scale-flag  "set")))
  90. )
  91. ;
  92. ;
  93. ;
  94. ;
  95. (defun set-style (/ r1 r2 r3 r4 r5 r6 r7 r8)
  96.         (setq
  97.           r1 style-name            ; Style name  - set above
  98.           r2 "MONOTXT"             ; Style
  99.           r3 (rtos txt-h)          ; Text height - set above
  100.           r4 "1.0"                 ; Width factor
  101.           r5 "0.0"                 ; Obliquing angle
  102.           r6 "N"                   ; Backwards?
  103.           r7 "N")                  ; Upside down?
  104.         (command "style" r1 r2 r3 r4 r5 r6 r7 r8)
  105. )
  106. ;
  107. ;
  108. (defun c:RDIM (/ basex basey rotangstr scalestr ans)
  109.    (save-vars)
  110.    (setvar "CMDECHO" 0)
  111.    (setvar "EXPERT" 2)
  112.    (setvar "BLIPMODE" 0)
  113.    (set-defaults)
  114.    (dim-scale)
  115.    (if (= style-name (getvar "TEXTSTYLE")) () (set-style))
  116.    (setq basex (rtos (car base) 2 precision)
  117.          basey (rtos (last base) 2 precision)
  118.          rotangstr (angtos rotang 0 precision)
  119.          scalstr (rtos scale 2 precision))
  120.    (princ (strcat "\nReference point:  " basex "," basey))
  121.    (princ (strcat "\nRotation  angle:  " rotangstr))
  122.    (princ (strcat "\nDimention scale:  " scalstr))
  123.    (princ (strcat "\nAccept <Y>:"))
  124.    (setq ans (strcase (substr (getstring) 1 1)))
  125.    (if (= ans "N") (progn
  126.       (princ (strcat "\nReference point  <" basex "," basey ">: "))
  127.       (setq ans (getpoint))
  128.       (if (null ans) () (setq base ans))
  129.       (setq rotang (picang))
  130.       (princ (strcat "\nDimention scale  <" scalstr ">: "))
  131.       (setq ans (getreal))
  132.       (if (null ans) () (progn
  133.                         (setq scale ans)
  134.                         (setq scale-flag nil)
  135.                         (dim-scale)
  136.                         (set-style)))))
  137.    (setq done "N")
  138.    (while (= done "N")
  139.       (dimention))
  140.    (rest-vars)
  141.    'Done
  142. )
  143. ;
  144. ;
  145. ; Subfunctions:
  146. ;
  147. ;
  148. ;
  149. (defun picang (/ blipmdsv entlst entnam type pt1 pt2)
  150.     (setvar "SNAPMODE" 0)
  151.     (setq type nil)
  152.     (while (/= type "LINE")       ; continue until valid entity selected
  153.        (setq entnam (entsel "\nSelect a line to align the dimention axis:"))
  154.        (if (null entnam) (setq type nil) (progn
  155.           (setq entlst (entget (car entnam)))
  156.           (setq type (cdr (assoc 0 entlst)))
  157.           (if (/= type "LINE") (setq type nil) (progn  ; only lines allowed
  158.              (setq pt1 (cdr (assoc 10 entlst)))
  159.              (setq pt2 (cdr (assoc 11 entlst)))
  160.              (angle pt1 pt2))))))
  161. )
  162. ;
  163. ;
  164. (defun dimention (/ distsrtg)
  165.    (setq point (getpoint "\nExtension line origin? "))
  166.    (if (null point) (setq done "Y") (progn ; Just exit if no point is selected
  167.        (drag-extension)
  168.        (get-distance)               ; Set global variables: dist ref-ang
  169.        (insert-arrow)
  170.        (get-dist-strg)
  171.        (insert-text))
  172.   )
  173. )
  174. ;
  175. ;
  176. (defun drag-extension ()
  177.     (setvar "BLIPMODE" 0)
  178.     (setvar "ORTHOMODE" 1)
  179.     (setvar "SNAPANG" rotang)
  180.     (setvar "SNAPBASE" base)
  181.     (setvar "SNAPMODE" 0)
  182.     (if (= d-layer (getvar "CLAYER")) () (progn
  183.         (command "layer" "N" d-layer "")
  184.         (command "layer" "S" d-layer "")))
  185.     (setq arrw-pnt nil)
  186.     (while (null arrw-pnt)
  187.        (setq arrw-pnt (getpoint point "\nDrag extension line:  ")))
  188.     (setq ext-ang (angle point arrw-pnt))
  189.     (setq ext-base (polar point ext-ang ext-gap))
  190.     (setq ext-end (polar arrw-pnt ext-ang endext-pos))
  191. )
  192. ;
  193. ;
  194. (defun get-distance (/ ref)
  195.     (setq base-ref (polar base ext-ang 100))
  196.     (setq point-ref (polar point (+ ext-ang (/ pi 2)) 100))
  197.     (setq ref (inters base base-ref point point-ref nil))
  198.     (setq dist (distance ref point))      ; Distance from origin to ref axis
  199.     (setq ref-ang (angle ref point))      ; Used to place text and arrow
  200. )
  201. ;
  202. ;
  203. (defun insert-arrow (/ p1 p2 p3 ref1 ref2)
  204.      (if (> dist 0.000005) () (progn
  205.         (setq ref nill)
  206.         (while (null ref1)
  207.            (princ "\nThis extension line is on the reference plane.")
  208.            (princ "\nPick the side that you want the text on:  ")
  209.            (setq ref2 (polar ext-end (+ ext-ang pi) arrow-pos))
  210.            (setvar "ORTHOMODE" 1)
  211.            (setvar "SNAPMODE" 0)
  212.            (setq ref1 (getpoint ref2)))
  213.         (setq ref-ang (angle ref2 ref1))
  214.         (setq dist 0)))
  215.      (setq
  216.         p2 (polar arrw-pnt (+ ref-ang pi) arrw-h)
  217.         p3 (polar arrw-pnt (+ ref-ang pi) arrw-l))
  218.      (command "pline" arrw-pnt "w" 0 arrw-w p2 "w" 0 0 p3 "")
  219.      (command "change" "l" "" "p" "c" ext-clr "")
  220. )
  221. ;
  222. ;
  223. (defun get-dist-strg (/ ans ref)
  224.      (distrng-calc)
  225.      (princ (strcat "\nDecimal places:    [" (itoa precision) "]"))
  226.      (princ (strcat "\nRound to fraction: [" fraction "]"))
  227.      (princ (strcat "\nPreceding text:    [" pr-text "]"))
  228.      (princ (strcat "\nDimention:         [" distrng "]"))
  229.      (princ (strcat "\nAppending text:    [" ap-text "]"))
  230.      (princ (strcat "\nAccept? <Y>:  "))
  231.      (setq ans (strcase (substr (getstring) 1 1)))
  232.      (if (= ans "N") (progn
  233.         (setq ans nil)
  234.         (while (null ans)
  235.            (setq precstrng (itoa precision))
  236.            (princ (strcat "\nDecimal places       <" precstrng ">:"))
  237.            (setq ans (getint))
  238.            (cond
  239.               ((null ans) (setq ans "set"))
  240.               ((<= ans 6) (if (>= ans 0) (setq precision ans)
  241.                                          (setq ans nil)))
  242.               (t (setq ans nil))))
  243.         (setq ans nil)
  244.         (while (null ans)
  245.            (princ (strcat "\nDenominator, or N    <" fraction ">:"))
  246.            (setq ans (getstring))
  247.            (cond
  248.               ((= ans "") (setq ans "set"))
  249.               ((= (strcase ans) "N") (setq fraction "N"))
  250.               ((<= (atoi ans) 64) (if (> (atoi ans) 0) (setq fraction ans)
  251.                                          (setq ans nil)))
  252.               (t (setq ans nil))))
  253.         (princ (strcat "\nPreceding text, or N <" pr-text ">:"))
  254.         (setq ans (getstring T))
  255.         (cond
  256.            ((= (strcase ans) "N") (setq pr-text " "))
  257.            ((/= ans "") (setq pr-text ans)))
  258.         (distrng-calc)
  259.         (princ (strcat "\nDimention            <" distrng ">:"))
  260.         (setq ans (getstring))
  261.         (if (= ans "") () (setq distrng ans))
  262.         (princ (strcat "\nAppending text, or N <" ap-text ">:"))
  263.         (setq ans (getstring T))
  264.         (cond
  265.            ((= (strcase ans) "N") (setq ap-text " "))
  266.            ((/= ans "") (setq ap-text ans)))))
  267. )
  268. ;
  269. ;
  270. (defun distrng-calc (/ ref)
  271.      (if (= fraction "N") (setq distrng (rtos dist 2 precision)) (progn
  272.               (setq ref (/ 1.00 (atoi fraction)))
  273.               (setq distrng (rtos (round dist ref) 2 precision))))
  274. )
  275. ;
  276. ;
  277. ; Round.lsp by Duff Kurland
  278. (defun round (num frac / over half)
  279.    (setq half (/ frac 2.0))
  280.    (setq over (rem num frac))    ; Get remainder
  281.    (if (>= over half)
  282.        (+ num frac (- over))     ; Round up
  283.        (- num over)              ; Round down
  284.    )
  285. )
  286. ;
  287. ;
  288. (defun insert-text (/ add-fctr ext-end-mod ext-flag)
  289.      (setq txtpnt (polar arrw-pnt ref-ang text-offset))
  290.      (setq txtpnt-flp (polar arrw-pnt ref-ang (+ text-offset txt-h)))
  291.      (setq txtang (- ref-ang (/ pi 2)))
  292.      (cond
  293.          ((>= txtang (* pi 2)) (setq txtang (- txtang (* pi 2))))
  294.          ((< txtang 0) (setq txtang (+ txtang (* pi 2)))))
  295.      (if (>= (+ txtang 0.05) (/ pi 2))
  296.          (if (< (+ txtang 0.05) (/ (* pi 3) 2))
  297.              (progn (setq txtang (+ txtang pi))
  298.              (setq txtpnt txtpnt-flp))))
  299.      (setq txtang (angtos txtang 0 precision))
  300.      (setq ext-flag nil)
  301.      (if (= pr-text " ") () (progn
  302.          (setq distrng (strcat pr-text distrng))
  303.          (setq ext-flag "set")))
  304.      (if (= ap-text " ") () (progn
  305.          (setq distrng (strcat  distrng ap-text))
  306.          (setq ext-flag "set")))
  307.      (command "text" "C" txtpnt txtang distrng)
  308.      (command "change" "L" "" "P" "C" txt-clr "")
  309.      (setq add-fctr (+ (strlen pr-text) (strlen ap-text)))
  310.      (setq ext-end-mod (/ (* txt-w add-fctr) 2.0))
  311.      (if (= ext-flag "set")
  312.          (setq ext-end (polar ext-end (angle ext-base ext-end) ext-end-mod)))
  313.     (command "line" ext-base ext-end "")
  314.     (command "change" "l" "" "p" "c" ext-clr "")
  315. )
  316. ;
  317. ;
  318. (defun save-vars ()
  319.     (setq
  320.        cmdecho-sv    (getvar "CMDECHO")
  321.        expert-sv     (getvar "EXPERT")
  322.        blipmode-sv   (getvar "BLIPMODE")
  323.        snapmode-sv   (getvar "SNAPMODE")
  324.        snapang-sv    (getvar "SNAPANG")
  325.        snapbase-sv   (getvar "SNAPBASE")
  326.        orthomode-sv  (getvar "ORTHOMODE")
  327.     ))
  328. ;
  329. ;
  330. (defun rest-vars ()
  331.     (setvar "CMDECHO" cmdecho-sv)
  332.     (setvar "EXPERT" expert-sv)
  333.     (setvar "BLIPMODE" blipmode-sv)
  334.     (setvar "SNAPMODE" snapmode-sv)
  335.     (setvar "SNAPANG" snapang-sv)
  336.     (setvar "SNAPBASE" snapbase-sv)
  337.     (setvar "ORTHOMODE" orthomode-sv)
  338. )
  339.