
;; ************************************************************************
;;;                I N  T H E   N A M E   O F   G O D
(defun idrlisp ()
 (setvar "cmdecho" 0)
 (setvar "blipmode" 0)
 (command "ucs" ""  )
 (setq cl (getvar "clayer"))
 (princ (strcat "\n      * * *   W E L C O M E   T O  < IDR >  P "
                                  "R O G R A M   * * * "))
 (princ (strcat "\nInsert Door , Version  1.0 "
                 ", (c) 1995 by R. Negarandeh . "))
  (if *error*                         ; Set our new error handler
    (setq err_oe *error* *error* err_er)
    (setq *error* err_er)
  )
       (if (= (tblsearch "layer" "door" ) nil)
           (command "layer" "m" "door" "c" "4" "" "")
       )
       (if (= (tblsearch "layer" "hid" ) nil)
           (command "layer" "m" "hid" "c" "1" "" "lt" "hidden" "" "")
       )
       (if (= (tblsearch "layer" "wl" ) nil)
           (command "layer" "m" "wl" "c" "7" "" "")
       )

 (if
     (= ps1 nil )(setq ps1 1)
 )
 (setq ps2 (rtos ps1 2 0))
 (princ (strcat "\nEnter plotting scale [1=?] <1=" ps2))
 (setq ps (getreal ">:"))
 (if
     (= ps nil) (setq ps ps1 )
 )
 (setq ps1 ps)
 (if
     (= ds1 nil )(setq ds1 1)
 )
 (setq ds2 (rtos ds1 2 0))
 (princ (strcat "\nEnter drawing scale [1/?] <1/" ds2))
 (setq ds (getreal ">:"))
 (if
     (= ds nil) (setq ds ds1 )
 )
 (setq ds1 ds)
 (setq ds2 (rtos ds 2 0))

 (setq fact (/ ds ps))

  (setq p1 (getpoint "\nEnter axe of door :"))
  (command "ortho" "off")
  (setq p2 (getpoint p1 "\nEnter span of door :"))
  (setq sd (getpoint "\nSide to open :"))
  (setq dif (- (angle p1 p2) (angle p1 sd)))
  (if (or (and (> dif 0.0) (< (abs dif) pi))
          (and (< dif 0.0) (> (abs dif) pi))
      )
      (setq sp (distance p1 p2))
      (setq sp (- (distance p1 p2)))
  )
  (initget "Fit Oneside Twosides" )
        (setq ansr1 (getkword "\nOneside/Twosides/<Fit>:"))
        (cond
          ((= ansr1 "Oneside")
              (progn
                (setq fit t)
                (setq sp1 (getdist p1 "\nEnter span of door :"))
                (setq sp1 (* (/ (abs sp) sp) sp1))
                (makedoor p1 p2 sp1 fit)
              )
          )
          ((= ansr1 "Twosides")
              (progn
                (setq fit nil)
                (setq sp1 (getdist p1 "\nEnter first  side : "))
                (setq pp2 (polar p1 (angle p1 p2) sp1 ))
                (setq sp2 (getdist pp2 (strcat "\nEnter second side <"
                                           (rtos sp1 2 0) ">: ")))
                (if (= sp2 nil)(setq sp2 sp1))
                (setq p2 (polar p1 (angle p1 p2) (+ sp1 sp2)))
                (setq sp12 (+ (abs sp1) (abs sp2) ) )
                (setq sp1 (+ sp1 (/ 12.5 fact)))
                (setq sp2 (+ sp2 (/ 12.5 fact)))
                (setq sp1    (* (/ (abs sp) sp) sp1))
                (setq sp2 (- (* (/ (abs sp) sp) sp2)))
                (setq ff 1)
                (makedoor p1 p2 sp1 fit)
                (makedoor p2 p1 sp2 fit)
              )
          )
          ((or (= ansr1 "Fit" ) (= ansr1 nil))
             (progn
                (setq fit t)
                (makedoor p1 p2 sp fit)
             )
          )
        )
    (print)
  (if err_oe (setq *error* err_oe))   ; Reset old error function if error
 (princ)
 (princ "\n     Good Luck .   ")
 (setvar "blipmode" 1)
 (setvar "cmdecho" 1)
 (setvar "clayer" cl)
 (prin1 )
)
(setq idrid 1)
(defun C:IDR () (idrlisp))


