;; Block Preview Example Program - Lee Mac
;; Short program to demonstrate DCL Block Preview function
(defun c:bpreview ( / *error* _blockpreview dcl def des lst tmp )
(defun *error* ( msg )
(if (< 0 dcl)
(unload_dialog dcl)
)
(if (= 'file (type des))
(close des)
)
(if (and tmp (findfile tmp))
(vl-file-delete tmp)
)
(if (and msg (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun _blockpreview ( blk )
(start_image "img")
(fill_image 0 0 (dimx_tile "img") (dimy_tile "img") 0)
(LM:BlockPreview "img" blk 5)
(end_image)
)
(while (setq def (tblnext "BLOCK" (null def)))
(if
(and
(= 0 (logand 125 (cdr (assoc 70 def))))
(not (wcmatch (cdr (assoc 2 def)) "`_*,`**,*|*"))
)
(setq lst (cons (cdr (assoc 2 def)) lst))
)
)
(cond
( (null (setq lst (vl-sort lst '<)))
(princ "\nNo blocks found in drawing.")
)
( (null
(and
(setq tmp (vl-filename-mktemp nil nil ".dcl"))
(setq des (open tmp "w"))
(foreach line
'(
"blockpreview : dialog"
"{"
" label = \"Block Preview\";"
" spacer;"
" : row"
" {"
" : list_box { key = \"lst\"; width = 30.0; fixed_width = true; }"
" spacer;"
" : image"
" {"
" key = \"img\";"
" width = 33.5;"
" aspect_ratio = 1.0;"
" fixed_width = true;"
" fixed_height = true;"
" }"
" }"
" spacer;"
" ok_only;"
"}"
)
(write-line line des)
)
(not (setq des (close des)))
(PointList en))
(if (or (= "POINT" (cdr (assoc 0 el))) (vlax-curve-isclosed en))
(setq pl (cons (last pl) pl))
)
(setq ec (_getcolour el))
(setq vl
(append vl
(mapcar
(function
(lambda ( a b )
(list (car a) (cadr a) (car b) (cadr b) ec)
)
)
pl (cdr pl)
)
)
)
)
)
)
)
vl
)
(defun _unique ( l / a r )
(while (setq a (car l))
(setq r (cons a r)
l (vl-remove-if (function (lambda ( b ) (equal a b))) (cdr l))
)
)
(reverse r)
)
(cond
( (or (< margin 0)
(<= (setq xt (dimx_tile key)) (* 2 margin))
(<= (setq yt (dimy_tile key)) (* 2 margin))
)
nil
)
( (setq vl (assoc (strcase block) cache))
(foreach x (cdr vl) (apply 'vector_image x))
t
)
( (setq vl (_getvectors block))
(setq mi (apply 'mapcar (cons 'min vl))
mx (apply 'mapcar (cons 'max vl))
mi (list (min (car mi) (caddr mi)) (min (cadr mi) (cadddr mi)))
mx (list (max (car mx) (caddr mx)) (max (cadr mx) (cadddr mx)))
r1 (/ (- (car mx) (car mi)) (- xt (* 2 margin)))
r2 (/ (- (cadr mx) (cadr mi)) (- yt (* 2 margin)))
)
(cond
( (and (equal r1 r2 1e-8) (equal r1 0.0 1e-8))
(setq sc 1.0
vc (mapcar '- mi (list (/ xt 2.0) (/ yt 2.0)))
)
)
( (equal r1 r2 1e-8)
(setq sc r1
vc (mapcar '(lambda ( x ) (- x (* sc margin))) mi)
)
)
( (PointList ( ent / der di1 di2 di3 elst fun inc lst par rad )
(setq elst (entget ent))
(cond
( (eq "POINT" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)))
)
( (eq "LINE" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)) (cdr (assoc 11 elst)))
)
( (member (cdr (assoc 0 elst)) '("CIRCLE" "ARC"))
(setq di1 0.0
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 (1+ (fix (* 35.0 (/ di2 (cdr (assoc 40 elst)) (+ pi pi))))))
fun (if (vlax-curve-isclosed ent) < <=)
)
(while (fun di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
lst
)
( (or (eq (cdr (assoc 0 elst)) "LWPOLYLINE")
(and (eq (cdr (assoc 0 elst)) "POLYLINE") (zerop (logand (cdr (assoc 70 elst)) 80)))
)
(setq par 0)
(repeat (fix (1+ (vlax-curve-getendparam ent)))
(if (setq der (vlax-curve-getsecondderiv ent par))
(if (equal der '(0.0 0.0 0.0) 1e-8)
(setq lst (cons (vlax-curve-getpointatparam ent par) lst))
(if (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
di1 (vlax-curve-getdistatparam ent par)
di2 (vlax-curve-getdistatparam ent (1+ par))
)
(progn
(setq inc (/ (- di2 di1) (1+ (fix (* 35.0 (/ (- di2 di1) rad (+ pi pi)))))))
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
)
)
)
)
(setq par (1+ par))
)
(if (or (vlax-curve-isclosed ent) (equal '(0.0 0.0 0.0) der 1e-8))
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "ELLIPSE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
di3 (* di2 (/ (+ pi pi) (abs (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)))))
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
der (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1)))
di1 (+ di1 (/ di3 (1+ (fix (/ 35.0 (/ di3 der (+ pi pi)))))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "SPLINE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 25.0)
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
;der (/ (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1))) inc)
di1 (+ di1 inc) ;(+ di1 (if (equal 0.0 der 1e-10) inc (min inc (/ 1.0 der (* 10. inc)))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; 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)
