;;; Saved from: https://www.cadtutor.net/forum/topic/43738-a-challenge-how-to-draw-this-floor-heating/
;;----------------------------=={ Heat Grid }==-------------------------;;
;; ;;
;; Prompts the user to select a rectangular closed LWPolyline and ;;
;; specify a grid wire spacing, and proceeds to construct a maximised ;;
;; filleted spiral centered within the selected LWPolyline based on ;;
;; the given wire spacing. ;;
;; ;;
;; The program will perform successfully with rectangular LWPolylines ;;
;; at any rotation or orientation, and with all UCS & Views. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
(defun c:hg ( / 2pi a1 a2 bl d2 di en h1 h2 ix l1 l2 l3 mt no p1 p2 pi2 rm tv v1 vl w1 w2 zv )
(setq pi2 (/ pi 2.0)
2pi (+ pi pi)
)
(while
(progn
(setvar 'errno 0)
(setq en (car (entsel "\nSelect Rectangular Closed LWPolyline: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'ename (type en))
(if (null (LM:rectangle-p en))
(princ "\nObject must be a Rectangular Closed LWPolyline.")
)
)
)
)
)
(if (= 'ename (type en))
(progn
(setq vl
(apply 'append
(mapcar
(function
(lambda ( dx )
(if (= 10 (car dx))
(list (trans (cdr dx) en 1))
)
)
)
(entget en)
)
)
)
(setq a1 (angle (car vl) (cadr vl))
w1 (distance (car vl) (cadr vl))
h1 (distance (cadr vl) (caddr vl))
)
(if (< h1 w1)
(setq tv w1
w1 h1
h1 tv
a1 (+ a1 pi2)
)
)
(setq w2 w1
h2 h1
)
(while
(and
(progn
(initget 6)
(setq di
(getdist
(strcat "\nSpecify Wire Spacing"
(if *spacing* (strcat " : ") ": ")
)
)
)
(if (null di)
(setq di *spacing*)
(setq *spacing* di)
)
)
(progn
(setq no (fix (/ w2 di))
rm (rem w2 di)
)
(if (equal 0.0 rm 0.1)
(setq no (1- no)
rm (+ rm di)
)
)
(if (zerop (rem no 2))
(setq no (1- no)
rm (+ rm di)
)
)
(< no 2)
)
)
(princ "\nWire Spacing too large.")
)
(if (= 'real (type di))
(progn
(setq w2 (- w2 rm)
h2 (- h2 rm)
p1 (list (/ rm 2.0) (/ rm 2.0) 0.0)
l1 (list p1)
a2 pi2
ix 0
)
(repeat no
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l1 (cons p1 l1)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
(setq l1 (reverse l1)
w2 (- w1 rm di di)
h2 (- h1 rm di)
p1 (list (+ (/ rm 2.0) di) (/ rm 2.0) 0.0)
l2 (list p1)
a2 pi2
ix 0
)
(repeat (- no 2)
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l2 (cons p1 l2)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (= ix 2)
(setq h2 (- h2 di))
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
)
(setq
v1
(mapcar '- (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) (car vl) (caddr vl))
(setq p2
(apply 'mapcar
(cons (function (lambda ( a b ) (/ (+ a b) 2.0)))
(mapcar
(function
(lambda ( x ) (apply 'mapcar (cons x l1)))
)
'(min max)
)
)
)
)
)
d2 (/ di 2.0)
bl (/ (sin (/ pi -8.0)) (cos (/ pi 8.0)))
l1
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list b)
)
( (null c)
(list (polar b (angle b a) d2))
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l1)
l1
(append (cdr l1) '(nil))
)
)
bl (- bl)
l2
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list (polar b (angle b c) d2))
)
( (null c)
(list b)
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l2)
l2
(append (cdr l2) '(nil))
)
)
zv (trans '(0.0 0.0 1.0) 1 0 t)
mt (list (list (cos a1) (- (sin a1))) (list (sin a1) (cos a1)))
v1 (mapcar '+ v1 (mapcar '- p2 (mxv mt p2)))
l3
(mapcar
(function
(lambda ( x )
(if (listp x)
(cons 10 (trans (mapcar '+ (mxv mt x) v1) 1 zv))
(cons 42 x)
)
)
)
(append l1 (list -1.0 (polar (last l1) (+ a2 pi) di) (polar (car l2) a2 di) 1.0) l2)
)
)
(entmake
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 090 (length (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) l3)))
'(070 . 0)
(cons 210 zv)
)
l3
)
)
)
)
)
)
(princ)
)
;; Rectangle-p - Lee Mac
;; Returns T if the supplied entity is a rectangular closed LWPolyline
(defun LM:rectangle-p ( e / a b c d )
(and
(= "LWPOLYLINE" (cdr (assoc 0 (setq e (entget e)))))
(= 4 (cdr (assoc 90 e)))
(= 1 (logand 1 (cdr (assoc 70 e))))
(LM:nobulge-p e)
(mapcar 'set '(a b c d)
(apply 'append
(mapcar '(lambda ( x ) (if (= 10 (car x)) (list (cdr x)))) e)
)
)
(LM:perp-p (mapcar '- a b) (mapcar '- a d))
(LM:perp-p (mapcar '- a b) (mapcar '- b c))
(LM:perp-p (mapcar '- a d) (mapcar '- c d))
)
)
;; Perpendicular-p - Lee Mac
;; Returns T if the supplied vectors are perpendicular
(defun LM:perp-p ( u v )
(equal 0.0 (apply '+ (mapcar '* u v)) 1e-8)
)
;; No Bulge-p - Lee Mac
;; Returns T if the supplied LWPolyline DXF list has zero bulge
(defun LM:nobulge-p ( e / p )
(or (not (setq p (assoc 42 e)))
(and (equal 0.0 (cdr p) 1e-8)
(LM:nobulge-p (cdr (member p e)))
)
)
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
(strcat
"\n:: HeatGrid.lsp | Version 1.0 | © Lee Mac "
(menucmd "m=$(edtime,$(getvar,DATE),YYYY)")
" http://www.lee-mac.com ::"
"\n:: Type \"hg\" to Invoke ::"
)
)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
(c:hg)
