Welcome,
Guest
. Please
login
or
register
.
1 Hour
1 Day
1 Week
1 Month
Forever
Login with username, password and session length
News:
Home
Help
Login
Register
TheSwamp
»
Code Red
»
AutoLISP (Vanilla / Visual)
»
Topic:
Very late tonight - can someone check the code - routine...
« previous
next »
Print
Pages: [
1
] |
Go Down
Author
Topic: Very late tonight - can someone check the code - routine... (Read 830 times)
0 Members and 1 Guest are viewing this topic.
ribarm
Gator
Posts: 3297
Marko Ribar, architect
WWW
Very late tonight - can someone check the code - routine...
«
on:
May 29, 2022, 05:46:43 PM »
Code - Auto/Visual Lisp:
[Select]
(
defun
c:stretch
-
all
-
vertices
-
polygon
-
lw
(
/
mid unit asin _chkptinside _triangcen _triangarea _centroid updatelw LM:3pcircle lw lwx ch1 ch2 ch3 lst pl pln bl bln cen mpl crl loop perc g dd ll k msg
)
(
defun
mid
(
p1 p2
)
(
mapcar
(
function
(
lambda
(
a b
)
(
/
(
+
a b
)
2.0
)
)
)
p1 p2
)
)
(
defun
unit
(
v
/
d
)
(
if
(
not
(
equal
(
setq
d
(
distance
(
list
0.0
0.0
0.0
)
v
)
)
0.0
1e
-
8
)
)
(
mapcar
(
function
(
lambda
(
x
)
(
/
x d
)
)
)
v
)
(
progn
(
prompt
"
\n
catched error in (unit) : vector strength almost none - equal 0.0..."
)
(
vl
-
catch
-
all
-
apply
(
function
/
)
(
list
1
0
)
)
)
)
)
(
defun
asin
(
x
)
(
cond
(
(
equal
x
1.0
1e
-
8
)
(
/
pi
2.0
)
)
(
(
equal
x
-
1.0
1e
-
8
)
(
*
3.0
(
/
pi
2.0
)
)
)
(
(
and
(
>
x
0
)
(
equal
x
0.0
1e
-
8
)
)
0.0
)
(
(
and
(
<
x
0
)
(
equal
x
-
0.0
1e
-
8
)
)
pi
)
(
(
atan
x
(
sqrt
(
-
1.0
(
*
x x
)
)
)
)
)
)
)
(
defun
_chkptinside
(
pt pl
/
ptn intpl
)
(
setq
ptn
(
mapcar
(
function
+
)
pt
(
list
1e
+
8
0.0
)
)
)
(
setq
intpl
(
mapcar
(
function
(
lambda
(
a b
)
(
inters
a b pt ptn t
)
)
)
pl
(
append
(
cdr
pl
)
(
list
(
car
pl
)
)
)
)
)
(
if
(
=
1
(
rem
(
length
intpl
)
2
)
)
t
)
)
(
defun
_triangcen
(
p1 p2 p3
)
(
inters
p1
(
mid p2 p3
)
p2
(
mid p1 p3
)
t
)
)
(
defun
_triangarea
(
p1 p2 p3
/
s d1 d2 d3
)
(
mapcar
(
function
set
)
'
(
d1 d2 d3
)
(
mapcar
(
function
(
lambda
(
a b
)
(
distance
a b
)
)
)
(
list
p1 p2 p3
)
(
list
p2 p3 p1
)
)
)
(
setq
s
(
/
(
+
d1 d2 d3
)
2.0
)
)
(
sqrt
(
*
s
(
-
s d1
)
(
-
s d2
)
(
-
s d3
)
)
)
)
(
defun
_centroid
(
pl bl
/
p1 p2 p3 trl cl al ar mom_x mom_y cen r
)
(
setq
pll pl
)
(
while
(
/=
(
length
pll
)
3
)
(
setq
p1
(
car
pll
)
p2
(
cadr
pll
)
)
(
foreach
p3
(
cddr
pll
)
(
if
(
_chkptinside
(
mid p1 p3
)
pl
)
(
setq
trl
(
cons
(
list
p1 p2 p3
)
trl
)
)
)
)
(
setq
pll
(
cdr
pll
)
)
)
(
if
(
=
(
length
pll
)
3
)
(
setq
trl
(
cons
pll trl
)
)
)
(
if
(
vl-every
(
function
zerop
)
bl
)
(
foreach
tr trl
(
setq
cl
(
cons
(
_triangcen
(
setq
p1
(
car
tr
)
)
(
setq
p2
(
cadr
tr
)
)
(
setq
p3
(
caddr
tr
)
)
)
cl
)
)
(
setq
al
(
cons
(
_triangarea p1 p2 p3
)
al
)
)
)
(
progn
(
prompt
"
\n
catched error in (_centroid) : picked LWPOLYLINE has arced segments (i.e. bl has some value different than 0.0)..."
)
(
setq
r
(
vl
-
catch
-
all
-
apply
(
function
/
)
(
list
1
0
)
)
)
)
)
(
if
(
not
r
)
(
progn
(
setq
ar
(
apply
(
function
+
)
al
)
)
(
setq
mom_x
(
apply
(
function
+
)
(
mapcar
(
function
(
lambda
(
a b
)
(
*
a b
)
)
)
(
mapcar
(
function
car
)
cl
)
al
)
)
)
(
setq
mom_y
(
apply
(
function
+
)
(
mapcar
(
function
(
lambda
(
a b
)
(
*
a b
)
)
)
(
mapcar
(
function
cadr
)
cl
)
al
)
)
)
(
setq
cen
(
list
(
/
mom_x ar
)
(
/
mom_y ar
)
)
)
)
r
)
)
(
defun
updatelw
(
lwx pl bl
)
(
if
bl
(
entupd
(
cdr
(
assoc
-
1
(
entmod
(
mapcar
(
function
(
lambda
(
a b c
)
(
cond
(
(
and
(
=
(
car
a
)
10
)
b
)
b
)
(
(
and
(
=
(
car
a
)
42
)
c
)
c
)
(
t a
)
)
)
)
lwx
(
mapcar
(
function
(
lambda
(
a
/
x
)
(
if
(
=
(
car
a
)
10
)
(
progn
(
setq
x
(
cons
10
(
car
pl
)
)
)
(
setq
pl
(
cdr
pl
)
)
x
)
)
)
)
lwx
)
(
mapcar
(
function
(
lambda
(
a
/
x
)
(
if
(
=
(
car
a
)
42
)
(
progn
(
setq
x
(
cons
42
(
car
bl
)
)
)
(
setq
bl
(
cdr
bl
)
)
x
)
)
)
)
lwx
)
)
)
)
)
)
(
entupd
(
cdr
(
assoc
-
1
(
entmod
(
mapcar
(
function
(
lambda
(
a b
)
(
if
(
and
(
=
(
car
a
)
10
)
b
)
b a
)
)
)
lwx
(
mapcar
(
function
(
lambda
(
a
/
x
)
(
if
(
=
(
car
a
)
10
)
(
progn
(
setq
x
(
cons
10
(
car
pl
)
)
)
(
setq
pl
(
cdr
pl
)
)
x
)
)
)
)
lwx
)
)
)
)
)
)
)
)
;; 3-Point Circle - Lee Mac
;; Returns the center (UCS) and radius of the circle defined by three supplied points (UCS).
(
defun
LM:3pcircle
(
pt1 pt2 pt3
/
cen md1 md2 vc1 vc2
)
(
if
(
and
(
setq
md1
(
mid pt1 pt2
)
)
(
setq
md2
(
mid pt2 pt3
)
)
(
setq
vc1
(
mapcar
(
function
-
)
pt2 pt1
)
)
(
setq
vc2
(
mapcar
(
function
-
)
pt3 pt2
)
)
(
setq
cen
(
inters
md1
(
mapcar
(
function
+
)
md1
(
list
(
-
(
cadr
vc1
)
)
(
car
vc1
)
)
)
md2
(
mapcar
(
function
+
)
md2
(
list
(
-
(
cadr
vc2
)
)
(
car
vc2
)
)
)
nil
)
)
)
(
list
cen
(
distance
cen pt1
)
)
)
)
(
if
(
and
(
setq
lw
(
car
(
entsel
"
\n
Pick CLOSED POLYGONAL LWPOLYLINE on unlocked layer..."
)
)
)
(
setq
lwx
(
entget
lw
)
)
(
=
(
cdr
(
assoc
0
lwx
)
)
"LWPOLYLINE"
)
(
=
1
(
logand
1
(
cdr
(
assoc
70
lwx
)
)
)
)
(
/=
4
(
logand
4
(
cdr
(
assoc
70
(
tblsearch
"LAYER"
(
cdr
(
assoc
8
lwx
)
)
)
)
)
)
)
(
vl-every
(
function
(
lambda
(
x
)
(
equal
x
(
cons
42
0.0
)
)
)
)
(
vl
-
remove
-
if
(
function
(
lambda
(
x
)
(
/=
(
car
x
)
42
)
)
)
lwx
)
)
)
(
progn
(
initget
"Straight Arced"
)
(
setq
ch1
(
getkword
"
\n
Choose option - keep current straightness or turn all to arced shape [Straight/Arced] <Straight> : "
)
)
(
if
(
not
ch1
)
(
setq
ch1
"Straight"
)
)
(
initget
"Percent Distance"
)
(
setq
ch2
(
getkword
"
\n
Choose option - stretch method [Percent/Distance] <Percent> : "
)
)
(
if
(
not
ch2
)
(
setq
ch2
"Percent"
)
)
(
initget
"Centroid Basepoint"
)
(
setq
ch3
(
getkword
"
\n
Choose option - use Centroid of LWPOLYLINE or pick Center base point [Centroid/Basepoint] <Centroid> : "
)
)
(
if
(
not
ch3
)
(
setq
ch3
"Centroid"
)
)
(
setq
msg
"left mouse click to finish, increase percentage : > ; decrease percentage : < ;; speed : 1,2,3,4,5,6,7,8,9..."
)
(
setq
lst
(
mapcar
(
function
cdr
)
(
vl
-
remove
-
if
-
not
(
function
(
lambda
(
x
)
(
vl-position
(
car
x
)
(
list
10
42
)
)
)
)
lwx
)
)
)
(
setq
pl
(
vl
-
remove
-
if
(
function
numberp
)
lst
)
)
(
setq
bl
(
vl
-
remove
-
if
-
not
(
function
numberp
)
lst
)
)
(
if
(
=
ch3
"Centroid"
)
(
setq
cen
(
_centroid pl bl
)
)
(
progn
(
initget
1
)
(
setq
cen
(
trans
(
getpoint
"
\n
Pick or specify Center base point : "
)
1
lw
)
)
)
)
(
setq
mpl
(
mapcar
(
function
(
lambda
(
a b
)
(
mid a b
)
)
)
pl
(
append
(
cdr
pl
)
(
list
(
car
pl
)
)
)
)
)
(
if
(
=
ch1
"Straight"
)
(
if
(
=
ch2
"Percent"
)
(
progn
(
setq
loop
1
)
(
setq
perc
100.0
)
(
prompt
(
strcat
"
\n
"
msg
"
\n
"
)
)
(
prompt
"
\n
Percent : "
)
(
princ
(
rtos
perc
2
20
)
)
(
while
(
/=
(
car
(
setq
g
(
grread
)
)
)
3
)
(
if
(
and
(
=
(
car
g
)
2
)
(
<
48
(
cadr
g
)
58
)
)
(
progn
(
setq
loop
(
-
(
cadr
g
)
48
)
)
(
prompt
"
\n
Speed : "
)
(
princ
loop
)
)
(
progn
(
prompt
(
strcat
"
\n
"
msg
)
)
(
repeat
loop
(
cond
(
(
equal
g
(
list
2
60
)
)
(
setq
perc
(
-
perc
(
*
loop
0.1
)
)
)
)
(
(
equal
g
(
list
2
62
)
)
(
setq
perc
(
+
perc
(
*
loop
0.1
)
)
)
)
)
(
prompt
"
\n
Percent : "
)
(
princ
(
rtos
perc
2
20
)
)
(
updatelw lwx
(
mapcar
(
function
(
lambda
(
p
)
(
mapcar
(
function
+
)
cen
(
mapcar
(
function
(
lambda
(
vc
)
(
*
vc
(
/
perc
100.0
)
)
)
)
(
mapcar
(
function
-
)
p cen
)
)
)
)
)
pl
)
nil
)
)
)
)
)
)
(
progn
(
setq
dd
(
cond
(
(
initget
6
)
)
(
(
setq
dd
(
getdist
"
\n
Pick or specify delta step distance <1.0> : "
)
)
)
(
t
1.0
)
)
)
(
setq
loop
1
ll
0.0
k
0
)
(
prompt
(
strcat
"
\n
"
msg
"
\n
"
)
)
(
prompt
"
\n
Distribution of delta distances : "
)
(
princ
k
)
(
prompt
"
\n
Delta step distance : "
)
(
princ
(
rtos
dd
2
20
)
)
(
prompt
"
\r
Total delta distances applied : "
)
(
princ
(
rtos
(
*
dd k
)
2
20
)
)
(
while
(
/=
(
car
(
setq
g
(
grread
)
)
)
3
)
(
if
(
and
(
=
(
car
g
)
2
)
(
<
48
(
cadr
g
)
58
)
)
(
progn
(
setq
loop
(
-
(
cadr
g
)
48
)
)
(
prompt
"
\n
Speed : "
)
(
princ
loop
)
)
(
progn
(
prompt
(
strcat
"
\n
"
msg
)
)
(
repeat
loop
(
cond
(
(
equal
g
(
list
2
60
)
)
(
setq
ll
(
-
ll
(
*
loop dd
)
)
k
(
-
k loop
)
)
)
(
(
equal
g
(
list
2
62
)
)
(
setq
ll
(
+
ll
(
*
loop dd
)
)
k
(
+
k loop
)
)
)
)
(
prompt
"
\n
Distribution of delta distances : "
)
(
princ
k
)
(
prompt
"
\n
Delta step distance : "
)
(
princ
(
rtos
dd
2
20
)
)
(
prompt
"
\r
Total delta distances applied : "
)
(
princ
(
rtos
(
*
dd k
)
2
20
)
)
(
updatelw lwx
(
mapcar
(
function
(
lambda
(
p
)
(
mapcar
(
function
+
)
cen
(
mapcar
(
function
(
lambda
(
vc
)
(
*
vc
(
+
(
distance
(
list
0.0
0.0
0.0
)
(
mapcar
(
function
-
)
p cen
)
)
ll
)
)
)
)
(
unit
(
mapcar
(
function
-
)
p cen
)
)
)
)
)
)
pl
)
nil
)
)
)
)
)
)
)
(
if
(
=
ch2
"Percent"
)
(
progn
(
setq
loop
1
)
(
setq
perc
100.0
)
(
prompt
(
strcat
"
\n
"
msg
"
\n
"
)
)
(
prompt
"
\n
Percent : "
)
(
princ
(
rtos
perc
2
20
)
)
(
while
(
/=
(
car
(
setq
g
(
grread
)
)
)
3
)
(
if
(
and
(
=
(
car
g
)
2
)
(
<
48
(
cadr
g
)
58
)
)
(
progn
(
setq
loop
(
-
(
cadr
g
)
48
)
)
(
prompt
"
\n
Speed : "
)
(
princ
loop
)
)
(
progn
(
prompt
(
strcat
"
\n
"
msg
)
)
(
repeat
loop
(
cond
(
(
equal
g
(
list
2
60
)
)
(
setq
perc
(
-
perc
(
*
loop
0.1
)
)
)
)
(
(
equal
g
(
list
2
62
)
)
(
setq
perc
(
+
perc
(
*
loop
0.1
)
)
)
)
)
(
setq
pln
(
mapcar
(
function
(
lambda
(
p
)
(
mapcar
(
function
+
)
cen
(
mapcar
(
function
(
lambda
(
vc
)
(
*
vc
(
/
perc
100.0
)
)
)
)
(
mapcar
(
function
-
)
p cen
)
)
)
)
)
pl
)
)
(
if
(
=
perc
100.0
)
(
setq
bln
nil
)
(
progn
(
setq
crl
(
mapcar
(
function
(
lambda
(
p1 p2 p3
)
(
LM:3pcircle p1 p2 p3
)
)
)
pln mpl
(
append
(
cdr
pln
)
(
list
(
car
pln
)
)
)
)
)
(
setq
bln
(
mapcar
(
function
(
lambda
(
p1 c p2
)
(
if
(
>
perc
100.0
)
(
-
(
abs
(
/
(
sin
(
/
(
setq
a
(
*
2.0
(
asin
(
/
(
/
(
distance
p1 p2
)
2.0
)
(
cadr
c
)
)
)
)
)
4.0
)
)
(
cos
(
/
a
4.0
)
)
)
)
)
(
abs
(
/
(
sin
(
/
(
setq
a
(
*
2.0
(
asin
(
/
(
/
(
distance
p1 p2
)
2.0
)
(
cadr
c
)
)
)
)
)
4.0
)
)
(
cos
(
/
a
4.0
)
)
)
)
)
)
)
pln crl
(
append
(
cdr
pln
)
(
list
(
car
pln
)
)
)
)
)
)
)
(
prompt
"
\n
Percent : "
)
(
princ
(
rtos
perc
2
20
)
)
(
updatelw lwx pln bln
)
)
)
)
)
)
(
progn
(
setq
dd
(
cond
(
(
initget
6
)
)
(
(
setq
dd
(
getdist
"
\n
Pick or specify delta step distance <1.0> : "
)
)
)
(
t
1.0
)
)
)
(
setq
loop
1
ll
0.0
k
0
)
(
prompt
(
strcat
"
\n
"
msg
"
\n
"
)
)
(
prompt
"
\n
Distribution of delta distances : "
)
(
princ
k
)
(
prompt
"
\n
Delta step distance : "
)
(
princ
(
rtos
dd
2
20
)
)
(
prompt
"
\r
Total delta distances applied : "
)
(
princ
(
rtos
(
*
dd k
)
2
20
)
)
(
while
(
/=
(
car
(
setq
g
(
grread
)
)
)
3
)
(
if
(
and
(
=
(
car
g
)
2
)
(
<
48
(
cadr
g
)
58
)
)
(
progn
(
setq
loop
(
-
(
cadr
g
)
48
)
)
(
prompt
"
\n
Speed : "
)
(
princ
loop
)
)
(
progn
(
prompt
(
strcat
"
\n
"
msg
)
)
(
repeat
loop
(
cond
(
(
equal
g
(
list
2
60
)
)
(
setq
ll
(
-
ll
(
*
loop dd
)
)
k
(
-
k loop
)
)
)
(
(
equal
g
(
list
2
62
)
)
(
setq
ll
(
+
ll
(
*
loop dd
)
)
k
(
+
k loop
)
)
)
)
(
setq
pln
(
mapcar
(
function
(
lambda
(
p
)
(
mapcar
(
function
+
)
cen
(
mapcar
(
function
(
lambda
(
vc
)
(
*
vc
(
+
(
distance
(
list
0.0
0.0
0.0
)
(
mapcar
(
function
-
)
p cen
)
)
ll
)
)
)
)
(
unit
(
mapcar
(
function
-
)
p cen
)
)
)
)
)
)
pl
)
)
(
if
(
=
k
0
)
(
setq
bln
nil
)
(
progn
(
setq
crl
(
mapcar
(
function
(
lambda
(
p1 p2 p3
)
(
LM:3pcircle p1 p2 p3
)
)
)
pln mpl
(
append
(
cdr
pln
)
(
list
(
car
pln
)
)
)
)
)
(
setq
bln
(
mapcar
(
function
(
lambda
(
p1 c p2
)
(
if
(
>
perc
100.0
)
(
-
(
abs
(
/
(
sin
(
/
(
setq
a
(
*
2.0
(
asin
(
/
(
/
(
distance
p1 p2
)
2.0
)
(
cadr
c
)
)
)
)
)
4.0
)
)
(
cos
(
/
a
4.0
)
)
)
)
)
(
abs
(
/
(
sin
(
/
(
setq
a
(
*
2.0
(
asin
(
/
(
/
(
distance
p1 p2
)
2.0
)
(
cadr
c
)
)
)
)
)
4.0
)
)
(
cos
(
/
a
4.0
)
)
)
)
)
)
)
pln crl
(
append
(
cdr
pln
)
(
list
(
car
pln
)
)
)
)
)
)
)
(
prompt
"
\n
Distribution of delta distances : "
)
(
princ
k
)
(
prompt
"
\n
Delta step distance : "
)
(
princ
(
rtos
dd
2
20
)
)
(
prompt
"
\r
Total delta distances applied : "
)
(
princ
(
rtos
(
*
dd k
)
2
20
)
)
(
updatelw lwx pln bln
)
)
)
)
)
)
)
)
)
(
prompt
"
\n
Missed or wrong entity picked (not CLOSED POLYGONAL LWPOLYLINE on unlocked layer)..."
)
)
(
princ
)
)
Something's not doing well and I am tired now...
Please, help us if you are available...
M.R.
[EDIT : Code fixed and updated...]
«
Last Edit: May 30, 2022, 02:51:08 AM by ribarm
»
Logged
Marko Ribar, d.i.a.
(graduated engineer of architecture)
M.R. on Youtube
ribarm
Gator
Posts: 3297
Marko Ribar, architect
WWW
Re: Very late tonight - can someone check the code - routine...
«
Reply #1 on:
May 30, 2022, 01:26:00 AM »
Sorry for the delay, I was tired yesterday...
Code fixed now - updated first post...
HTH. M.R.
Logged
Marko Ribar, d.i.a.
(graduated engineer of architecture)
M.R. on Youtube
d2010
Bull Frog
Posts: 326
WWW
Re: Very late tonight - can someone check the code - routine...
«
Reply #2 on:
May 30, 2022, 12:21:36 PM »
Please,You upload a sample Before.dwg and After.dwg
Please you make a tiny Demo, how to use?
Logged
Print
Pages: [
1
] |
Go Up
« previous
next »
TheSwamp
»
Code Red
»
AutoLISP (Vanilla / Visual)
»
Topic:
Very late tonight - can someone check the code - routine...
