home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / acad / autolisp / door / door.lsp
Encoding:
Text File  |  1989-09-24  |  8.2 KB  |  167 lines
  1. ;;; -*-  Mode: LISP -*- Syntax: AutoLISP (C) Benjamin Olasov 1988
  2. ;;;      Two pick door programs
  3.  
  4. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5. ;;; File: DOOR.LSP Copyright (C) Benjamin Olasov 1988 All Rights Reserved   ;;;
  6. ;;; Inquiries:                                                              ;;;
  7. ;;;                                                                         ;;;
  8. ;;;     Benjamin Olasov                                                     ;;;
  9. ;;;     Graphic Systems, Inc.:                                              ;;;
  10. ;;;                                                                         ;;;
  11. ;;;                    New York, NY:   PH (212) 725-4617                    ;;;
  12. ;;;                    Cambridge, MA:  PH (617) 492-1148                    ;;;
  13. ;;;                    MCI-Mail:       GSI-NY   344-4003                    ;;;
  14. ;;;                    Arpanet:        olasov@cs.columbia.edu               ;;;
  15. ;;;                                                                         ;;;
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17.  
  18. ;; This program is provided 'as is' without warranty of any kind, either 
  19. ;; expressed or implied, including, but not limited to the implied warranties of
  20. ;; merchantability and fitness for a particular purpose.  The entire risk as to
  21. ;; the quality and performance of the program is with the user.  Should the 
  22. ;; program prove defective, the user assumes the entire cost of all necessary 
  23. ;; servicing, repair or correction. 
  24. ;; AutoLisp and AutoCad are registered trademarks of AutoDesk, Inc.
  25.  
  26.  
  27. (gc)
  28. (vmon)
  29. (princ "\nPlease wait- loading.")
  30.  
  31. (DEFUN C:DOOR (/ HP1 HP2 DWIDTH SP1 SP2 C-LAY BOX LINE1 LINE2)
  32.        (SETQ OS (GETVAR "OSMODE")
  33.              CMD (GETVAR "CMDECHO")
  34.              COORDS  (GETVAR "COORDS")
  35.              PICK (GETVAR "PICKBOX"))
  36.        (SETVAR "CMDECHO" 0)
  37.        (SETVAR "COORDS" 2)
  38.        (SETVAR "OSMODE" 256)
  39.        (SETQ HP1 (GETPOINT "\nHinge pt: ")
  40.              HP1 (OSNAP HP1 "NEAR")
  41.              SP1 (GETPOINT HP1 "\nSwing pt: ")
  42.              SP1 (OSNAP SP1 "NEAR")
  43.              DWIDTH (DISTANCE HP1 SP1)
  44.              C-LAY (GETVAR "CLAYER")
  45.              BOX (SSGET "C" (LIST (- (CAR HP1) 12.0) (- (CADR HP1) 12.0))
  46.                             (LIST (+ (CAR HP1) 12.0) (+ (CADR HP1) 12.0))))
  47.        (IF (AND BOX (SETQ LINE1 (ENTGET (SSNAME (SSGET HP1) 0))))
  48.            (PROGN (SSDEL (CDR (ASSOC -1 LINE1)) BOX) ;; remove first line from box
  49.                   (FOREACH ENT (SS2ELIST BOX)
  50.                            (IF (OR (/= (CDR (ASSOC 8 ENT))
  51.                                        (CDR (ASSOC 8 LINE1)))
  52.                                    (/= (CDR (ASSOC 0 ENT)) "LINE")
  53.                                    (NOT (PARALLEL ENT LINE1)))
  54.                                (SSDEL (CDR (ASSOC -1 ENT)) BOX)))
  55.        (SETVAR "OSMODE" 0)
  56.        (IF (> (SSLENGTH BOX) 0) ;; look in the box
  57.            (PROGN (SETQ LINE2 (ENTGET (SSNAME BOX 0))
  58.                         HP2 (INTERS (CDR (ASSOC 10 LINE2))
  59.                                     (CDR (ASSOC 11 LINE2))
  60.                                     HP1
  61.                                     (POLAR HP1 (IF (> PI (ANGLE HP1 SP1))
  62.                                                    (- (ANGLE HP1 SP1) (/ PI 2.0))
  63.                                                    (+ (ANGLE HP1 SP1) (/ PI 2.0)))
  64.                                            (DISTANCE HP1 SP1)) nil))
  65.                   (COMMAND "LAYER" "S" (CDR (ASSOC 8 LINE1)) "")
  66.                   (SETQ SP2 (POLAR HP2 (ANGLE HP1 SP1) DWIDTH)
  67.                         P5 (POLAR HP1 (ANGLE HP2 HP1) DWIDTH))
  68.                   (COMMAND "BREAK" HP1 SP1)
  69.                   (COMMAND "BREAK" HP2 SP2)
  70.                   (COMMAND "LINE" HP1 HP2 "")
  71.                   (COMMAND "LINE" SP1 SP2 "")
  72.                   (COMMAND "LAYER" "M" "DOOR" "C" "5" "" "")
  73.                   (COMMAND "LINE" HP1 P5 "")
  74.                   (COMMAND "ARC" SP1 "E" P5 "D" (ATOF (ANGTOS (ANGLE HP2 HP1) 0 4)))
  75.                   (SETVAR "CMDECHO" CMD)
  76.                   (SETVAR "OSMODE" OS)
  77.                   (SETVAR "PICKBOX" PICK)
  78.                   (COMMAND "LAYER" "S" C-LAY "")))))
  79.     (PRINC))
  80.  
  81. (princ ".")
  82.  
  83. (DEFUN C:DDOOR (/ HP1 HP2 DWIDTH HHP1 HHP2 C-LAY BOX LINE1 LINE2)
  84.        (SETQ OS (GETVAR "OSMODE")
  85.              CMD (GETVAR "CMDECHO")
  86.              COORDS  (GETVAR "COORDS")
  87.              PICK (GETVAR "PICKBOX"))
  88.        (SETVAR "CMDECHO" 0)
  89.        (SETVAR "COORDS" 2)
  90.        (SETVAR "OSMODE" 256)
  91.        (SETQ HP1 (GETPOINT "\nHinge pt: ")
  92.              HP1 (OSNAP HP1 "NEAR")
  93.              HHP1 (GETPOINT HP1 "\nOther hinge pt: ")
  94.              HHP1 (OSNAP HHP1 "NEAR")
  95.              DWIDTH (DISTANCE HP1 HHP1)
  96.              HFWIDTH (/ DWIDTH 2.0)
  97.              SP (POLAR HP1 (ANGLE HP1 HHP1) HFWIDTH)
  98.              C-LAY (GETVAR "CLAYER")
  99.              BOX (SSGET "C" (LIST (- (CAR HP1) 12.0) (- (CADR HP1) 12.0))
  100.                             (LIST (+ (CAR HP1) 12.0) (+ (CADR HP1) 12.0))))
  101.        (IF (AND BOX (SETQ LINE1 (ENTGET (SSNAME (SSGET HP1) 0))))
  102.            (PROGN (SSDEL (CDR (ASSOC -1 LINE1)) BOX) ;; remove first line from box
  103.                   (FOREACH ENT (SS2ELIST BOX)
  104.                            (IF (OR (/= (CDR (ASSOC 8 ENT))
  105.                                        (CDR (ASSOC 8 LINE1)))
  106.                                    (/= (CDR (ASSOC 0 ENT)) "LINE")
  107.                                    (NOT (PARALLEL ENT LINE1)))
  108.                                (SSDEL (CDR (ASSOC -1 ENT)) BOX)))
  109.        (SETVAR "OSMODE" 0)
  110.        (SETVAR "PICKBOX" 1)
  111.        (IF (> (SSLENGTH BOX) 0) ;; look in the box
  112.            (PROGN (SETQ LINE2 (ENTGET (SSNAME BOX 0))
  113.                         HP2 (INTERS (CDR (ASSOC 10 LINE2))
  114.                                     (CDR (ASSOC 11 LINE2))
  115.                                     HP1
  116.                                     (POLAR HP1 (IF (> PI (ANGLE HP1 HHP1))
  117.                                                    (- (ANGLE HP1 HHP1) (/ PI 2.0))
  118.                                                    (+ (ANGLE HP1 HHP1) (/ PI 2.0)))
  119.                                            (DISTANCE HP1 HHP1)) nil))
  120.                   (COMMAND "LAYER" "S" (CDR (ASSOC 8 LINE1)) "")
  121.                   (SETQ HHP2 (POLAR HP2 (ANGLE HP1 HHP1) DWIDTH)
  122.                         P5 (POLAR HP1 (ANGLE HP2 HP1) HFWIDTH)
  123.                         P6 (POLAR HHP1 (ANGLE HHP2 HHP1) HFWIDTH))
  124.                   (COMMAND "BREAK" HP1 HHP1)
  125.                   (COMMAND "BREAK" HP2 HHP2)
  126.                   (COMMAND "LINE" HP1 HP2 "")
  127.                   (COMMAND "LINE" HHP1 HHP2 "")
  128.                   (COMMAND "LAYER" "M" "DOOR" "C" "5" "" "")
  129.                   (COMMAND "LINE" HP1 P5 "")
  130.                   (COMMAND "ARC" SP "E" P5 "D" (ATOF (ANGTOS (ANGLE HP2 HP1) 0 4)))
  131.                   (COMMAND "LINE" HHP1 P6 "")
  132.                   (COMMAND "ARC" SP "E" P6 "D" (ATOF (ANGTOS (ANGLE HP2 HP1) 0 4)))
  133.                   (COMMAND "LAYER" "S" C-LAY "")
  134.                   (SETVAR "CMDECHO" CMD)
  135.                   (SETVAR "OSMODE" OS)
  136.                   (SETVAR "PICKBOX" PICK)))))
  137.     (PRINC))
  138.  
  139. (princ ".")
  140.  
  141. ;; convert a selection set to a list of entity lists
  142. (DEFUN SS2ELIST (SS / ENTLIST COUNTER)
  143.        (SETQ COUNTER 0)
  144.        (REPEAT (SSLENGTH SS)
  145.                (PROGN (SETQ ENTLIST (CONS (ENTGET (SSNAME SS COUNTER)) ENTLIST))
  146.                       (SETQ COUNTER (1+ COUNTER)))) ENTLIST)
  147.  
  148. (princ ".")
  149.  
  150. (DEFUN PARALLEL (LINE1 LINE2)                 ;; Takes 2 e-lists as arguments.
  151.        (OR (~= (ANGLE (CDR (ASSOC 10 LINE1))  ;; Allow tolerance for nearly 
  152.                       (CDR (ASSOC 11 LINE1))) ;; parallel lines.
  153.                (ANGLE (CDR (ASSOC 10 LINE2))
  154.                       (CDR (ASSOC 11 LINE2))) (/ PI 90.0)) ;; 2 degrees tol
  155.            (~= (ANGLE (CDR (ASSOC 11 LINE1))
  156.                       (CDR (ASSOC 10 LINE1)))
  157.                (ANGLE (CDR (ASSOC 10 LINE2))
  158.                       (CDR (ASSOC 11 LINE2))) (/ PI 90.0))))
  159.  
  160. (princ ".")
  161.  
  162. (DEFUN ~= (ACT_VAL TEST_VAL TOL)  ;;fuzzy equality
  163.        (AND (<= ACT_VAL (+ TEST_VAL TOL))
  164.             (>= ACT_VAL (- TEST_VAL TOL))))
  165.  
  166. (princ "\nC:DOOR and C:DDOOR loaded.  Type DOOR or DDOOR to begin.")
  167.