;;; Axonometric Planes Creator through dynamic rectangles
;;; Saved from here: https://www.theswamp.org/index.php?topic=26111.0

(defun c:apc()
(while (and (setq pt1 (getpoint "\nstartpoint:"))
(setq pt2 (getpoint pt1 "\nendpoint:")))
(command "pline" "non" pt1 "non" pt2 "non" pt2 "non" pt1 "c")
(setq en (entlast))
(prompt (strcat "\nwidth" "(def wid=" (vl-princ-to-string real)"):" ))
(setq test t)
(while TEST
(setq TMP (grread t 4 0))
(setq MODE (car TMP)
PT (cadr TMP)
)

(cond ((= MODE 3)
(setq TEST NIL)
)
((= mode 25)
(entdel en)
(setq TEST NIL)
)
((= MODE 5)
(entdel en)
(setq pt3 pt)
(setq ptl (ls-jx2 pt1 pt2 pt3))
(command "pline" "non" (car ptl) "non" (cadr ptl) "non" (caddr ptl) "non" (cadddr ptl) "c")
(setq en (entlast))
)
((member tmp '((2 13) (2 32)))
(if (= real nil)
(progn
(entdel en)
(setq TEST NIL)
);progn
(progn
(setq pt (getvar "lastpoint"))
(setq ptzz (ls-jx3 pt1 pt2 pt real))
(setq ptl (ls-jx2 pt1 pt2 ptzz))
(command "pline" "non" (car ptl) "non" (cadr ptl) "non" (caddr ptl) "non" (cadddr ptl) "c")
(entdel en)
(setq test nil)

);progn
);if
)
((and (member tmp '((2 49) (2 50)(2 51)(2 52)(2 53)(2 54)(2 55)(2 56)(2 57)(2 48)(2 46)))
(setq asc (cadr tmp)) (/= asc 47) (>= asc 46) ( pdz 0)
(setq ang1 (+ ang (* pi 0.5)))
(setq ang1 (- ang (* pi 0.5)))
);if

);progn
(progn
(if ( pdz 0)
(setq ang1 (+ ang (* pi 0.5)))
(setq ang1 (- ang (* pi 0.5)))
);if
(setq ptz (polar ptt ang1 jl))
);progn
(progn
(if ( pdz 0)
(setq ptz (polar pt2 ang1 (/ jl (sin (- (- ang ang1) 180)))))
(setq ptz (polar pt2 ang1 (/ jl (sin (- (- ang1 ang) 180)))))
);if
);progn
(progn
(setq ang1 (angle pt1 pt))
(if (> pdz 0)
(setq ptz (polar pt1 ang1 (/ jl (sin (- ang1 ang)))))
(setq ptz (polar pt1 ang1 (/ jl (sin (- ang ang1)))))
);if
);progn
);if

);progn
)

ptz

)
(defun ls-get-lineperpt (p p1 p2 / l1 a b c x y z x1 y1 z1 k)
(setq l1 (mapcar '- p2 p1)
a (car l1)
b (cadr l1)
c (last l1)
x (car p)
y (cadr p)
z (last p)
x1 (car p1)
y1 (cadr p1)
z1 (last p1)
)
(if (equal l1 '(0. 0. 0.))
l1
(progn(setq k (/ (+ (* a (- x x1))
(* b (- y y1))
(* c (- z z1))
)
(+ (* a a)
(* b b)
(* c c)
)
)
)
(list (+ x1 (* a k))
(+ y1 (* b k))
(+ z1 (* c k))
)
) )
)
(defun ls-linepointposition (p1 p2 pt wc / p c B C P z)
(setq p pt)
(setq z (apply '+
(mapcar '(lambda (b)
(setq c (- (* (car p) (cadr b)) (* (cadr p) (car b)))
p b
)
c
)
(list p1 p2 pt)
)
)
)
(if (< (abs z) (* wc 0.0614658))
(setq z 0)
(setq z z)
)
)
(c:apc)

Advertisements