Topic: 4 point mass objects (some idea)

[lamarn]

I found This Video uploaded today.
Liked the Idea. Sometimes i use a routine to fill holes in 3d.
But This concepts goed further Than that and lets You choose the primitive shape.
Would This be possible to programm? ..just a thought..
Kind regards
Hans

https://m.youtube.com/watch?v=ZQ6FkBntuq4&a=&feature=youtu.be

[ribarm]

Yes, it would be very possible to program this...

[lamarn]

I allready thought ribarm would have a reply on this one.. Here's code i use for filling holes. 4-point solid.
It is not mine and i failed to archived the author sadly. For me it works but i could images someones might be better of with a 'v2.0' of such code.
I am not a great programmer but as stated, i might be good for inspirations..
Kind regards
Hans

Code: [Select]

(defun C:4PS () (4ps))
(defun 4PS (/      TORF   P1     P1X    P1Y    P1Z    P2     P2X
              P2Y    P2Z    P3     P3X    P3Y    P3Z    P4     P4X
              P4Y    P4Z    P5     P5X    P5Y    P5Z    P6     P6X
              P6Y    P6Z    P7     P7X    P7Y    P7Z    GDIST  DELTAX
              DELTAY DELTAZ BOXDIA TRIMBOX       MID12X MID12Y MID12Z
              MID34X MID34Y MID34Z MID56X MID56Y MID56Z XMIN   XMAX
              YMIN   YMAX   ZMIN   ZMAX
             )
  (setq TORF nil)
  (setq P1 (getpoint "\nPick First Point: "))
  (setq P2 (getpoint P1 "\nPick Second Point: "))
  (setq P3 (getpoint P2 "\nPick Third Point: "))
  (setq P4 (getpoint P3 "\nPick Final Point: "))
  (setq OLDSNAP (getvar "osmode"))
  (setvar "osmode" 0)
  (prompt "\nComputing...")
 ;--------------------
  (setq P1X (car P1))
  (setq P1Y (cadr P1))
  (setq P1Z (caddr P1))
  (setq P2X (car P2))
  (setq P2Y (cadr P2))
  (setq P2Z (caddr P2))
  (setq P3X (car P3))
  (setq P3Y (cadr P3))
  (setq P3Z (caddr P3))
  (setq P4X (car P4))
  (setq P4Y (cadr P4))
  (setq P4Z (caddr P4))
 ;--------------------
  (setq MID12X (/ (+ P1X P2X) 2))
  (setq MID12Y (/ (+ P1Y P2Y) 2))
  (setq MID12Z (/ (+ P1Z P2Z) 2))
  (setq MID34X (/ (+ P3X P4X) 2))
  (setq MID34Y (/ (+ P3Y P4Y) 2))
  (setq MID34Z (/ (+ P3Z P4Z) 2))
 ;--------------------
  (setq P5 (list MID12X MID12Y MID12Z))
 ;--------------------
  (setq P6 (list MID34X MID34Y MID34Z))
 ;--------------------
  (setq MID56X (/ (+ MID12X MID34X) 2))
  (setq MID56Y (/ (+ MID12Y MID34Y) 2))
  (setq MID56Z (/ (+ MID12Z MID34Z) 2))
  (setq P7 (list MID56X MID56Y MID56Z))
 ;----------------
  (setq XMIN P1X)
  (setq TORF (<= P2X XMIN))
  (if (= TORF T)
    (progn (setq XMIN P2X))
  )
  (setq TORF nil) ; if
  (setq TORF (<= P3X XMIN))
  (if (= TORF T)
    (progn (setq XMIN P3X))
  )
  (setq TORF nil) ; if
  (setq TORF (<= P4X XMIN))
  (if (= TORF T)
    (progn (setq XMIN P4X))
  )
  (setq TORF nil) ; if
 ;----------------
  (setq YMIN P1Y)
  (setq TORF (<= P2Y YMIN))
  (if (= TORF T)
    (progn (setq YMIN P2Y))
  )
  (setq TORF nil) ; if
  (setq TORF (<= P3Y YMIN))
  (if (= TORF T)
    (progn (setq YMIN P3Y))
  )
  (setq TORF nil) ; if
  (setq TORF (<= P4Y YMIN))
  (if (= TORF T)
    (progn (setq YMIN P4Y))
  )
  (setq TORF nil) ; if
 ;----------------
  (setq ZMIN P1Z)
  (setq TORF (<= P2Z ZMIN))
  (if (= TORF T)
    (progn (setq ZMIN P2Z))
  )
  (setq TORF nil) ; if
  (setq TORF (<= P3Z ZMIN))
  (if (= TORF T)
    (progn (setq ZMIN P3Z))
  )
  (setq TORF nil) ; if
  (setq TORF (<= P4Z ZMIN))
  (if (= TORF T)
    (progn (setq ZMIN P4Z))
  )
  (setq TORF nil) ; if
 ;----------------
  (setq XMAX P1X)
  (setq TORF (>= P2X XMAX))
  (if (= TORF T)
    (progn (setq XMAX P2X))
  )
  (setq TORF nil) ; if
  (setq TORF (>= P3X XMAX))
  (if (= TORF T)
    (progn (setq XMAX P3X))
  )
  (setq TORF nil) ; if
  (setq TORF (>= P4X XMAX))
  (if (= TORF T)
    (progn (setq XMAX P4X))
  )
  (setq TORF nil) ; if
 ;----------------
  (setq YMAX P1Y)
  (setq TORF (>= P2Y YMAX))
  (if (= TORF T)
    (progn (setq YMAX P2Y))
  )
  (setq TORF nil) ; if
  (setq TORF (>= P3Y YMAX))
  (if (= TORF T)
    (progn (setq YMAX P3Y))
  )
  (setq TORF nil) ; if
  (setq TORF (>= P4Y YMAX))
  (if (= TORF T)
    (progn (setq YMAX P4Y))
  )
  (setq TORF nil) ; if
 ;----------------
  (setq ZMAX P1Z)
  (setq TORF (>= P2Z ZMAX))
  (if (= TORF T)
    (progn (setq ZMAX P2Z))
  )
  (setq TORF nil) ; if
  (setq TORF (>= P3Z ZMAX))
  (if (= TORF T)
    (progn (setq ZMAX P3Z))
  )
  (setq TORF nil) ; if
  (setq TORF (>= P4Z ZMAX))
  (if (= TORF T)
    (progn (setq ZMAX P4Z))
  )
  (setq TORF nil) ; if
 ;----------------
  (setq DELTAX (abs (- XMAX XMIN)))
  (setq DELTAY (abs (- YMAX YMIN)))
  (setq DELTAZ (abs (- ZMAX ZMIN)))
 ;----------------
  (setq GDIST DELTAX)
  (setq TORF (>= DELTAY GDIST))
  (if (= TORF T)
    (progn (setq GDIST DELTAY))
  )
  (setq TORF nil) ; if
  (setq TORF (>= DELTAZ GDIST))
  (if (= TORF T)
    (progn (setq GDIST DELTAZ))
  )
  (setq TORF nil) ; if
 ;----------------
  (setq BOXDIA (* GDIST 2.25))
 ; arbitrary value, larger than the possible object
 ;----------------
 ; Draw box
  (command "BOX" "c" P7 "c" BOXDIA)
  (setq TRIMBOX (ssget "l"))
  (command "SLICE" TRIMBOX "" "3" P1 P2 P3 P7)
  (command "SLICE" TRIMBOX "" "3" P1 P2 P4 P7)
  (command "SLICE" TRIMBOX "" "3" P1 P3 P4 P7)
  (command "SLICE" TRIMBOX "" "3" P2 P3 P4 P7)
  (setvar "osmode" OLDSNAP)
 ;
  (princ)
) ; defun 4P

