;;; Copyright © 2012-2020 by Reinaldo N. Togores. All rights reserved.
;;; Use of this code is allowed mentioning the book and its author.
;;;Chapter 19. Subdivision Surfaces.
(defun mesh-polyhedron-data (/)
(initget 1 "Tetrahedron Hexahedron Dodecahedron")
(setq class (getkword
"\nPolyhedron [Tetrahedron/Hexahedron/Dodecahedron]: "))
(initget 1)
(setq center (getpoint "\nPolyhedron's center: "))
(initget (+ 1 2 4))
(setq radius (getdist center "\Circumscribed sphere's radius: "))
(initget (+ 1 4))
(while
(> (setq level (getint "\nSmoothing level: "))
(getvar "SMOOTHMESHMAXLEV"))
(prompt
(strcat
"\nSmooting level must not be more than "
(itoa (getvar "SMOOTHMESHMAXLEV"))))
(initget (+ 1 2 4)))
(initget 1 "Always Never 1 2 3")
(setq crease (getkword
"\nEdge crease level [Always/Never/1/2/3]: "))
(cond
((= crease "Always") (setq crease -1))
((= crease "Never") (setq crease 0))
(t (setq crease (atof crease)))))
;;;Listing 19.1. Data entry for a Polyhedron shaped MESH.
(defun face-edges (face-indices / i v0 v1 v2 edge-indices)
(foreach face face-indices
(setq i 0
v0 (nth i face))
(repeat (1- (length face))
(setq v1 (nth i face)
i (1+ i)
v2 (nth i face))
(if
(not
(or (member (list v1 v2) edge-indices)
(member (list v2 v1) edge-indices)))
(setq edge-indices (cons (list v1 v2) edge-indices))))
(if
(not
(or (member (list v2 v0) edge-indices)
(member (list v0 v2) edge-indices)))
(setq edge-indices (cons (list v2 v0) edge-indices))))
(apply 'append (reverse edge-indices)))
;;;Listing 19.2. Function that creates the MESH edges list.
(defun ent-mesh (vertices faces edges level crease / res ent-list)
(setq res (cons (cons 91 level) res)
res (cons (cons 92 (length vertices)) res))
(foreach vertex vertices
(setq res (cons (cons 10 vertex) res)))
(setq res (cons
(cons
93
(+ (length faces)
(length (apply 'append faces))))
res))
(foreach face faces
(setq res (cons (cons 90 (length face)) res))
(foreach datum face
(setq res (cons (cons 90 datum) res))))
(setq res (cons (cons 94 (/ (length edges) 2)) res))
(foreach endpt edges (setq res (cons (cons 90 endpt) res)))
(setq res (cons (cons 95 (/ (length edges) 2)) res))
(repeat (/ (length edges) 2)
(setq res (cons (cons 140 crease) res)))
(setq ent-list (append
(list
'(0 . "MESH")
'(100 . "AcDbEntity")
'(100 . "AcDbSubDMesh")
'(71 . 2)
'(72 . 0))
(reverse res)))
(if (entmake ent-list)
(entlast)))
;;;Listing 19.3. Creating MESH entities with ENTMAKE.
(defun C:MESH-POLYHEDRON (/ mtrans class center radius level vertices faces edges
crease obj)
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(mesh-polyhedron-data)
(op-polyhedron class)
(setq faces (mapcar '(lambda (face) (mapcar '1- face)) faces)
edges (face-edges faces)
obj (ent-mesh vertices faces edges level crease))
(if obj
(progn
(setq obj (vlax-ename->vla-object obj))
(ax-scale obj (list radius radius radius))
(if mtrans (vla-TransformBy obj mtrans))
(ax-translation obj (trans center 1 0 t))
(ax-SWt)))
(vla-EndUndoMark *aevl:drawing*)
(princ))
;;;Listing 19.4. Main Function C:MESH-POLYHEDRON.
(defun subd-mesh-data (/ name str n-faces)
(initget 1)
(setq name (getstring "\nEquation function to use: "))
(while (not (setq equation (car (atoms-family 0 (list name)))))
(prompt
(strcat "\nThe function "
name
" is not defined for the present context."))
(initget 1)
(setq name (getstring "\nSpecify function to use: ")))
(initget 1)
(setq center (getpoint "\nMesh center: "))
(initget (+ 1 2 4))
(setq dim-x (getdist center "\nMesh X dimension: "))
(initget (+ 1 2 4))
(setq dim-y (getdist center "\nMesh Y dimension: "))
(initget (+ 1 2 4))
(setq dim-z (getdist center "\nMesh Z dimension: "))
(if (< dim-x dim-y)
(setq str "X")
(setq str "Y"))
(initget (+ 1 2 4))
(setq n-faces (getint
(strcat "\nNumber of faces for dimension "
str
": ")))
(if (> dim-x dim-y)
(setq rows n-faces
columns (fix (/ dim-x (/ dim-y n-faces))))
(setq rows (fix (/ dim-y (/ dim-x n-faces)))
columns n-faces)))
;;;Listing 19.5. Function that prompts for the MESH data.
(defun mesh-vertices-calc (dim-x dim-y equation dim-z rows columns / xmin ymin dx dy
face faces x0 y0)
(setq xmin (- (/ dim-x 2))
ymin (- (/ dim-y 2))
dx (/ dim-x columns)
dy (/ dim-y rows))
(setq x0 xmin
y0 ymin)
(repeat columns
(setq y0 ymin)
(repeat rows
(setq face (list (list xmin y0)
(list (+ xmin dx) y0)
(list (+ xmin dx) (+ y0 dy))
(list xmin (+ y0 dy))))
(setq faces (cons face faces)
y0 (+ y0 dy)))
(setq xmin (+ xmin dx)))
(coord-z (reverse faces) equation dim-z))
;;;Listing 19.6. Function that calculates the vertices coordinates for each face.
(defun coord-z (faces equation dim-z / lst-z height scale-f)
(setq lst-z (mapcar
'(lambda (face)
(mapcar '(lambda (pt) (apply equation pt))
face))
faces)
height (- (apply 'max (apply 'append lst-z))
(apply 'min (apply 'append lst-z)))
scale-f (/ dim-z height)
lst-z (mapcar
'(lambda (lst-face)
(mapcar '(lambda (z) (* z scale-f)) lst-face))
lst-z))
(mapcar
'(lambda (face elev)
(mapcar '(lambda (pt z) (append pt (list z)))
face
elev))
faces
lst-z))
;;;Listing 19.7. Function that calculates the Z coordinates values.
(defun unique-vertices-list (faces / vertices-list)
(foreach face faces
(foreach vertex face
(if (not (member vertex vertices-list))
(setq vertices-list (cons vertex vertices-list)))))
(reverse vertices-list))
;;;Listing 19.8. Function that generates the vertices list without duplicates.
(defun face-indices-list (faces unique-vertices / indices face-indices)
(foreach face faces
(foreach vertex face
(setq indices (cons (vl-position vertex unique-vertices)
indices)))
(setq face-indices (cons indices face-indices)
indices nil))
(reverse face-indices))
;;;Listing 19.9. Function that creates the list of face vertex indices.
(defun rectangular-subd-mesh (faces-vertices-coords / vertices faces edges obj)
(setq vertices (unique-vertices-list faces-vertices-coords)
faces (face-indices-list faces-vertices-coords vertices)
edges (face-edges faces)
obj (ent-mesh vertices faces edges 0 -1)))
;;;Listing 19.10. Function that generates the data structure and creates the mesh.
(defun C:SUBD-MESH (/ mtrans equation center dim-x dim-y dim-z rows columns n-faces
coord-vertices obj)
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(subd-mesh-data)
(setq coord-vertices (mesh-vertices-calc dim-x dim-y equation dim-z rows columns)
obj (rectangular-subd-mesh coord-vertices))
(cond
(obj
(setq obj (vlax-ename->vla-object obj))
(if mtrans
(vla-TransformBy obj mtrans))
(ax-translation obj (trans center 1 0 t))
(ax-SWt))
(t (prompt "\nError in mesh construction.")))
(vla-EndUndoMark *aevl:drawing*)
(princ))
;;;Listing 19.11. Main Function C:SUBD-MESH.
(defun cmd-mesh-box (center n-div dim-x dim-y dim-z corner / dims d-inc divs
corner-pt obj)
(setq dims (list dim-x dim-y dim-z)
d-inc (/ (apply 'max (list dim-x dim-y dim-z)) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims)
divs (mapcar
'(lambda (div)
(if (< div 1)
1
div))
divs))
(setvar "DIVMESHBOXLENGTH" (nth 0 divs))
(setvar "DIVMESHBOXWIDTH" (nth 1 divs))
(setvar "DIVMESHBOXHEIGHT" (nth 2 divs))
(if corner
(setq corner-pt (mapcar '+ center (list dim-x dim-y 0))
obj (vl-cmdf "._MESH" "_B" center corner-pt dim-z))
(setq obj (vl-cmdf "._MESH" "_B" "_C" center "_L" dim-x dim-y dim-z)))
(if obj
(entlast)))
;;;Listing 19.12. Creating a Rectangular Prism MESH.
(defun ellipse-length (dim-x dim-y /)
(*
pi
(+ dim-x dim-y)
(+ 1
(/
(* 3.0 (expt (/ (- dim-x dim-y) (+ dim-x dim-y)) 2))
(+ 10.0
(sqrt
(- 4.0
(* 3.0
(expt (/ (- dim-x dim-y) (+ dim-x dim-y))
2.0)))))))))
;;;Listing 19.13. Function that calculates an ellipse's circumference.
(defun cmd-mesh-cone (center n-div dim-x dim-y dim-z / r-max dims d-inc divs obj)
(setq r-max (apply 'max (list dim-x dim-y))
dims (list (ellipse-length dim-x dim-y) r-max dim-z)
d-inc (/ (apply 'max dims) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims)
divs (mapcar
'(lambda (div)
(if (< div 1)
1
div))
divs))
(setvar "DIVMESHCONEAXIS" (nth 0 divs))
(setvar "DIVMESHCONEBASE" (nth 1 divs))
(setvar "DIVMESHCONEHEIGHT" (nth 2 divs))
(setq obj
(vl-cmdf "_MESH"
"_Cone"
"_Elliptical"
"_C"
centro
dim-x
(list (nth 0 center)
(+ (nth 1 center) dim-y)
(nth 2 center))
dim-z))
(if obj
(entlast)))
;;;Listing 19.14. Function that creates a cone-shaped MESH.
(defun cmd-mesh-cylinder (center n-div dim-x dim-y dim-z / r-max dims d-inc divs obj)
(setq r-max (apply 'max (list dim-x dim-y))
dims (list (ellipse-length dim-x dim-y) r-max dim-z)
d-inc (/ (apply 'max dims) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims)
divs (mapcar
'(lambda (div)
(if (< div 1)
1
div))
divs))
(setvar "DIVMESHCYLAXIS" (nth 0 divs))
(setvar "DIVMESHCYLBASE" (nth 1 divs))
(setvar "DIVMESHCYLHEIGHT" (nth 2 divs))
(setq obj (vl-cmdf "._MESH"
"_CY"
"_E"
"_C"
center
dim-x
(list (nth 0 center)
(+ (nth 1 center) dim-y)
(nth 2 center))
(list (nth 0 center)
(nth 1 center)
(+ (nth 2 center) dim-z))))
(if obj
(entlast)))
;;;Listing 19.15. Function that creates a cylindrical MESH.
(defun cmd-mesh-sphere (center n-div radius / dims d-inc divs obj)
(setq dims (list (* 2 pi radius) (* pi radius))
d-inc (/ (car dims) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims))
(if (> (nth 0 divs) 2)
(setvar "DIVMESHSPHEREAXIS" (nth 0 divs))
(setvar "DIVMESHSPHEREAXIS" 3))
(if (> (nth 1 divs) 1)
(setvar "DIVMESHSPHEREHEIGHT" (nth 1 divs))
(setvar "DIVMESHSPHEREHEIGHT" 2))
(setq obj (vl-cmdf "._MESH" "_S" center radius))
(if obj
(entlast)))
;;;Listing 19.16. Function that creates a Spherical MESH.
(defun entmod-mesh (ename equation dim-z / ent-list vertices lst-z height scale-f x y z
vertices-mod new-list)
(if (eq (type ename) 'VLA-OBJECT)
(setq ename (vlax-vla-object->ename ename)))
(setq ent-list (entget ename)
vertices (values 10 ent-list)
lst-z (mapcar
'(lambda (vert)
(apply equation
(list (nth 0 vert) (nth 1 vert))))
vertices)
height (- (apply 'max lst-z) (apply 'min lst-z))
scale-f (/ dim-z height))
(foreach vertex vertices
(setq x (nth 0 vertex)
y (nth 1 vertex)
z (+ (nth 2 vertex)
(* scale-f (apply equation (list x y))))
vertices-mod (cons (list x y z) vertices-mod)))
(setq vertices-mod (reverse vertices-mod))
(setq i 0
new-list ent-list)
(while (< i (length vertices))
(setq new-list (subst (cons 10 (nth i vertices-mod))
(cons 10 (nth i vertices))
new-list)
i (1+ i)))
(entmod new-list)
(entupd ename))
;;;Listing 19.17. Modifying a MESH entity using entmod.
(defun ax-mod-mesh (obj equation dim-z / level xyz lst-z i pt)
(if (eq (type obj) 'ENAME)
(setq ename (vlax-ename->vla-object obj)))
(setq level (vla-get-Smoothness obj))
(if (> level 0)
(vla-put-Smoothness obj 0))
(setq xyz (vlax-safearray->list
(vlax-variant-value (vla-get-Coordinates obj)))
lst-z (cal-z xyz equation dim-z)
i 0)
(repeat (vla-get-VertexCount obj)
(setq pt (vlax-safearray->list
(vlax-variant-value (vla-get-Coordinate obj i))))
(vla-put-Coordinate
obj
i
(vlax-3d-point
(list (nth 0 pt)
(nth 1 pt)
(+ (nth 2 pt) (nth i lst-z)))))
(setq i (1+ i)))
(if (> level 0)
(vla-put-Smoothness obj level)))
;;;Listing 19.18. Modifying a MESH object using ActiveX.
(defun rev-par (x y /)
(- (+ (expt x 2.0) (expt y 2.0))))
;;;Listing 19.19. Function for calculating the vertices of a paraboloid of revolution.
(defun hyp-par (x y /)
(- (expt x 2) (expt y 2)))
;;;Listing 19.20. Function for calculating the vertices of a hyperbolic paraboloid.
(defun ucs->w (/ tmp)
(setq tmp (ax-ucs
"World"
'(0.0 0.0 0.0)
'(1.0 0.0 0.0)
'(0.0 1.0 0.0)))
(vla-put-ActiveUCS *aevl:drawing* tmp))
;;;Listing 19.21. Function that establishes the World Coordinate System as current.
(defun paraboloid-data (/)
(initget 1 "Entmod Activex")
(setq proc (getkword "Method: [Entmod/Activex]: "))
(if (= proc "Entmod")
(setq proc 'entmod-mesh)
(setq proc 'ax-mod-mesh))
(initget 1 "Revolution Hyperbolic")
(setq option (getkword
"\nParaboloid type [Revolution/Hyperbolic]: "))
(cond
((= option "Revolution") (setq option 'rev-par))
((= option "Hyperbolic") (setq option 'hyp-par)))
(initget 1 "Rectangle Circle Ellipse Sphere")
(setq form (getkword "\nForm [Rectangle/Circle/Ellipse/Sphere]: "))
(if (= form "Rectangle")
(progn (initget "Center cOrner")
(if
(not
(setq origin (getkword
"Coordinates origin [Center/cOrner]
"
)))
(setq origin "Center"))))
(initget 1)
(setq pos (getpoint "\nMesh origin position: ")
z-mesh (getdist pos "\nMesh height: "))
(cond
((= form "Rectangle")
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nX dimension: "))
(initget (+ 1 2 4))
(setq dimY (getdist pos "\nY dimension: "))
(initget (+ 1 2 4))
(setq dimZ (getdist pos "\nMesh thickness: "))
(initget (+ 1 2 4))
(setq prec (getint "\nMesh resolution: "))
(while (not (< 1 prec 257))
(prompt "\nMesh resolution must be in the 2 to 256 range")
(initget (+ 1 2 4))
(setq prec (getint "\nMesh resolution: "))))
((= form "Circle")
(initget (+ 2 4))
(if
(not
(setq prec (getint "\nPerimeter subdivision <20>: ")))
(setq prec 20))
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nMesh radius: ")
dimY dimX)
(initget (+ 1 2 4))
(setq dimZ (getdist pos "\nMesh thickness: ")))
((= form "Ellipse")
(initget (+ 2 4))
(if
(not
(setq prec (getint "\nPerimeter subdivision <20>: ")))
(setq prec 20))
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nMesh X semi-axis length: "))
(initget (+ 1 2 4))
(setq dimY (getdist pos "\nMesh Y semi-axis length: "))
(initget (+ 1 2 4))
(setq dimZ (getdist pos "\nMesh thickness: ")))
((= form "Sphere")
(initget (+ 2 4))
(if (not (setq prec (getint "\nEquatorial subdivision <20>: ")))
(setq prec 20))
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nSphere radius: ")))))
;;;Listing 19.22. Function that prompts for the Paraboloid's data.
(defun C:PARABOLOID (/ *error* proc option form origin pos z-mesh dimX
dimY dimZ prec obj)
(defun *error* (msg)
(vla-EndUndoMark *aevl:drawing*)
(command-s "_U")
(cmd-out)
(prompt msg))
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq curr-ucs (ax-ucs-matrix)
mtrans (last curr-ucs))
(ucs->w))
(t (setq mtrans nil)))
(paraboloid-data)
(cmd-in)
(cond
((= form "Rectangle")
(if (= origin "Center")
(cmd-mesh-box '(0 0 0) prec dimX dimY dimZ nil)
(cmd-mesh-box '(0 0 0) prec dimX dimY dimZ t)))
((= form "Circle")
(cmd-mesh-cylinder '(0 0 0) prec dimX dimY dimZ))
((= form "Ellipse")
(cmd-mesh-cylinder '(0 0 0) prec dimX dimY dimZ))
((= form "Sphere") (cmd-mesh-sphere '(0 0 0) prec dimX)))
(setq obj (vlax-ename->vla-object (entlast)))
(cmd-out)
(if (= (vla-get-ObjectName obj) "AcDbSubDMesh")
(progn
(apply proc (list obj option z-mesh))
(if mtrans
(progn
(vla-put-ActiveUCS
*aevl:drawing*
(vla-item
(vla-get-UserCoordinateSystems
*aevl:drawing*)
(car curr-ucs)))
(vla-TransformBy obj mtrans)))
(ax-translation obj pos)
(ax-SWt)))
(vla-EndUndoMark *aevl:drawing*)
(princ))
;;;Listing 19.23. Main function C:PARABOLOID.
(defun entmod-mesh-xyz (ename equation dim-max axis / ent-list vertices i j k lst-mod
height scale-f v-i v-j v-mod vertices-mod)
(if (eq (type ename) 'VLA-OBJECT)
(setq ename (vlax-vla-object->ename ename)))
(setq ent-list (entget ename)
vertices (values 10 ent-list))
(cond
((= axis 0)
(setq i 1
j 2))
((= axis 1)
(setq i 0
j 2))
((= axis 2)
(setq i 0
j 1)))
(setq lst-mod (mapcar
'(lambda (vert)
(apply equation
(list (nth i vert) (nth j vert))))
vertices)
height (- (apply 'max lst-mod) (apply 'min lst-mod))
scale-f (/ dim-max height))
(foreach vertex vertices
(setq v-i (nth i vertex)
v-j (nth j vertex)
v-mod (+ (nth axis vertex)
(* scale-f (apply equation (list v-i v-j)))))
(cond
((= axis 0)
(setq vertices-mod (cons (list v-mod v-i v-j) vertices-mod)))
((= axis 1)
(setq vertices-mod (cons (list v-i v-mod v-j) vertices-mod)))
((= axis 2)
(setq vertices-mod (cons (list v-i v-j v-mod) vertices-mod)))))
(setq vertices-mod (reverse vertices-mod))
(setq k 0
new-list ent-list)
(while (< k (length vertices))
(setq new-list (subst (cons 10 (nth k vertices-mod))
(cons 10 (nth k vertices))
new-list)
k (1+ k)))
(entmod new-list)
(entupd ename))
;;;Listing 19.24. Function that transforms a MESH in the X, Y or Z directions.
(defun C:SHAPE-M (/ ent axis equation var-dim)
(vla-StartUndoMark *aevl:drawing*)
(prompt "\nSelect MESH to shape: ")
(while (not (setq ent (ssget "_:S" '((0 . "MESH")))))
(prompt "\nSelect MESH to shape: "))
(initget (+ 2 4) "X Y Z")
(setq axis (getkword "\nSpecify shaping axis [X/Y/Z]"))
(cond
((= axis "X") (setq axis 0))
((= axis "Y") (setq axis 1))
(t (setq axis 2)))
(setq ent (ssname ent 0))
(initget 1)
(setq equation (getstring "\nSpecify shaping equation function: "))
(cond
((car (atoms-family 0 (list equation)))
(initget (+ 1 2 4))
(setq var-dim (getdist "\nShaping offset: "))
(entmod-mesh-xyz ent (read equation) var-dim axis))
(t
(prompt
(strcat "\nFunction "
equation
" has not been defined in the current context."))))
(vla-EndUndoMark *aevl:drawing*)
(princ))
;;;Listing 19.25. Main function C:SHAPE-M.
(defun cmd-square-mesh (ins-pt side div / x-min x-max y-min y-max z edges)
(setvar "MESHTYPE" 1) ; MESH type object
(setvar "SURFTAB1" div) ; U tesselations
(setvar "SURFTAB2" div) ; V tesselations
(setq x-min (nth 0 ins-pt)
x-max (+ x-min side)
y-min (nth 1 ins-pt)
y-max (+ y-min side)
z (nth 2 ins-pt))
(vl-cmdf "_LINE" ins-pt (list x-max y-min z) "") ; Line 1
(setq edges (cons (entlast) edges))
(vl-cmdf "_LINE"
(list x-max y-min z)
(list x-max y-max z)
"") ; Line 2
(setq edges (cons (entlast) edges))
(vl-cmdf "_LINE"
(list x-max y-max z)
(list x-min y-max z)
"") ; Line 3
(setq edges (cons (entlast) edges))
(vl-cmdf "_LINE" (list x-min y-max z) ins-pt "") ; Line 4
(setq edges (cons (entlast) edges))
(apply 'vl-cmdf (cons "EDGESURF" edges)) ; Create MESH
(mapcar 'entdel edges) ; Erase lines
(princ))
;;;Listing 19.26. Creating a planar square MESH using the EDGESURF command.
(defun hyperb-data (/)
(initget 1)
(setq base-cen (getpoint "\nCenter of the base: "))
(initget (+ 1 2 4))
(setq base-rad (getdist base-cen "\nBase radius: "))
(initget (+ 1 2 4))
(setq height (getdist base-cen "\nHyperboloid height: "))
(initget 1)
(setq top-cen (getpoint "\nCenter for the top circle: "))
(initget (+ 1 2 4))
(setq top-rad (getdist top-cen "\nTop circle radius: "))
(initget (+ 1 2 4))
(while (not (< 0.0 (setq ang (getreal "\nTurn angle: ")) 180.0))
(prompt "\nTurn angle must be in the 0º to 180º range")
(initget (+ 1 2 4)))
(setq ang (dtr ang))
(initget (+ 2 4))
(if (not (setq n (getint "\nCircumference subdivisions <32>: ")))
(setq n 32))
(initget (+ 2 4))
(if (not (setq k (getint "\nSmoothing level <2>: ")))
(setq k 2))
(setvar "SURFTAB1" n)
(setvar "MESHTYPE" 1))
;;;Listing 19.27. Function that prompts for the hyperboloid data.
(defun ent-polcirc (elev radius lyr)
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
(cons 8 lyr)
'(100 . "AcDbPolyline")
'(90 . 2)
'(70 . 1)
(cons 38 elev)
(cons 10 (list (- radius) 0.0))
'(42 . 1.0)
'(91 . 0)
(cons 10 (list radius 0.0))
'(42 . 1.0)
'(91 . 0))))
;;;Listing 19.28. Function that creates circular profiles.
(defun ax-trans-rot (obj vector ang)
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos ang) (- (sin ang)) 0.0 (nth 0 vector))
(list (sin ang) (cos ang) 0.0 (nth 1 vector))
(list 0.0 0.0 1.0 (nth 2 vector))
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 19.29. Function that translates and rotates a profile.
(defun C:HYPERBOLOID (/ base-cen base-rad height top-cen top-rad ang base-profile
top-profile layer-coll hyper)
(hyperb-data)
(cond
((ent-polcirc 0.0 base-rad "PROFILES")
(setq base-profile (entlast))
(ax-trans-rot
(vlax-ename->vla-object base-profile)
base-cen
0.0))
(t (prompt "\nERROR creating the base profile.") (exit)))
(cond
((ent-polcirc height top-rad "PROFILES")
(setq top-profile (entlast))
(ax-trans-rot
(vlax-ename->vla-object top-profile)
top-cen
ang))
(t (prompt "\nERROR creating the top profile.") (exit)))
(setq layer-coll (vla-get-layers *aevl:drawing*))
(vla-put-ActiveLayer
*aevl:drawing*
(ax-layer layer-coll "SURFACE" "4" "Continuous"))
(if (vl-cmdf "_rulesurf" base-profile top-profile)
(progn (setq hyper (entlast))
(vla-put-smoothness (vlax-ename->vla-object hyper) k)
(ax-SWt))
(prompt "\nError creating the hyperboloid.")))
;;;Listing 19.30. Main function C:HYPERBOLOID.
No comments:
Post a Comment