home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / aplic / felixcad / fcaddata.z / CONE2D.LSP < prev    next >
Lisp/Scheme  |  1996-02-13  |  5KB  |  130 lines
  1. ;;; CONE2D.LSP
  2. ;;; =======================================================
  3. ;;; DrawUtilility TRAPEZOID.
  4. ;;; Provided by Felix CAT GmbH 1996 as FCAD Application Sample
  5. ;;; =======================================================
  6. ;;; DESCRIPTION:
  7. ;;; =======================================================
  8. ;;; SAMPLE FOR: 
  9. ;;;   getpoint, getangle, getdist, getreal, initget
  10. ;;;   entmake
  11. ;;; =======================================================
  12. ;;; CHANGES might be:
  13. ;;;### Enter Ratio not only as [1:n], but also as [n:1] !
  14. ;;;### Evaluate and Set Construction Line Layer !
  15. ;;; =======================================================
  16.  
  17. (defun C:KONUS() (C:TRAPEZOID)(princ)) ;;; ### GERMAN COMMAND
  18.  
  19. (defun C:TRAPEZOID ( / lang prt_list MAKE_LINE
  20.                                          ins_ang ang d1 d2 l e p1 p2 p3 p4 p5)
  21.   
  22.   (if (> (getvar "ACTDB") -1) (progn
  23.     ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  24.     (defun *ERROR* (msg)        
  25.         (setq *ERROR* nil)
  26.         (princ) 
  27.     ) 
  28.     ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  29.     (setq lang (getvar "LANGUAGE") )
  30.     ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  31.     (setq prt_list (cond
  32.        ((= lang 1) (list 
  33.           "Einfⁿgepunkt: "
  34.           "Einfⁿgewinkel <0>: "
  35.           "Durchmesser der ersten Seite: "
  36.           "LΣnge: "
  37.           "Verjⁿngung"
  38.           "Durchmesser der zweiten Seite: "
  39.           "Verjⁿngung"
  40.           "VerjⁿngungsverhΣltnis 1 : "
  41.           "Ungⁿltiges VerjⁿngungsverhΣltnis. \nDer zweite Durchmesser mu▀ gr÷▀er 1 sein."
  42.           "Achtung"
  43.        ))
  44.        (T (list
  45.           "Insertion point: "      ;;; 0
  46.           "Insertion angle <0>: "   ;;; 1
  47.           "Diameter of first side: "   ;;; 2
  48.           "Length: "   ;;; 3
  49.           "Ratio"   ;;; 4
  50.           "Diameter of second side: "   ;;; 5
  51.           "Ratio"   ;;; 6
  52.           "Ratio 1 : "   ;;; 7
  53.           "Invalid ratio. \nSecond diameter must be greater than 1."   ;;; 8
  54.           "Alert"    ;;; 9
  55.        ))
  56.     ))
  57.     (defun MAKE_LINE (par1 par2 par3 / el ln ll par1 par2 par3)
  58.        (setq ln (cons 8 (getvar "CLAYER")))
  59.        (setq ll (cons 8 "CLINE"))              ;;; Construction Line Layer !
  60.        (setq el (list
  61.           (cons 0 "LINE") ln (cons 10 par1) (cons 11 par2)     ;;; ll
  62.        ))
  63.        (entmake el)
  64.     )
  65.     (initget 1)
  66.     (setq e (getpoint (nth 0 prt_list)))  ;;;@Insertion point: 
  67.     (setq ins_ang (getangle e (nth 1 prt_list)))  ;;;@Insertion angle <0>: 
  68.     (if (not ins_ang)(setq ins_ang 0))
  69.     (initget 1)
  70.     (setq d1 (getdist (nth 2 prt_list)))  ;;;@Diameter of first side: 
  71.     (initget 1)
  72.     (setq l (getdist e (nth 3 prt_list)))  ;;;@Length: 
  73.     (setq f1 T)
  74.     (initget 256 (nth 4 prt_list))  ;;;@Ratio
  75.     (setq d2 (getdist (nth 5 prt_list)))  ;;;@Diameter of second side: 
  76.     (if (= d2 (nth 4 prt_list)) (setq d2 nil))  ;;;@Ratio
  77.     (if (not d2)
  78.      (progn
  79.       (while f1
  80.         (initget (+ 1 2))
  81.         (setq d2 (getreal (nth 7 prt_list)))   ;;;@Ratio 1 : 
  82.         (setq d2 (- d1 (* (/ 1.0 d2) l)))
  83.         (if (minusp d2)
  84.             (alert 
  85.                 (nth 8 prt_list)   ;;;@Invalid ratio. \nSecond diameter must be greater than 1.
  86.                 (nth 9 prt_list)   ;;;@Alert
  87.                 "EXCLAMATION"
  88.              )
  89.              (setq f1 nil)
  90.         )
  91.       )
  92.      )
  93.     )
  94.     (setq ang (+ ins_ang (/ pi 2.00)))
  95.     (setq p4 (polar e ins_ang  l))
  96.     (setq p2 (polar e ang (/ d1 2.00)))
  97.     (setq p3 (polar p4 ang (/ d2 2.00)))
  98.     (setq p1 (polar p2 (+ ang pi) d1))
  99.     (setq p5 (polar p3 (+ ang pi) d2))
  100.     (MAKE_LINE p1 p2 nil)
  101.     (MAKE_LINE p2 p3 nil)
  102.     (MAKE_LINE p3 p5 nil)
  103.     (MAKE_LINE p5 p1 nil)
  104.     ;;; = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
  105.     ; ### Draw Center Line: Function MEC_CENTERLINE may be defined
  106.     ; ### in Mechanical application to draw center line !
  107.     (if MEC_CENTERLINE (progn
  108.           (setq d1 (if $center2 $center2 (* (+ d1 d2) 0.125) ) )
  109.           (MEC_CENTERLINE (polar e (+ ins_ang pi) d1) (polar e ins_ang (+ l d1)) nil nil)
  110.     ))
  111.     ;;; = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
  112.     (setq *ERROR* nil)
  113.     (princ)
  114.   ))
  115. )
  116. ;;; =======================================================
  117. (if (= (getvar "LANGUAGE") 1)
  118.     (progn 
  119.        (princ "Befehl KONUS geladen.") 
  120.        (setfunhelp "C:KONUS" "Konus" "fcad")
  121.     )
  122.     (progn 
  123.        (princ "Command TRAPEZOID loaded.") 
  124.        (setfunhelp "C:TRAPEZOID" "Trapezoid" "fcad")
  125.     )
  126. )
  127. (terpri)
  128. (princ)
  129.  
  130.