(princ)

[ribarm]

Here, try this, but not tested at all and you'll have to have A2012+ - means that for tetrahedron it should support SURFSCULPT command...

Code - Auto/Visual Lisp: [Select]

1. (defun c:4pprimitive ( / mid v^v unit coplanar-p ucsf p1 p2 p3 p4 ch
2.                             mp1p2 mp2p3 v12 v23 c r h ucsff
3.                             ca va cb vb mp1p4 v14
4.                             el ss
5.                         )
6.   (defun mid ( a b )
7.     (mapcar '(lambda ( x y ) (/ (+ x y) 2.0)) a b)
8.   )
9.  
10.   (defun v^v ( u v )
11.     (list
12.       (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
13.       (- (* (caddr u) (car v)) (* (car u) (caddr v)))
14.       (- (* (car u) (cadr v)) (* (cadr u) (car v)))
15.     )
16.   )
17.  
18.   (defun unit ( v )
19.     (if (not (equal v '(0.0 0.0 0.0) 1e-6))
20.       (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
21.     )
22.   )
23.  
24.   (defun coplanar-p ( p1 p2 p3 p4 )
25.     (if (and (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))) (unit (v^v (mapcar '- p2 p1) (mapcar '- p4 p1))) (unit (v^v (mapcar '- p3 p1) (mapcar '- p4 p1))) (unit (v^v (mapcar '- p3 p2) (mapcar '- p4 p2))))
26.       (equal (v^v (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))) (unit (v^v (mapcar '- p2 p1) (mapcar '- p4 p1)))) '(0.0 0.0 0.0) 1e-6)
27.       (progn
28.         (prompt "\nSome 3 point sequence resulting in collinearity... Please specify correct points... Quitting...")
29.         (exit)
30.       )
31.     )
32.   )
33.  
34.   (if (eq (getvar 'worlducs) 0)
35.     (progn
36.       (command "_.UCS" "_W")
37.       (setq ucsf t)
38.     )
39.   )
40.   (if (null *p1*)
41.     (progn
42.       (setq p1 (getpoint "\nFirst point of base : "))
43.       (setq *p1* p1)
44.     )
45.     (progn
46.       (setq p1 (getpoint (strcat "\nFirst point of base <" (vl-prin1-to-string *p1*) "> : ")))
47.       (if (null p1)
48.         (setq p1 *p1*)
49.         (setq *p1* p1)
50.       )
51.     )
52.   )
53.   (if (null *p2*)
54.     (progn
55.       (setq p2 (getpoint "\nSecond point of base : "))
56.       (setq *p2* p2)
57.     )
58.     (progn
59.       (setq p2 (getpoint (strcat "\nSecond point of base <" (vl-prin1-to-string *p2*) "> : ")))
60.       (if (null p2)
61.         (setq p2 *p2*)
62.         (setq *p2* p2)
63.       )
64.     )
65.   )
66.   (if (null *p3*)
67.     (progn
68.       (setq p3 (getpoint "\nThird point of base : "))
69.       (setq *p3* p3)
70.     )
71.     (progn
72.       (setq p3 (getpoint (strcat "\nThird point of base <" (vl-prin1-to-string *p3*) "> : ")))
73.       (if (null p3)
74.         (setq p3 *p3*)
75.         (setq *p3* p3)
76.       )
77.     )
78.   )
79.  
80.   (if (null *p4*)
81.     (progn
82.       (setq p4 (getpoint "\nFourth point OUT of base : "))
83.       (setq *p4* p4)
84.     )
85.     (progn
86.       (setq p4 (getpoint (strcat "\nFourth point OUT of base <" (vl-prin1-to-string *p4*) "> : ")))
87.       (if (null p4)
88.         (setq p4 *p4*)
89.         (setq *p4* p4)
90.       )
91.     )
92.   )
93.  
94.   (if (coplanar-p p1 p2 p3 p4)
95.     (progn
96.       (prompt "\nAll specified points lie in plane... Please specify correct points... Quitting...")
97.       (exit)
98.     )
99.     (progn
100.       (initget 1 "Cylinder Sphere Tetrahedron")
101.       (setq ch (getkword "\nChoose primitive type [Cylinder/Sphere/Tetrahedron] : "))
102.       (cond
103.         ( (eq ch "Cylinder")
104.           (setq mp1p2 (mid p1 p2))
105.           (setq mp2p3 (mid p2 p3))
106.           (setq v12 (v^v (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)) (mapcar '- p2 p1)))
107.           (setq v23 (v^v (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)) (mapcar '- p3 p2)))
108.           (setq c (inters mp1p2 (mapcar '+ mp1p2 v12) mp2p3 (mapcar '+ mp2p3 v23) nil))
109.           (setq r (distance c p1))
110.           (setq h (abs (- (caddr (trans p4 0 (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))) (caddr (trans p1 0 (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))))))
111.           (command "_.UCS" "_3P" "_non" c "_non" p1 "_non" p2)
112.           (if (< (caddr (trans p4 0 1)) 0.0)
113.             (progn
114.               (command "_.UCS" "_Y" 180.0)
115.               (setq ucsff t)
116.             )
117.           )
118.           (command "_.CYLINDER" "_non" '(0.0 0.0 0.0) r h)
119.           (if ucsff
120.             (progn
121.               (command "_.UCS" "_P")
122.               (command "_.UCS" "_P")
123.             )
124.             (command "_.UCS" "_P")
125.           )
126.         )
127.         ( (eq ch "Sphere")
128.           (setq mp1p2 (mid p1 p2))
129.           (setq mp2p3 (mid p2 p3))
130.           (setq v12 (v^v (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)) (mapcar '- p2 p1)))
131.           (setq v23 (v^v (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)) (mapcar '- p3 p2)))
132.           (setq cb (inters mp1p2 (mapcar '+ mp1p2 v12) mp2p3 (mapcar '+ mp2p3 v23) nil))
133.           (setq vb (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)))
134.           (setq v12 (v^v (v^v (mapcar '- p2 p1) (mapcar '- p4 p1)) (mapcar '- p2 p1)))
135.           (setq mp1p4 (mid p1 p4))
136.           (setq v14 (v^v (v^v (mapcar '- p2 p1) (mapcar '- p4 p1)) (mapcar '- p4 p1)))
137.           (setq ca (inters mp1p2 (mapcar '+ mp1p2 v12) mp1p4 (mapcar '+ mp1p4 v14) nil))
138.           (setq va (v^v (mapcar '- p2 p1) (mapcar '- p4 p1)))
139.           (setq c (inters ca (mapcar '+ ca va) cb (mapcar '+ cb vb) nil))
140.           (setq r (distance c p1))
141.           (command "_.SPHERE" "_non" c r)
142.         )
143.         ( (eq ch "Tetrahedron")
144.           (setq ss (ssadd))
145.           (ssadd (entmakex (list '(0 . "3DFACE") (cons 10 p1) (cons 11 p1) (cons 12 p2) (cons 13 p3))) ss)
146.           (ssadd (entmakex (list '(0 . "3DFACE") (cons 10 p1) (cons 11 p1) (cons 12 p2) (cons 13 p4))) ss)
147.           (ssadd (entmakex (list '(0 . "3DFACE") (cons 10 p1) (cons 11 p1) (cons 12 p3) (cons 13 p4))) ss)
148.           (ssadd (entmakex (list '(0 . "3DFACE") (cons 10 p2) (cons 11 p2) (cons 12 p3) (cons 13 p4))) ss)
149.           (setq el (entlast))
150.           (command "_.REGION" ss "")
151.           (setq ss (ssadd))
152.           (while (setq el (entnext el))
153.             (ssadd el ss)
154.           )
155.           (command "_.SURFSCULPT" ss "")
156.           (while (< 0 (getvar 'cmdacitve)) (command ""))
157.         )
158.       )
159.     )
160.   )
161.   (if ucsf
162.     (command "_.UCS" "_P")
163.   )
164.   (princ)
165. )
166.  

HTH, M.R.

[EDIT : Now tested - found some lacks, should work as desired now...]

[Jochen]

Just an old idea:

Code: [Select]

(defun C:tetra(/ p1 p2 p3 p4  pliste bbox)

  (setq p1 (getpoint "\npick P1"))
  (setq p2 (getpoint "\npick P2"))
  (setq p3 (getpoint "\npick P3"))
  (setq p4 (getpoint "\npick P4"))

  (setq osmode_alt (getvar "osmode"))
  (command "_osmode" 0)

; Bounding box nach Idee vom macar (cad.de) für beliebige Punktliste pliste
  (setq pliste (list  p1 p2 p3 p4))

  (setq bbox
(list (mapcar'(lambda(s)(apply'min(mapcar s pliste)))'(car cadr caddr))
      (mapcar'(lambda(s)(apply'max(mapcar s pliste)))'(car cadr caddr))
)
  )

  (command "_box" (car bbox) (cadr bbox))
 
  (command "_slice" "_L" "" "_3P" p1 p2 p3 p4)
  (command "_slice" "_L" "" "_3P" p2 p3 p4 p1)
  (command "_slice" "_L" "" "_3P" p3 p4 p1 p2)
  (command "_slice" "_L" "" "_3P" p4 p1 p2 p3)

  (command "_osmode" osmode_alt)
)
Regards
Jochen

[lamarn]

Thank both of you!
I am really happy with this piece of code.
Makes my 3D working life just a little easier..
Thanks Ribarm!