(princ (strcat "\n      <InsertDoor> loaded.  Start command with IDR ." ))
(princ )
; ************************************************************************
(defun dtr (a)
   (* pi (/ a 180.0))
)

(defun sgn (a)
   (/ a (abs a))
)
; ************************************************************************

(defun makedoor (pt1 pt2 sp fit )
(command "undo" "g")
 (setq pangle (angtos (angle pt1 pt2) 0 8))
 (command "ucs" "o" pt1)
 (command "ucs" "z" pangle )
 (setq fact1 (* (/ (abs sp) sp) fact))

    (setq pt2  (trans (list (/ 97.5 fact) (/ -00.0 fact1)) 0 2))
    (setq pt3  (trans (list (/ 97.5 fact) (/ -25.0 fact1)) 0 2))
    (setq pt4  (trans (list (/ 25.0 fact) (/ -25.0 fact1)) 0 2))
    (setq pt5  (trans (list (/ 25.0 fact) (/ -75.0 fact1)) 0 2))
    (setq pt6  (trans (list (/ 0.00 fact) (/ -75.0 fact1)) 0 2))
    (setq pt7  (trans (list (/ 0.00 fact) (/ -100  fact1)) 0 2))
    (setq pt8  (trans (list (+ (abs sp) ) (/ -00.0 fact1)) 0 2))
    (setq pt9  (trans (list (- (car pt8) (/ 12.5 fact)) (/ -00.0 fact1)) 0 2))
    (setq pt10 (trans (list (- (car pt8) (/ 12.5 fact)) (/ -25.0 fact1)) 0 2))
    (setq pt11 (trans (list (- (car pt8) (/ 00.0 fact)) (/ -25.0 fact1)) 0 2))
    (setq pt12 (trans (list (- (car pt8) (/ 00.0 fact)) (/ -100  fact1)) 0 2))
    (setq pt13 (trans (list (- (car pt8) (/ 00.0 fact)) (/ -75.0 fact1)) 0 2))
    (setq pt14 (trans (list (/ 47.5 fact) (/ -50.0 fact1))  0 2))
    (setq pt15 (trans (list (/ 97.5 fact) (/ -50.0 fact1))  0 2))
    (setq pt16 (trans (list (/ 97.5 fact) (- (/ 60 fact1) sp)) 0 2))
    (setq pt17 (trans (list (/ 47.5 fact) (- (/ 60 fact1) sp)) 0 2))
    (setq pt18 (trans (list (car pt9) (cadr pt14) )  0 2))

 (setvar "clayer" "wl")
    (command "line" '(0 0 0) pt2 pt3 pt4 pt5 pt6 pt7 "")
 (if (= fit nil)
          (progn
               (if (= ff 1)
                (progn
                    (setq
                      pt9  (polar pt2 0 (- sp12 (/ 195 fact)))
                      pt12 (polar pt7 0 sp12 )
                      ff 0
                    )
                      (setvar "clayer" "hid")
                      (command "line"  pt2 pt9 "" )
                      (command "line"  pt7 pt12 "")
                )
               )
          )
          (progn
               (command "line"  pt8 pt9 pt10 pt11 pt12 "")
               (setvar "clayer" "hid")
               (command "line"  pt2 pt9 "" )
               (command "line"  pt7 pt12 "")
          )
 )

 (setvar "clayer" "door")
    (command "pline" pt16 pt15 pt14 pt17 pt16 "a" pt18 "")
 (command "ucs" ""  )
(command "undo" "e")
)
