Menu
▾
▴
euslisp-commit
|
From: <k-...@us...> - 2013-04-18 14:15:53
|
Revision: 607
http://sourceforge.net/p/euslisp/code/607
Author: k-okada
Date: 2013-04-18 14:15:43 +0000 (Thu, 18 Apr 2013)
Log Message:
-----------
move enclosed-vertexp from jsk, update convex-hull-3d based on convex-hull-3d-old of primtpatch.l
Modified Paths:
--------------
trunk/EusLisp/lisp/geo/primt.l
Modified: trunk/EusLisp/lisp/geo/primt.l
===================================================================
--- trunk/EusLisp/lisp/geo/primt.l 2013-04-16 06:48:00 UTC (rev 606)
+++ trunk/EusLisp/lisp/geo/primt.l 2013-04-18 14:15:43 UTC (rev 607)
@@ -332,6 +332,13 @@
;; convexhull using gift-wrapping algorithm
;;
+(defun enclosed-vertexp (v) ;; v=(#f() #<edge..> #<edge..>...)
+ (let ((result t))
+ (dolist (e (cdr v))
+ (setq result (and (e . pface)(e . nface) result))
+ )
+ (and (cdr v) result)))
+
(defun convex-hull-3d (vertices)
"ARGS = (vertices)
Create a body of convex-hull from a list of vertices"
@@ -390,8 +397,15 @@
(setq newedges (send newface :edges))
(dolist (ne newedges)
(if (memq ne edgeq)
- (setq edgeq (delete ne edgeq))
- (setq edgeq (cons ne edgeq))))
+ (progn
+ (setq edgeq (delete ne edgeq))
+ (let ((ver))
+ (dolist (v (send ne :vertices))
+ (setq ver (find v *vertices* :key #'car))
+ (if (enclosed-vertexp ver)
+ (setq *vertices* (delete ver *vertices* :count 1 )
+ )))))
+ (setq edgeq (append edgeq (list ne)))))
(setq faceq (cons newface faceq))
(nconc *faces* (list newface))
(if *debug* (print (length *faces* )))
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <k-...@us...> - 2013-04-22 15:02:06
|
Revision: 618
http://sourceforge.net/p/euslisp/code/618
Author: k-okada
Date: 2013-04-22 15:02:00 +0000 (Mon, 22 Apr 2013)
Log Message:
-----------
use searched-edgeq, impremented as convex-hull-3d-ol of primptpatch.l
Modified Paths:
--------------
trunk/EusLisp/lisp/geo/primt.l
Modified: trunk/EusLisp/lisp/geo/primt.l
===================================================================
--- trunk/EusLisp/lisp/geo/primt.l 2013-04-22 13:10:57 UTC (rev 617)
+++ trunk/EusLisp/lisp/geo/primt.l 2013-04-22 15:02:00 UTC (rev 618)
@@ -350,6 +350,7 @@
(newbody)
(faceq)
(edgeq)
+ (searched-edgeq)
(searched-v)
)
(setq *points* vertices
@@ -396,16 +397,29 @@
p1 p2 p3 (set-difference *vertices* searched-v :key #'car)))
(setq newedges (send newface :edges))
(dolist (ne newedges)
- (if (memq ne edgeq)
- (progn
- (setq edgeq (delete ne edgeq))
- (let ((ver))
- (dolist (v (send ne :vertices))
- (setq ver (find v *vertices* :key #'car))
- (if (enclosed-vertexp ver)
- (setq *vertices* (delete ver *vertices* :count 1 )
- )))))
- (setq edgeq (append edgeq (list ne)))))
+ (cond ((memq ne edgeq)
+ (setq edgeq (delete ne edgeq))
+ (setq searched-edgeq (cons ne searched-edgeq))
+ (let ((ver))
+ (dolist (v (send ne :vertices))
+ (setq ver (find v *vertices* :key #'car))
+ (if (enclosed-vertexp ver)
+ (setq *vertices* (delete ver *vertices* :count 1)))
+ ))
+ )
+ ((memq ne searched-edgeq)
+ (format *error-output* "~%re-searched edge:~A~%" ne)
+ (let ((*coplanar-threshold*
+ (/ *coplanar-threshold* 2)))
+ (format *error-output*
+ "thd:~A->~A~%" (* 2 *coplanar-threshold*)
+ *coplanar-threshold*)
+ (if (< *coplanar-threshold* 0.00001)
+ (error "edgeq error!!")
+ (return-from convex-hull-3d
+ (convex-hull-3d vertices)))))
+ (t
+ (setq edgeq (append edgeq (list ne))))))
(setq faceq (cons newface faceq))
(nconc *faces* (list newface))
(if *debug* (print (length *faces* )))
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <k-...@us...> - 2013-04-22 15:02:09
|
Revision: 618
http://sourceforge.net/p/euslisp/code/618
Author: k-okada
Date: 2013-04-22 15:02:00 +0000 (Mon, 22 Apr 2013)
Log Message:
-----------
use searched-edgeq, impremented as convex-hull-3d-ol of primptpatch.l
Modified Paths:
--------------
trunk/EusLisp/lisp/geo/primt.l
Modified: trunk/EusLisp/lisp/geo/primt.l
===================================================================
--- trunk/EusLisp/lisp/geo/primt.l 2013-04-22 13:10:57 UTC (rev 617)
+++ trunk/EusLisp/lisp/geo/primt.l 2013-04-22 15:02:00 UTC (rev 618)
@@ -350,6 +350,7 @@
(newbody)
(faceq)
(edgeq)
+ (searched-edgeq)
(searched-v)
)
(setq *points* vertices
@@ -396,16 +397,29 @@
p1 p2 p3 (set-difference *vertices* searched-v :key #'car)))
(setq newedges (send newface :edges))
(dolist (ne newedges)
- (if (memq ne edgeq)
- (progn
- (setq edgeq (delete ne edgeq))
- (let ((ver))
- (dolist (v (send ne :vertices))
- (setq ver (find v *vertices* :key #'car))
- (if (enclosed-vertexp ver)
- (setq *vertices* (delete ver *vertices* :count 1 )
- )))))
- (setq edgeq (append edgeq (list ne)))))
+ (cond ((memq ne edgeq)
+ (setq edgeq (delete ne edgeq))
+ (setq searched-edgeq (cons ne searched-edgeq))
+ (let ((ver))
+ (dolist (v (send ne :vertices))
+ (setq ver (find v *vertices* :key #'car))
+ (if (enclosed-vertexp ver)
+ (setq *vertices* (delete ver *vertices* :count 1)))
+ ))
+ )
+ ((memq ne searched-edgeq)
+ (format *error-output* "~%re-searched edge:~A~%" ne)
+ (let ((*coplanar-threshold*
+ (/ *coplanar-threshold* 2)))
+ (format *error-output*
+ "thd:~A->~A~%" (* 2 *coplanar-threshold*)
+ *coplanar-threshold*)
+ (if (< *coplanar-threshold* 0.00001)
+ (error "edgeq error!!")
+ (return-from convex-hull-3d
+ (convex-hull-3d vertices)))))
+ (t
+ (setq edgeq (append edgeq (list ne))))))
(setq faceq (cons newface faceq))
(nconc *faces* (list newface))
(if *debug* (print (length *faces* )))
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
Thanks for helping keep SourceForge clean.
X