;;; Copyright © 2012-2020 by Reinaldo N. Togores. All rights reserved.
;;; Use of this code is allowed mentioning the book and its author.
;;;Chapter 20. Procedural and NURBS Surfaces.
(defun nurbs-data (/ name)
(initget 1)
(setq name (getstring "\nSurface equation function: "))
(while (not (setq equation (car (atoms-family 0 (list name)))))
(prompt
(strcat "\nFunction " name " is not defined."))
(initget 1)
(setq name (getstring "\nSurface equation function: ")))
(initget 1)
(setq center (getpoint "\nSurface center: "))
(initget (+ 1 2 4))
(setq dim-x (getdist center "\nSurface X dimension: "))
(initget (+ 1 2 4))
(setq dim-y (getdist center "\nSurface Y dimension: "))
(initget (+ 1 2 4))
(setq dim-z (getdist center "\nSurface Z dimension: "))
(initget (+ 1 2 4))
(setq n-sec (getint "\nNumber of cross section profiles: "))
(initget (+ 1 2 4))
(setq n-pts (getint "\nNumber of fit points for each cross section: "))
(initget 1 "Chord Square Uniform")
(setq param (getkword
"\nKnot parametrization [Chord/Square root/Uniform]: "))
(cond
((= param "Chord") (setq param (+ 8 32 1024)))
((= param "Square") (setq param (+ 8 64 1024)))
((= param "Uniform") (setq param (+ 8 128 1024)))))
;;;Listing 20.1. Prompting for data for the lofted NURBS surface.
(defun calc-sect (dim-x dim-y dim-z equation n-sec n-pts
/ d-sec d-pts x0 y0 section sections)
(setq xmin (- (/ dim-x 2))
ymin (- (/ dim-y 2))
d-sec (/ dim-y (1- n-sec))
d-pts (/ dim-x (1- n-pts))
x0 xmin
y0 ymin)
(repeat n-sec
(setq x0 xmin
section nil)
(repeat n-pts
(setq section (cons (list x0 y0) section))
(setq x0 (+ x0 d-pts)))
(setq sections (cons (reverse section) sections))
(setq y0 (+ y0 d-sec)))
(coord-z (reverse sections) equation dim-z))
;;;Listing 20.2. Function that calculates the fit point coordinates.
(defun ent-sect (point-list cod70 normal-vec)
(entmake
(append
(list '(0 . "SPLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbSpline")
(cons 70 cod70)
'(71 . 3)
(cons 74 (length point-list))
(cons 210 normal-vec))
(mapcar '(lambda (x) (cons 11 x)) point-list))))
;;;Listing 20.3. Function that creates the cross-section as a SPLINE.
(defun C:NURBS-SURF (/ *error* mtrans dim-x dim-y equation dim-z n-sec n-pts
param sections sel-sect obj i xmin ymin)
(defun *error* ()
(cmd-out)
(vla-EndUndoMark *aevl:drawing*))
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(setvar "SURFACEMODELINGMODE" 1)
(nurbs-data)
(setq sections (calc-sect dim-x dim-y dim-z equation n-sec n-pts)
sel-sect (ssadd))
(foreach secc sections
(if (ent-sect secc param '(0.0 -1.0 0.0))
(ssadd (entlast) sel-sect)))
(cmd-in)
(vl-cmdf "_loft" "_mode" "_surface" sel-sect "" "")
(if
(= (vla-get-ObjectName (vlax-ename->vla-object (entlast)))
"AcDbNurbSurface")
(progn (setq obj (vlax-ename->vla-object (entlast)))
(if (> (getvar "DELOBJ") 0)
(progn (setq i 0)
(repeat (sslength sel-sect)
(entdel (ssname sel-sect i))
(setq i (1+ i)))))
(if mtrans
(vla-TransformBy obj mtrans))
(ax-translation obj (trans center 1 0 t))
(vla-put-CvHullDisplay obj 1)
(ax-SWt))
(progn
(vla-ZoomWindow
*aevl:acad*
(vlax-3d-point (list xmin ymin))
(vlax-3d-point (mapcar '- (list xmin ymin))))
(alert
(strcat "\nError building the surface."
"\nCheck cross sections for intersecting loops"))))
(cmd-out))
;;;Listing 20.4. Main function C:NURBS-SURF.
(defun ent-profile (elev height width lyr /)
(setq x (/ width 2.0)
y (- height x))
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 lyr)
(cons 38 elev)
'(90 . 4) ;Number of vertices
'(70 . 1) ;Closed polyline flag (1)
(list 10 x 0.0) ;First vertex coordinates (OCS)
'(42 . 0.0) ;Straight segment bulge
'(91 . 0) ;End of data for vertex 1
(list 10 x y) ;Second vertex coordinates (OCS)
'(42 . 1.0) ;Arc segment bulge
'(91 . 0) ;End of data for vertex 2
(list 10 (- x) y) ;Third vertex coordinates (OCS)
'(42 . 0.0) ;Straight segment bulge
'(91 . 0) ;End of data for vertex 3
(list 10 (- x) 0.0) ;Fourth vertex coordinates (OCS)
'(42 . 0.0) ;Straight segment bulge
'(91 . 0) ;End of data for vertex 4
'(210 0.0 1.0 0.0) ;Normal vector.
)))
;;;Listing 20.5. Function that creates the profile.
(defun assoc-surf-data (/)
(initget (+ 1 2 4))
(setq n (getint "\nNumber of profiles: "))
(initget (+ 1 2 4))
(setq interval (getreal "\nDistance between profiles: "))
(initget (+ 1 2 4))
(setq height (getreal "\nProfile height: "))
(initget (+ 1 2 4))
(while (>= (setq width (getreal "\nProfile width: ")) (* height 2))
(prompt
(strcat "\nWidth must be less than "
(rtos (* height 2.0) 2 2)))
(initget (+ 1 2 4)))
(initget 1)
(setq id (getstring "\nSurface ID: ")))
;;;Listing 20.6. Prompting for cross-section data.
(defun ax-trans-ucs (ucs-coll origin x-axis-pt y-axis-pt name / ucs curr-ucs)
(setq ucs (vl-catch-all-apply
'vla-add
(list ucs-coll
(vlax-3d-point origin)
(vlax-3d-point x-axis-pt)
(vlax-3d-point y-axis-pt)
name)))
(cond
((vl-catch-all-error-p ucs)
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message ucs))))
(t
(setq curr-ucs (vl-catch-all-apply
'vla-put-ActiveUCS
(list *aevl:drawing* ucs)))
(if (vl-catch-all-error-p curr-ucs)
(prompt
(strcat "\nERROR: "
(vl-catch-all-error-message ucs)))))))
;;;Listing 20.7. Function that sets the correct UCS right before applying the constraints.
(defun make-profiles (origin-list height width lyr id / ucs-coll pt-o pt-x pt-y nom i
p1 p2 dimconst)
(setq ucs-coll (vla-get-UserCoordinateSystems
*aevl:drawing*))
(foreach elev origin-list
(ent-profile elev height width lyr)
(setq profiles (cons (entlast) profiles)))
(setq profiles (reverse profiles))
(ax-view '(-1 0 0) t)
(vla-ZoomScaled *aevl:acad* 0.9 acZoomScaledRelative)
(setvar "PERSPECTIVE" 0)
(setq i 0)
(foreach profile profiles
(setq pt-o (list 0.0 (nth i origin-list) 0.0)
pt-x (list 100.0 (nth i origin-list) 0.0)
pt-y (list 0 (nth i origin-list) 100.0)
nom (strcat "SCP-" (itoa i))
i (1+ i))
(ax-trans-ucs ucs-coll pt-o pt-x pt-y nom)
(vl-cmdf "_AutoConstrain" profile "")
(vl-cmdf "_GcFix" (osnap '(0 0 0) "_mid"))
(setq p1 (osnap (list 0.0 height 0.0) "_qua")
p2 (list 0.0 (/ height 3.0) 0.0))
(vl-cmdf "_DcRadius" p1 p2 "")
(setq dimconst (vl-catch-all-apply
'vlax-ename->vla-object
(list (entlast))))
(cond
((vl-catch-all-error-p dimconst)
(prompt (strcat "\nERROR: " (vl-catch-all-error-message))))
(t
(vla-get-DimConstrName dimconst)
(vla-put-DimConstrName dimconst (strcat id "_rad" (itoa i)))
(vla-put-DimConstrDesc
dimconst
(strcat "Surface " id "; Profile radius " (itoa i)))))))
;;;Listing 20.8. Function that creates the fully constrained cross-sections.
(defun make-assoc-surf (profiles /)
(setvar "SURFACEASSOCIATIVITY" 1)
(setvar "SURFACEMODELINGMODE" 0)
(vla-put-ActiveLayer
*aevl:drawing*
(ax-layer
(vla-get-layers *aevl:drawing*)
(strcat id "_SURFACE")
"4"
"Continuous"))
(vl-cmdf "_LOFT" "_MOde" "_SUrface")
(foreach profile profiles (vl-cmdf profile))
(vl-cmdf "" "_Cross"))
;;;Listing 20.9. Function that creates the associative surface.
(defun val (i n /)
(if (zerop (logand 1 i))
(+ (/ n 2.0))
(- (/ n 2.0))))
;;;Listing 20.10. Function that calculates the modified dimensional constraint value.
(defun mod-constraint (/ dim-constraints i n dim-constr pos curr-value increm)
(if
(setq dim-constraints (ssget
"X"
(list
'(0 . "DIMENSION")
'(8 . "*ADSK_CONSTRAINTS")
(cons 1 (strcat id "_rad*")))))
(progn
(setq i 0
n (sslength dim-constraints))
(repeat n
(setq dim-constr (ssname dim-constraints i)
pos (cdr (assoc 10 (entget dim-constr)))
dim-constr (vlax-ename->vla-object dim-constr)
curr-value (atof (vla-get-DimConstrValue dim-constr))
increm (val i curr-value)
i (1+ i))
(vla-put-DimConstrExpression
dim-constr
(rtos (+ curr-value increm)))))
(alert "\nError modifying dimensional constraints.")))
;;;Listing 20.11. Function that modifies the dimensional constraints.
(defun C:ASSOC-SURF (/ *error* n interval height width origin-list profiles)
(defun *error* ()
(cmd-out)
(vla-EndUndoMark *aevl:drawing*)
(command-s "_U"))
(vla-StartUndoMark *aevl:drawing*)
(cmd-in)
(if (= (getvar "WORLDUCS") 0)
(vl-cmdf "_UCS" "_W"))
(assoc-surf-data)
(setq i 0)
(repeat n
(setq origin-list (cons (* interval i) origin-list)
i (1+ i)))
(make-profiles
(reverse origin-list)
height
width
(strcat id "_PROFILE")
id)
(make-assoc-surf profiles)
(mod-constraint)
(cmd-out)
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 20.12. Main Function C:ASSOC-SURF.
(defun cmd-conv-param (id / dim-constraints i)
(if (= (getvar "BLOCKEDITOR") 1)
(progn
(setq dim-constraints (ssget
"X"
(list
'(0 . "DIMENSION")
'(8 . "*ADSK_CONSTRAINTS")
(cons 1 (strcat id "_rad*"))))
i 0)
(repeat (sslength dim-constraints)
(vl-cmdf "_bcparameter"
"_Convert"
(ssname dim-constraints i)
"")
(setq i (1+ i))))))
;;;Listing 20.13. Converting dimensional constraints into parameters when working in the Block Editor.
(defun C:ASSOC-SURF-BL (/ *error* n interval height width origin-list profiles)
(defun *error* ()
(cmd-out)
(vla-EndUndoMark *aevl:drawing*)
(command-s "_U"))
(vla-startundomark *aevl:drawing*)
(cmd-in)
(if (= (getvar "WORLDUCS") 0)
(vl-cmdf "_UCS" "_W"))
(assoc-surf-data)
(vl-cmdf "_BEDIT" id "")
(setq i 0)
(repeat n
(setq origin-list (cons (* interval i) origin-list)
i (1+ i)))
(make-profiles
(reverse origin-list)
height
width
(strcat id "_PROFILE")
id)
(make-assoc-surf profiles)
(mod-constraint)
(cmd-conv-param id)
(vl-cmdf "_BCLOSE" "_Save")
(vl-cmdf "_-INSERT" id "0,0" "1.0" "1.0" "1.0" "0")
(cmd-out)
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 20.14. C:ASSOC-SURF with constraints conversion into parameters.
No comments:
Post a Comment