home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p024 / 5.img / R11SUPP.EXE / CL.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1990-07-30  |  4.3 KB  |  132 lines
  1. ;;; --------------------------------------------------------------------------;
  2. ;;; CL.LSP
  3. ;;;   Copyright (C) 1990 by Autodesk, Inc.
  4. ;;;  
  5. ;;;   Permission to use, copy, modify, and distribute this software and its
  6. ;;;   documentation for any purpose and without fee is hereby granted.  
  7. ;;;
  8. ;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. 
  9. ;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF 
  10. ;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
  11. ;;;
  12. ;;;   By Simon Jones    Autodesk Ltd , London      March 1987
  13. ;;;
  14. ;;; --------------------------------------------------------------------------;
  15. ;;; DESCRIPTION
  16. ;;;
  17. ;;;  This macro constructs a pair of center lines through the
  18. ;;;  center of a circle. The lines are put on a layer "CL".
  19. ;;;
  20. ;;; --------------------------------------------------------------------------;
  21.  
  22. (defun clerr (s) 
  23.   (if (/= s "Function cancelled")     ; If an error (such as CTRL-C) occurs
  24.     (princ (strcat "\nError: " s))    ; while this command is active...
  25.   ) 
  26.   (command "UCS" "P")                 ; Restore previous UCS
  27.   (setvar "BLIPMODE" sblip)           ; Restore saved modes
  28.   (setvar "GRIDMODE" sgrid)
  29.   (setvar "HIGHLIGHT" shl)
  30.   (setvar "UCSFOLLOW" sucsf)
  31.   (command "LAYER" "S" clay "") 
  32.   (command "undo" "e") 
  33.   (setvar "CMDECHO" scmde)
  34.   (setq *error* olderr)               ; Restore old *error* handler
  35.   (princ)                             
  36. ) 
  37.  
  38. ;;; --------------------------- Main Program ---------------------------------;
  39.  
  40. (defun C:CL (/ olderr clay sblip scmde sgrid shl sucsf e cen rad d ts xx) 
  41.   (setq olderr *error* 
  42.         *error* clerr)
  43.   (setq scmde (getvar "CMDECHO"))
  44.   (command "undo" "group") 
  45.   (setq clay (getvar "CLAYER"))
  46.   (setq sblip (getvar "BLIPMODE"))
  47.   (setq sgrid (getvar "GRIDMODE"))
  48.   (setq shl (getvar "HIGHLIGHT"))
  49.   (setq sucsf (getvar "UCSFOLLOW"))
  50.   (setvar "CMDECHO" 0)
  51.   (setvar "GRIDMODE" 0)
  52.   (setvar "UCSFOLLOW" 0)
  53.   (setq e nil 
  54.         xx "Yes")
  55.   (setq ts (tblsearch "LAYER" "CL"))
  56.   (if (null ts) 
  57.     (prompt "\nCreating new layer - CL. ") 
  58.     (progn
  59.       (if (= (logand 1 (cdr (assoc 70 ts))) 1) 
  60.         (progn
  61.           (prompt "\nLayer CL is frozen. ") 
  62.           (initget "Yes No") 
  63.           (setq xx (getkword "\nProceed? <N>: "))
  64.           (if (= xx "Yes") 
  65.             (command "LAYER" "T" "CL" "")
  66.           )
  67.         )
  68.       )
  69.     )
  70.   ) 
  71.   (if (= xx "Yes") 
  72.     (progn
  73.       (while (null e) 
  74.         (setq e (entsel "\nSelect arc or circle: "))
  75.         (if e 
  76.           (progn
  77.             (setq e (car e))
  78.             (if (and (/= 
  79.                          (cdr (assoc 0 (entget e))) "ARC") 
  80.                          (/= (cdr (assoc 0 (entget e))) "CIRCLE")
  81.                 ) 
  82.               (progn
  83.                 (prompt "\nEntity is a ") 
  84.                 (princ (cdr (assoc 0 (entget e)))) 
  85.                 (setq e nil)
  86.               )
  87.             )
  88.           )
  89.         )
  90.       ) 
  91.       (command "UCS" "e" e) 
  92.       (setq cen (trans (cdr (assoc 10 (entget e))) e 1))
  93.       (setq rad (cdr (assoc 40 (entget e))))
  94.       (prompt "\nRadius is ") 
  95.       (princ (rtos rad)) 
  96.       (initget 7 "Length") 
  97.       (setq d (getdist "\nLength/<Extension>: "))
  98.       (if (= d "Length") 
  99.         (progn
  100.           (initget 7) 
  101.           (setq d (getdist cen "\nLength: "))
  102.         ) 
  103.         (setq d (+ rad d))
  104.       ) 
  105.       (setvar "BLIPMODE" 0)
  106.       (setvar "HIGHLIGHT" 0)
  107.       (command "LAYER" "M" "CL" "") 
  108.       (command "LINE" (list (car cen) (- (cadr cen) d) (caddr cen)) 
  109.                (list (car cen) (+ (cadr cen) d) (caddr cen)) ""
  110.       ) 
  111.       (command "CHANGE" "l" "" "P" "LT" "CENTER" "") 
  112.       (command "LINE" (list (- (car cen) d) (cadr cen) (caddr cen)) 
  113.                (list (+ (car cen) d) (cadr cen) (caddr cen)) ""
  114.       ) 
  115.       (command "CHANGE" "l" "" "P" "LT" "CENTER" "") 
  116.       (command "LAYER" "S" clay "")
  117.     )
  118.   ) 
  119.   (command "UCS" "P")                 ; Restore previous UCS
  120.   (setvar "BLIPMODE" sblip)           ; Restore saved modes
  121.   (setvar "GRIDMODE" sgrid)
  122.   (setvar "HIGHLIGHT" shl)
  123.   (setvar "UCSFOLLOW" sucsf)
  124.   (command "undo" "e") 
  125.   (setvar "CMDECHO" scmde)
  126.   (setq *error* olderr)               ; Restore old *error* handler
  127.   (princ)
  128. ) 
  129.  
  130. ;;; --------------------------------------------------------------------------;
  131.  
  132.