[Euslisp-commit] SF.net SVN: euslisp:[672] trunk/EusLisp/lisp

[<ina...@us...>]

Revision: 672
          http://sourceforge.net/p/euslisp/code/672
Author:   inaba-jsk
Date:     2014-05-21 15:09:30 +0000 (Wed, 21 May 2014)
Log Message:
-----------
add Hendy Baker's contribution on remove-duplicates with hash table

Modified Paths:
--------------
    trunk/EusLisp/lisp/geo/primt.l
    trunk/EusLisp/lisp/l/common.l

Modified: trunk/EusLisp/lisp/geo/primt.l
===================================================================
--- trunk/EusLisp/lisp/geo/primt.l	2014-02-26 10:42:09 UTC (rev 671)
+++ trunk/EusLisp/lisp/geo/primt.l	2014-05-21 15:09:30 UTC (rev 672)
@@ -701,7 +701,7 @@
 
 ;;
 
-
+#|
 (defun make-body-from-vertices (face-vertices &optional (klass *body-class*))
    ; face-vertices=(list #f(x1 y1 z1) #f(x2 y2 z2) ...) ...
    #|(setq a
@@ -728,6 +728,29 @@
      (setq bod (instance *body-class* :init :faces (nreverse faces)))
      (send bod :csg (list (cons :body-from-vertices face-vertices)))
      bod) )
+|#
+;; 2014.5.21 add Henry Baker's contribution of 2013.8.31
+(defun make-body-from-vertices (face-vertices &optional (klass *body-class*))
+                                         ; face-vertices=(list #f(x1 y1 z1) #f(x2 y2 z2) ...) ...
+    (let* ((vlist (mapcar #'list
+                          (remove-duplicates
+                                  (apply #'append face-vertices)
+                                  :test #'equal)))
+            (vhash (make-hash-table :size (* 2 (length vlist)) :test #'equal))
+           faces bod)
+      (dolist (vlist-entry vlist) ; Populate hash table.
+        (or (gethash (car vlist-entry) vhash)
+             (setf (gethash (car vlist-entry) vhash) vlist-entry)))
+      (dolist (fverts face-vertices)
+         (let ((fvlist))
+            (dolist (fv fverts)
+              ;; (push (assoc fv vlist) fvlist)
+              ;; (push (assoc fv vlist :test #'equal) fvlist) ; *** Too slow !!! ***
+              (push (gethash fv vhash) fvlist))
+            (push (make-face-from-vertices (nreverse fvlist)) faces)) )
+      (setq bod (instance *body-class* :init :faces (nreverse faces)))
+      (send bod :csg (list (cons :body-from-vertices face-vertices)))
+      bod) )
 
 
 

Modified: trunk/EusLisp/lisp/l/common.l
===================================================================
--- trunk/EusLisp/lisp/l/common.l	2014-02-26 10:42:09 UTC (rev 671)
+++ trunk/EusLisp/lisp/l/common.l	2014-05-21 15:09:30 UTC (rev 672)
@@ -620,10 +620,30 @@
       ((memq (car l) (cdr l)) (unique (cdr l)))
       (t (cons (car l) (unique (cdr l))))))
 
+#|
 (defun remove-duplicates (seq &key (test #'eq) (test-not) (key #'identity)
 				   (start 0) (end 1000000))
    (system::raw-remove-duplicates seq test test-not key start end))
+|#
+;; 2014.5.21 add Henry Baker's contribution of 2013.7.22, 2013.8.31
+(defun remove-duplicates (seq &key (key #'identity)
+                               (test #'eq) (test-not)
+                               (start 0) (end (length seq)))
+   (if (and (or (eq test #'eq) (eq test #'eql) (eq test #'equal))
+            (> end 100))
+       (let* ((htab (make-hash-table :size (* 2 (length seq)) :test test)))
+         (let* ((res
+                 (remove-if
+                 #'(lambda (k)
+                      (let* ((v (gethash k htab)))
+                        (unless v (setf (gethash k htab) t))
+                        v))
+                 seq
+                 :start start :end end :key key)))
+           res))
+     (system::raw-remove-duplicates seq test test-not key start end)))
 
+
 (defun extream (seq test &optional (key #'identity))
    (if (null seq)
        nil

This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.