Chapter 20 Source code.

;;; Source code from the book "AutoCAD expert's Visual LISP"

;;; (c) 2012 Ediciones ARTUAL, S.L. Barcelona, EspaƱa.
;;; 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.02 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 0t)
  (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.00.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