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
|
(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 project (pln bod)
(let* (Vfaces Ifaces Contour-edges contour-edge-loops Contour-vertices
(vnormal (send pln :normal)) (-vnormal (v- vnormal))
x y loop shadow-contours)
(dolist (f (send bod :faces))
(if (eps<= (v. vnormal (plane-normal f)) 0.0 0.01)
(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)))) )))
(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))
(push y loop)
(if (eq (second (second y)) x)
(setq x (second (third y)))
(setq x (second (second y)))) )
(push (nreverse loop) contour-edge-loops))
(nreverse contour-edge-loops)
(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-intersection3 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)
(let* ((segments (mapcar #'cadr
(apply #'append (mapcar #'cdr edge-loop))))
new-loop p (p1 (pop segments)) flag kill)
(setq segments (append segments (list p1)))
(dolist (s segments)
(setq p (scale 0.5 (v+ p1 s)))
(setq kill nil)
(dolist (f Vfaces)
(when (eq (send f :intersect-point-vector p -vnormal)
:inside)
(setq kill t)
(return t)))
(unless kill
(dolist (f Ifaces)
(when (eq (send f :intersect-point-vector p vnormal)
:inside)
(setq kill t)
(return t))))
(unless kill (push s new-loop)))
(push (nreverse new-loop) shadow-contours)))
shadow-contours))
#|
(let* ((e1 (car edge-loop))
(p (scale 0.5 (v+ (second (second e1)) (second (third e1)))))
kill new-loop)
(if (or (send bod :faces-intersect-with-point-vector p vnormal)
(send bod :faces-intersect-with-point-vector p -vnormal))
(setq kill t))
(dolist (e edge-loop)
(cond (kill
(if ())))))
|#
|
