(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 ())))))
|#

