home *** CD-ROM | disk | FTP | other *** search
/ Current Shareware 1994 January / SHAR194.ISO / cad_util / v8n8_cad.zip / SD.LSP < prev    next >
Lisp/Scheme  |  1993-07-23  |  6KB  |  212 lines
  1. (defun SD_ARROW (PT DA DA3)
  2.    (entmake
  3.      (list
  4.         '(0 . "SOLID")
  5.         (cons 10 PT)
  6.         (list 11 (- (car PT) DA3) (+ (cadr PT) DA) 0.0)
  7.         (list 12 (+ (car PT) DA3) (+ (cadr PT) DA) 0.0)
  8.         (list 13 (+ (car PT) DA3) (+ (cadr PT) DA) 0.0)
  9.      )
  10.    )
  11. )
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13. (defun SD_LINE (P1 P2)
  14.   (entmake
  15.     (list
  16.       '(0 . "LINE")
  17.       (cons 10 P1)
  18.       (cons 11 P2)
  19.     )
  20.   )
  21. )
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. (defun SD_TEXT (S PT JST / BX BY TENG ELFG FLG)
  24.    (setq BX (textbox (list (cons 1 S))) ;;text limits
  25.          BX (mapcar '- (cadr BX) (car BX)) ;;delta size
  26.          BY (/ (cadr BX) 2.0) ;;1/2 Y difference
  27.    )
  28.    (cond
  29.      ((= JST 1)  ;;left midpoint given
  30.        (setq TENG (list (car PT) (- (cadr PT) BY) 0.0)
  31.              ELFG (list 0.0 0.0 0.0)
  32.              FLG 0)
  33.      )
  34.      ((= JST -1)   ;;right midpoint given
  35.        (setq TENG (list (- (car PT) (car BX))
  36.                         (- (cadr PT) BY) 0.0)
  37.              ELFG (list (car PT)
  38.                         (- (cadr PT) BY) 0.0)
  39.              FLG 2)
  40.      )
  41.    )
  42.    (entmake
  43.      (list
  44.        '(0 . "TEXT")
  45.        (cons 10 TENG)
  46.        (cons 11 ELFG)
  47.        (cons 1 S)
  48.        (cons 40 TS)
  49.        '(50 . 0.0)
  50.        (cons 72 FLG)
  51.      )
  52.    )
  53. )
  54.  
  55. (defun SD_VARS ( / T1 T2)
  56.   (setq SD_PNT (entsel "\nLocate center line: "))
  57.   (if SD_PNT
  58.     (progn
  59.       (setq
  60.        SD_PNT (cdr (assoc 10 (entget (car SD_PNT))))
  61.        T1 (getdist (strcat "\nDimension text size <"
  62.                       (rtos (getvar "DIMTXT")) ">: "))
  63.        T2 (getdist (strcat "\nArrow size <"
  64.                       (rtos (getvar "DIMASZ")) ">: "))
  65.        T3 (getstring (strcat "\nDimension layer name <"
  66.                              (getvar "CLAYER") ">: "))
  67.       )
  68.       (if (null T1)
  69.          (setq T1 (getvar "DIMTXT"))
  70.          (setvar "DIMTXT" T1)
  71.       )
  72.       (if (null T2)
  73.          (setq T2 (getvar "DIMASZ"))
  74.          (setvar "DIMASZ" T2)
  75.       )
  76.       (if (= T3 "")
  77.          (setq T3 (getvar "CLAYER"))
  78.          (command "_LAYER" "_M" T3 "")
  79.       )
  80.       (setq TS T1
  81.             DA T2
  82.             DL T3
  83.             DA3 (/ DA 6.0) ;;arrow size 3::1
  84.       )
  85.     )
  86.     (prompt "\nFunction cancelled, no center line selected")
  87.   )
  88. )
  89.  
  90. (defun SD_LEADER ( / EXIT VECS)
  91.   (setq EXIT nil
  92.         P2 nil
  93.         VECS nil)
  94.   (while (null EXIT)
  95.      (setq P2 (grread 'T 4 1)) ;(id 3d_pnt)
  96.      (if VECS
  97.         (grvecs VECS))
  98.      (cond 
  99.        ((= (car P2) 5)
  100.           (setq P2 (cadr P2))
  101.           (grvecs 
  102.              (setq VECS
  103.                (list 257 P1 (list (car P1) (cadr P2) 0.0)
  104.                   257 (list (car P1) (cadr P2) 0.0) P2
  105.                 )
  106.              )
  107.           )
  108.        )
  109.        ((= (car P2) 3)
  110.           (setq P2 (cadr P2)
  111.                 EXIT 'T)
  112.        )
  113.        ((and (= (car P2) 2)
  114.              (= (cadr P2) 13)) ;;return request
  115.           (setq EXIT 'T)
  116.        )
  117.        ((and (= (car P2) 2)
  118.              (= (cadr P2) 27)) ;;ESC
  119.           (setq EXIT 'T
  120.                 P2 nil)
  121.        )
  122.      )
  123.   )   
  124.   P2 ;;returns P2 value.  NIL if no point selected
  125. )
  126.  
  127. (defun SD_TEXT_ED ()
  128.   (setq DD (* 2.0 (abs (- (cadr P1) (cadr SD_PNT)))))
  129.   (if (= (getvar "DIMTOL") 0)
  130.      (progn
  131.        (setq TMP 
  132.                (getstring 1 
  133.                      (strcat "\nNew dimension text <" (rtos DD) ">: "))
  134.        )
  135.        (if (= TMP "") (setq TMP (rtos DD)))
  136.      )
  137.      (progn
  138.        (setq TMP1
  139.                (getstring 1
  140.                  (strcat "\nNew upper text <" 
  141.                          (rtos (+ DD (getvar "DIMTP"))) ">: ")))
  142.        (if (= TMP1 "") (setq TMP1 (rtos (+ DD (getvar "DIMTP")))))
  143.        (setq TMP2
  144.                (getstring 1
  145.                  (strcat "\nNew lower text <" 
  146.                          (rtos (- DD (getvar "DIMTM"))) ">: ")))
  147.        (if (= TMP2 "") (setq TMP2 (rtos (- DD (getvar "DIMTM")))))
  148.      )
  149.   )
  150. )
  151.  
  152. (defun SD_TEXT_PUT ()
  153.   (if (> (car P2) (car P1)) 
  154.       (setq AA 0.0
  155.             JT 1)  ;; left justified
  156.       (setq AA PI
  157.             JT -1) ;; right justified
  158.   )
  159.   
  160.   (if (= (getvar "DIMTOL") 0)
  161.     (SD_TEXT TMP (polar P2 AA (/ TS 2)) JT) ;;single line of text
  162.     (progn ;;ELSE dimtol is active, two lines of text
  163.       (SD_TEXT TMP1 (list (+ (car P2) (* TS 0.5 JT))
  164.                           (+ (cadr P2) (* TS 0.75))
  165.                           0.0)
  166.                     JT)
  167.       (SD_TEXT TMP2 (list (+ (car P2) (* TS 0.5 JT))
  168.                           (- (cadr P2) (* TS 0.75))
  169.                           0.0)
  170.                     JT)
  171.     )
  172.   )
  173. )
  174.  
  175. (defun C:SD ( / DL DA DA3 TS P1 P2 P3 TMP TMP1 TMP2)
  176.   (prompt "\nSD:  SHAFT Dimensioning   Bill Kramer   CADENCE 8/93")
  177.   (if (SD_VARS) ;;sets SD variables up from user input
  178.     (progn
  179.       (command "_LAYER" "_S" DL "")
  180.       (while (setq P1 
  181.                  (getpoint "\nLocate point on radius to dimension: "))
  182.          (if (SD_LEADER)  ;;operator shows location of dimension text
  183.            (progn
  184.              (SD_TEXT_ED) ;;operator override of text value
  185.              (if (> (cadr P2) (cadr P1)) ;;above CL?
  186.                (progn
  187.                  (setq P3 (list (car P1) 
  188.                               (- (cadr P1) DD) 0.0)) ;; other side of CL
  189.                  (SD_ARROW P1 DA DA3)
  190.                  (SD_ARROW P3 (* -1 DA) DA3)
  191.                  (SD_LINE P3 (polar P3 (* 1.5 PI) (* 2 DA)))
  192.                )
  193.                (progn ;;below CL
  194.                  (setq P3 (list (car P1)
  195.                               (+ (cadr P1) DD) 0.0))
  196.                  (SD_ARROW P1 (* -1 DA) DA3)
  197.                  (SD_ARROW P3 DA DA3)
  198.                  (SD_LINE P3 (polar P3 (* 0.5 PI) (* 2 DA)))
  199.                )
  200.              )
  201.              (SD_LINE P1 (list (car P1) (cadr P2) 0.0))
  202.              (SD_LINE (list (car P1) (cadr P2) 0.0) P2)
  203.              (SD_TEXT_PUT)
  204.            )
  205.          )
  206.       )
  207.     )
  208.   )
  209.   (princ)
  210. )
  211.  
  212.