1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
(list "@(#)$Id: sweep.l,v 1.1.1.1 2003/11/20 07:46:29 eus Exp $")
(defun sweep-body (bod direction length)
"(bod direction length) returns a body made by sweeping the convex-hull
points of BOD in DIRECTION"
(let* ((pnt (send bod :extream-point (scale -1.0 direction)))
(projection-plane (make-plane :normal direction :point pnt))
(contour-points
(mapcar #'(lambda (v) (send projection-plane :project v))
(send bod :vertices))))
; (setq *points* (remove-duplicates contour-points :test #'equal))
(make-prism (reverse (quickhull contour-points direction))
(scale length direction))))
(defun remove-inner-loop (Vfaces Ifaces direction edge-loop)
"Visible-faces Invisible-faces normal edge-loop:
((edge1 (param1 point1) (param2 point2)) (edge2 (param2 ...)))"
(let* ((kill nil)
(tracep1 edge-loop)
(tracep2 (cdar tracep1))
(tracing-edge (caar tracep1))
flag
(adjfaces (list (send tracing-edge :pface)
(send tracing-edge :nface)))
(-direction (v- direction))
px midp new-loop result)
(labels ((next-point ()
(cond ((cdr tracep2)
(prog1 tracep2 (setq tracep2 (cdr tracep2))))
((cdr tracep1)
(setq tracep1 (cdr tracep1)
tracep2 (cdar tracep1)
tracing-edge (caar tracep1)
adjfaces (list (send tracing-edge :pface)
(send tracing-edge :nface)))
(prog1 tracep2 (setq tracep2 (cdr tracep2))))
(t nil)))
(inner-point-p (p &aux flag flag2)
(dolist (f Ifaces)
(unless (memq f adjfaces)
(setq flag (send f :intersect-point-vector
p direction))
(cond ((eql (car flag) :inside)
(return-from inner-point-p :inside))
((eq (car flag) :border)
(setq flag2 flag))) ) )
(dolist (f Vfaces)
(unless (memq f adjfaces)
(setq flag (send f :intersect-point-vector
p -direction))
(cond ((eql (car flag) :inside)
(return-from inner-point-p :inside))
((eql (car flag) :border)
(setq flag2 flag))) ) )
(if flag2 (car flag2))
:outside )
(connect-lines (l1 l2)
(cond ((eps= (line-nvert l1) (line-pvert l2))
(setf (line-nvert l1) (line-nvert l2)))
((eps= (line-nvert l1) (line-nvert l2))
(setf (line-nvert l1) (line-pvert l2)))
((eps= (line-pvert l1) (line-nvert l2))
(setf (line-pvert l1) (line-pvert l2)))
((eps= (line-pvert l1) (line-pvert l2))
(setf (line-pvert l1) (line-nvert l2))))
l1))
(cond ((some #'cdddr edge-loop)
(print "intersection")
(while (setq px (next-point))
(setq midp (midpoint 0.5 (second (first px)) (second (second px))))
(setq flag (inner-point-p midp))
(unless (eql flag :inside)
(push (second (car px)) new-loop)))
(setq new-loop (cons (car new-loop) (nreverse new-loop)))
(while (cdr new-loop)
(push (make-line (pop new-loop) (car new-loop)) result)))
(t
(print "no intersection")
(setq px (next-point))
(setq midp (midpoint 0.5 (second (first px)) (second (second px))))
(setq flag (inner-point-p midp))
(if (eql flag :inside)
nil
(progn
(setq new-loop (cons (cadr (cadr (car edge-loop)))
(mapcar #'(lambda (x) (cadr (caddr x))) edge-loop)))
(while (cdr new-loop)
(push (make-line (pop new-loop) (car new-loop))
result)))) ))
(setq new-loop nil)
(let* ((loop (nreverse result))
(l1 (pop loop)) l2)
(while loop
(if (send l1 :colinear-line (setq l2 (pop loop)) 0.001)
(setq l1 (connect-lines l1 l2) l2 nil)
(progn (push l1 new-loop)
(setq l1 l2)) ))
(cond (new-loop
(setq l2 (car (last new-loop)))
(cond ((send l1 :colinear-line l2) (connect-lines l2 l1))
(t (push l1 new-loop)))
(instance polygon :init :edges (nreverse new-loop)) ))
))))
(defun project (bod pln)
(let* (Vfaces Ifaces Contour-edges contour-edge-loops Contour-vertices
(vnormal (send pln :normal)) (-vnormal (v- vnormal))
x y loop shadow-loops shadows)
(dolist (f (send bod :faces))
(if (eps< (v. vnormal (plane-normal f)) 0.0 )
(push f Vfaces)
(push f Ifaces)))
(dolist (e (send bod :edges))
(if (or (and (member (edge-pface e) Vfaces)
(member (edge-nface e) Ifaces))
(and (member (edge-nface e) Vfaces)
(member (edge-pface e) Ifaces)))
(push (list e) contour-edges)))
(dolist (e contour-edges)
(let ((pv (edge-pvert (car e))) (nv (edge-nvert (car e))) x)
(unless (assoc pv contour-vertices)
(push (list pv (send pln :project pv)) contour-vertices))
(unless (assoc nv contour-vertices)
(push (list nv (send pln :project nv)) contour-vertices))) )
(dolist (e contour-edges)
(let ((pv (edge-pvert (car e))) (nv (edge-nvert (car e))))
(nconc e (list (list 0.0 (cadr (assoc pv contour-vertices))))
(list (list 1.0 (cadr (assoc nv contour-vertices)))) )))
;; find closed loops
(while contour-edges
(setq loop nil)
(setq x (pop contour-edges))
(push x loop)
(setq x (second (third x)))
(while (setq y (find-if
#'(lambda (ce) (or (eq (second (second ce)) x)
(eq (second (third ce)) x)) )
contour-edges))
(setq contour-edges (delete y contour-edges :count 1))
(unless (eq (second (second y)) x)
(setq y (list (car y) (list 0.0 (second (third y)))
(list 1.0 (second (second y))))) )
(setq x (second (third y)))
(push y loop))
(push (nreverse loop) contour-edge-loops))
(nreverse contour-edge-loops)
;; find intersections
(dolist (edge-loop contour-edge-loops)
(do-combination (e1 e2 edge-loop)
(let* ((pv1 (second (second e1)))
(nv1 (second (third e1)))
(pv2 (second (second e2)))
(nv2 (second (third e2)))
(intersects (line-intersection #|3|# pv1 nv1 pv2 nv2))
param1 param2 point)
(when intersects
(setq param1 (first intersects)
param2 (second intersects))
(setq point (midpoint param1 pv1 nv1))
(when (and (eps< 0.0 param1) (eps< param1 1.0)
(eps< 0.0 param2) (eps< param2 1.0))
(setq point (midpoint param1 pv1 nv1))
(nconc e1 (list (list param1 point)))
(nconc e2 (list (list param2 point)))))
)
)
(dolist (elist edge-loop)
(rplacd elist (sort (cdr elist) #'<= #'first)))
)
(dolist (edge-loop contour-edge-loops)
(setq loop
(remove-inner-loop Vfaces Ifaces vnormal edge-loop))
(if loop (push loop shadow-loops)))
;; (do-combination (s1 s2 (nreverse shadow-loops)))
(nreverse shadow-loops) ) )
|
