;;; SNAKE.LSP
;;; To draw a lightweight Polyline Snaking curve.
;;; Draws a zero-width continuous LWPolyline as a series of approximately 120-degree arc segments,
;;; alternating direction. Intermediate point locations are adjusted for localized path direction on curved
;;; paths, maintaining consistent overall "snake" width. [Non-tangent changes in direction in Polyline
;;; paths, or overly tight curves relative to snake width in some entity types, or non-Centered justification
;;; with Polylines or Splines that intersect (or relative to snake width, get too close to) themselves, may
;;; yield quirky results.]
;;; Divides path length into whole arc chord-length increments to eliminate need for trimming at ends;
;;; forces an even number of segments for closed paths so that result looks continuous across start/end.
;;; Draws on current Layer, unless Deleting pre-Existing path; if so, draws on its Layer, assuming the
;;; intent is to replace it.
;;; Under select-Existing option, asks User to select again if nothing is selected, or if selected object is an
;;; inappropriate entity type.
;;; Accounts for different Coordinate Systems.
;;; Remembers option choices and offers them as defaults for subsequent use.
;;; Options:
;;; 1. create new within the routine, or select pre-Existing, path of any 2D finite type with linearity;
;;; 2. if selected Existing object is on a locked Layer, whether to unlock it and Proceed, or Quit;
;;; 3. PRevious = redraw along prior path (whether retained or deleted) allowing different choices;
;;; 4. Flip = one-step replacement of prior result, if Left- or Right-justified, on other side -- meant for
;;; Existing Line/Pline/Spline (drawing direction not visually apparent), but works on all types;
;;; 5. Retain or Delete base path, whether new or selected Existing;
;;; 6. Snake width between extreme bulge points (midpoints of curves);
;;; 7. Center-line or Left- or Right-side justification (Left & Right are relative to drawing direction
;;; for Line/Pline/Spline; for Arc/Circle/Ellipse, Left draws inside, Right draws outside).
;;;
;;; Kent Cooper, last edited July 2009
;;; Slightly modified by Igal Averbuh 2018 (added x1 x2 x4 wave multiplicator for "snake" width)
(defun snreset ()
(setvar 'osmode osm)
(setvar 'blipmode blips)
(setvar 'plinewid plwid)
(setvar 'plinetype pltyp)
(setvar 'celtype ltyp)
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); end defun - snreset
;
(defun locdir (path dist); LOCal DIRection of path at distance along it, accounting for UCS
(angle
'(0 0 0)
(trans
(vlax-curve-getFirstDeriv
path
(vlax-curve-getParamAtDist path dist)
); end getFirstDeriv
0 1 T ; world to current CS, as displacement
); end trans
); end angle
); end defun - locdir
;
(defun snpt (advpro offpro)
;; This subroutine calculates a SNake polyline definition PoinT, with arguments:
;; advpro = localized amount of ADVance from current Bulge segment's basepoint along path,
;; as a PROportion of segment length
;; offpro = localized amount of OFFset to side from path, as a PROportion of thickness
(polar
(trans
(vlax-curve-getPointAtDist ; advance point along working path
sntpath
(+
(vlax-curve-getDistAtPoint sntpath bbase)
(* advpro blength); proportion of segment length
); end +
); end getPointAtDist
0 1 ; from World coordinates to object's coordinates
); end trans
(+ ; localized angle of offset
(locdir
sntpath
(+
(vlax-curve-getDistAtPoint sntpath bbase)
(* advpro blength)
); end +
); end locdir
(* pi 0.5 side); perpendicular to center-line path [side +/- gives left/right]
); end +
(* offpro *snthk*); proportion of snake thickness
); end polar
); end defun - snpt
;
;;; ******************************** Main Routine: SNAKE ********************************
(defun C:DSL
(/ *error* cmde osm blips plwid pltyp ltyp typetemp pathsel pathdata pathtype
polyclosed unlktemp deltemp thktemp justtemp ucschanged ptno side pldist
plpt sntpath pathlength isCurved vertcheck vertbulge bbase bsegs blength)
;
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort"))
(princ (strcat "\nError: " errmsg))
); end if
(if ucschanged (command "_.ucs" "_prev"))
; ^ i.e. don't go back unless routine reached UCS change but didn't change it back
(snreset)
); end defun - *error*
;
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq
osm (getvar 'osmode)
blips (getvar 'blipmode)
plwid (getvar 'plinewid)
pltyp (getvar 'plinetype)
ltyp (getvar 'celtype)
); end setq
(setvar 'osmode 0)
(setvar 'plinewid 0)
(setvar 'plinetype 2)
(setvar 'celtype "CONTINUOUS")
;
(initget
(strcat
"Existing Line Arc Circle Pline ELlipse Spline"
(if *sntype* " PRevious" ""); add PR option only if not first use
(if (member *snjust* '("Left" "Right")) " Flip" ""); add Flip option only if prior was L/R
); end strcat
); end initget
(setq
typetemp
(getkword
(strcat
"\nPath type [Existing, or new Line(single)/Arc/Circle/Pline/ELlipse/Spline"
(if *sntype* "/PRevious" ""); offer PR option if not first use
(if (member *snjust* '("Left" "Right")) "/Flip" ""); add Flip option only if prior was L/R
"] : "
); end strcat
); end getkword & typetemp
*sntype*
(cond
(typetemp); if User typed something other than Enter, use it
(*sntype*); if Enter and there's a prior choice, use that
(T "Pline"); otherwise [Enter on first use], Line default
); end cond & *sntype*
); end setq
;
(if
(and (wcmatch *sntype* "PRevious,Flip") *isLocked*)
(command "_.layer" "_unlock" *pathlay* ""); then - unlock layer without asking [prior Proceed option]
); end if
;
(cond ; select or make path
((= *sntype* "Existing")
(while
(not
(and
(setq
pathsel (car (entsel "\nSelect object to draw a Snake along an Existing path,"))
pathdata (if pathsel (entget pathsel))
pathtype (if pathsel (substr (cdr (assoc 100 (cdr (member (assoc 100 pathdata) pathdata)))) 5))
; ^ = entity type from second (assoc 100) without "AcDb" prefix; using this because (assoc 0)
; value is the same for 2D & 3D Polylines; 2D OK, but not 3D because they can't be offset,
; so only center justification could be offered, and result would be flattened in current CS
); end setq
(wcmatch pathtype "Line,Arc,Circle,Ellipse,Spline,Polyline,2dPolyline")
); end and
); end not
(prompt "\nNothing selected, or it is not a 2D finite path type; try again:")
); end while
); end first condition - Existing
((and (wcmatch *sntype* "PRevious,Flip") (= *sndel* "Delete")) (entdel *snpath*)); bring back prior
((= *sntype* "Line") (setvar 'cmdecho 1) (command "_.line" pause pause "") (setvar 'cmdecho 0))
((not (wcmatch *sntype* "PRevious,Flip")); all other entity types
(setvar 'cmdecho 1)
(command *sntype*)
(while (> (getvar 'cmdactive) 0) (command pause))
(setvar 'cmdecho 0)
); end fourth condition
); end cond
(setvar 'blipmode 0)
;
(setq
*snpath* ; set object as base path [not localized, so it can be brought back if PR/F and D options]
(cond
((= *sntype* "Existing") pathsel); selected object
((wcmatch *sntype* "PRevious,Flip") *snpath*); keep the same
((entlast)); otherwise, newly created path
); end cond & *snpath*
pathdata (entget *snpath*)
pathtype (cdr (assoc 0 pathdata)); can now use this, once past possibility of selecting 3D Polyline
polyclosed ; used in offsetting determinations
(and
(wcmatch pathtype "*POLYLINE"); allow for "heavy" 2D or "lightweight" Polylines
(vlax-curve-isClosed *snpath*)
); end and
*pathlay* (cdr (assoc 8 pathdata))
; ^ not localized, so that under PRevious or Flip options, knows what layer to unlock if needed
*isLocked* ; not localized, so that under PRevious or Flip options, don't need to ask again
(if (and (wcmatch *sntype* "PRevious,Flip") *isLocked*)
T ; keep with PR/F if prior object was on locked layer
(/= (cdr (assoc 70 (tblsearch "layer" *pathlay*))) 0); other types - 0 for Unlocked: nil; 4 for Locked: T
); end if & *isLocked*
); end setq
;
(if *isLocked*
(if (not (wcmatch *sntype* "PRevious,Flip")); then - check for not redoing prior object
(progn ; then - ask whether to unlock
(initget "Proceed Quit")
(setq
unlktemp
(getkword
(strcat
"\nLayer is locked; temporarily unlock and Proceed, or Quit? [P/Q] : "
); end strcat
); end getkword & unlktemp
*snunlk*
(cond
(unlktemp); if User typed something, use it
(*snunlk*); if Enter and there's a prior choice, keep that
(T "Proceed"); otherwise [Enter on first use], Proceed
); end cond & *snunlk*
); end setq
(if (= *snunlk* "Proceed")
(command "_.layer" "_unlock" *pathlay* ""); then
(progn (snreset) (quit)); else
); end if
); end progn & inner else argument
); end inner if & outer then argument
); end outer if - no else argument [no issue if not on locked layer]
;
(if (wcmatch *sntype* "PRevious,Flip") (entdel *sn*))
; ^ if re-using Previous path with new choices, or Flipping to other side, delete previous result
;
(if (/= *sntype* "Flip")
(progn ; then - ask whether to Retain or Delete if not Flipping
(initget "Retain Delete")
(setq
deltemp
(getkword
(strcat
"\nRetain or Delete base path [R/D] : "
); end strcat
); end getkword
*sndel*
(cond
(deltemp); if User typed something, use it
(*sndel*); if Enter and there's a prior choice, keep that
(T "Delete"); otherwise [Enter on first use], Delete
); end cond & *sndel*
); end setq
); end progn
); end if -- no else argument [keep previous option if Flipping]
;
(if (/= *sntype* "Flip")
(progn ; then - ask for thickness if not Flipping
(initget (if *snthk* 6 7) "A B C D"); no Enter on first use, no 0, no negative
(setq
thktemp
(getdist
(strcat
"\nThickness of Snake, or [A=1/B=2/C=4/D=8/E=10/F=12/G=14]"
(if *snthk* (strcat " ") ""); default only if not first use
": "
); end strcat
); end getdist & thktemp
*snthk*
(cond
((= thktemp "A") 1.0)
((= thktemp "B") 2.0)
((= thktemp "C") 4.0)
((= thktemp "D") 8.0)
((= thktemp "E") 10.0)
((= thktemp "F") 12.0)
((= thktemp "G") 14.0)

((numberp thktemp) thktemp); user entered number or picked distance
(T *snthk*); otherwise, user hit Enter - keep value
); end cond & *snthk*
); end setq
); end progn
); end if -- no else argument [keep previous thickness if Flipping]
;
(if (/= *sntype* "Flip")
(progn ; then - ask for justification if not Flipping
(initget "Center Left Right")
(setq
justtemp
(getkword
(strcat
"\nJustification [Center/Left(inside arc,circle,ellipse)/Right(outside)] : "
); end strcat
); end getkword
*snjust*
(cond
(justtemp); if User typed something, use it
(*snjust*); if Enter and there's a prior choice, use that
(T "Center"); otherwise [Enter on first use], Center
); end cond & *snjust*
); end setq
); end progn
(setq *snjust* (if (= *snjust* "Left") "Right" "Left")); else - reverse justification if Flipping
); end if
;
(command "_.ucs" "_new" "_object" *snpath*) ; set UCS to match object
(setq
ucschanged T ; marker for *error* to reset UCS if routine doesn't get to it
ptno 0 ; starting point-number value for intermediate point multiplier
side 1 ; starting directional multiplier for 'side' [left/right of center-path] argument in (snpt)
); end setq
;
(if (= *snjust* "Center")
(command "_.copy" *snpath* "" '(0 0 0) '(0 0 0)); then - copy in place for Center justification
(command ; else - offset by half Snake thickness for Left or Right justification
"_.offset"
(/ *snthk* 2)
*snpath*
(polar
(if polyclosed ; less risk of inside-offsetting Plines closing at acute angles wrongly to outside
(setq ; then - partway in
pldist (vlax-curve-getDistAtParam *snpath* 0.5)
plpt (trans (vlax-curve-getPointAtParam *snpath* 0.5) 0 1)
); end setq
(trans (vlax-curve-getStartPoint *snpath*) 0 1); else - start point
); end if - point argument
(apply
(if (= *snjust* "Left") '+ '-); add for Left, subtract for Right
(list (locdir *snpath* (if polyclosed pldist 0)) (/ pi 2)); partway into closed Pline; else, startpoint
); end apply - angle argument
0.1 ; distance
); end polar
"" ; end offset
); end command - offset & else argument
); end if
;
(setq
sntpath (entlast); save as Temporary [working] PATH
pathlength (vlax-curve-getDistAtParam sntpath (vlax-curve-getEndParam sntpath))
isCurved
; Determine whether path has any curves, calling for more definition points - without them,
; curved paths can result in bulges that are obviously far from tangent crossing path
(cond
((= pathtype "LINE") nil); Lines are never curved
((= pathtype "LWPOLYLINE"); check LWPolylines for arc segments
(if
(vl-remove-if-not ; recognize only non-0 bulge factors
'(lambda (x) (and (= (car x) 42) (/= (cdr x) 0.0)))
pathdata
); end vl-remove-if-not; returns list only if there are arc segments
T ; contains at least one arc segment
nil ; all line segments
); end if
); end LWPolyline condition
((= pathtype "POLYLINE"); check heavy 2D Polylines for arc segments
(setq vertcheck (entnext sntpath))
(while
(and
(not vertbulge)
(= (cdr (assoc 0 (entget vertcheck))) "VERTEX")
); end and
(setq
vertbulge (/= (cdr (assoc 42 (entget vertcheck))) 0.0); T if bulge factor
vertcheck (entnext vertcheck)
); end setq
); end while
vertbulge
); end heavy 2D Polyline condition
(T) ; Arc/Circle/Ellipse/Spline are always curved
); end cond & isCurved
bbase (vlax-curve-getStartPoint sntpath); startpoint is first Bulge BASE point
bsegs ; closed paths need even numbers of Bulge SEGmentS; open can have odd number
(if (vlax-curve-isClosed *snpath*)
(* (fix (+ (/ pathlength *snthk* 3.4641) 0.5)) 2); then - round to nearest *even* number
(fix (+ (/ pathlength *snthk* 1.7321) 0.5)); else - round to nearest *whole* number
); end if & bsegs
blength (/ pathlength bsegs); proportioned Bulge LENGTH
); end setq
;
(if (= *sndel* "Delete") (setvar 'clayer *pathlay*)) ; if Deleting Existing path, draw on same Layer
;
(command
"_.pline"
(snpt 0 0); start point of first bulge
"_arc"
(while (< ptno bsegs)
(setq
bbase (vlax-curve-getPointAtDist sntpath (* blength ptno)); incremented Bulge segment BASE along path
ptno (1+ ptno); increment point number for next time [put here so it's not last function in (while) loop]
); end setq
(command "_second")
(if isCurved
(command ; then - more definition points for curved paths
(snpt 0.1289 0.226); second point of first shorter curve
(snpt 0.3025 0.4397); third point of first shorter curve
"_second"
); end interim command
); end if [no else - continue to next second-point designation]
(command (snpt 0.5 0.5)); 2nd pnt of [middle shorter, or single longer] curve: midpoint of bulge
(if isCurved
(command ; then - more definition points for curved paths
(snpt 0.6975 0.4397); third point of middle curve
"_second"
(snpt 0.8711 0.226); second point of third curve
); end interim command
); end if [no else - continue to next thirdd-point designation]
(command
(if (= ptno bsegs); third point of last curve in overall Bulge
(trans (vlax-curve-getEndPoint sntpath) 0 1)
(snpt 1.0 0); else - intermediate
); end if
); end command
(if (/= ptno bsegs) (setq side (- side))); for next bulge on other side of path
); end while
); end command - pline
;
(command "_.ucs" "_prev")
(setq
ucschanged nil ; eliminate UCS reset in *error* since routine did it already
*sn* (entlast); save result in case of recall of routine with PRevious or Flip option
); end setq
(entdel sntpath); remove temporary working path
(if (= *sndel* "Delete") (entdel *snpath*)); remove base path under Delete option
;
(if (and (wcmatch *sntype* "Existing,PRevious,Flip") (= *sndel* "Delete")) (command "_.layerp"))
; ^ reset Layer if appropriate
(if *isLocked* (command "_.layer" "_lock" *pathlay* "")); re-lock layer if appropriate
(snreset)
(princ)
); end defun - SNAKE
(prompt "Type DSL to make polyline-form snaking curve.")
(c:DSL)

Advertisements