;|   F2S.lsp  (Faces-to-Solid)
Creates a single ACIS solid from selected 3dfaces, touching or not

Version: 1.0
Date:    8/23/2006

(c) Copyright 2006 by Bill Gilliss.
All rights reserved... such as they are.

bill.gilliss@<<NOSPAM>>aya.yale.edu    gilliss@<<NOSPAM>>iglou.com

As in M2S.lsp, the solid is created by projecting each selected face 
vertically "down" the CURRENT z-axis to a plane a user-specified distance 
below the lowest vertex. To assure that all parts of the mesh are generated 
as solids, this distance can not be zero, but the solid can be SLICEd
later if need be. The solid is created on the current layer.

If the final union of small solids hangs because of memory limitations, 
try unioning contiguous bunches of them manually when given the choice.

Notes:
 - Works with AutoCAD 2007 as well as all previous releases.

 - Thanks to Gilles Chanteau for R2007 and international syntax suggestions.

 - If adjacent faces do not have identical coordinates, there will be very 
small gaps or overlaps between the solids derived from them, which can 
cause AutoCAD to fail to be able to union the solids. Common results:
      "Inconsistent containment of intersection curve."
      "Inconsistent information in vertex and coedge coordinates."
      "Inconsistent edge-face relationships."
      "Inconsistent face-body relationships."
   Many thanks to Robert Morin for suggesting that the best way to fix the 
face coordinates before running F2S is to use 3DSOUT with Auto-Welding turned
on with an appropriate threshold, then 3DSIN to bring the welded mesh
back into AutoCAD, then EXPLODE and run F2S. (R2007 does not have 3DSIN, alas.)
The larger the threshold distance, the fewer the problems. Some manual unioning
might still be necesary.
   If problematic solids do persist, copying them a small distance and then 
unioning the copies with the original will usually fill the gaps and resolve
these problems.
|;


(defun c:f2s ( / ss ent ed bot bottom partialsolid R17 n partialsolid num
                 low10 low11 low12 low13
                 p1 p2 p3 p4 c1 c2 c3 c4 b1 b2 b3 b4
                 soldepth sspartial ssfinal
                 oldsolidhist oldecho oldsnap oldblip
                 )
                 
(command "_.undo" "_begin")
(setq oldecho (getvar "cmdecho"))
(setq oldsnap (getvar "osmode"))
(setq oldblip (getvar "blipmode"))
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(setvar "blipmode" 0)
(if (< 16 (atoi (substr (getvar "acadver") 1 2))) (setq R17 T))
(if R17 (setq oldsolidhist (getvar "solidhist")))
(if R17 (setvar "solidhist" 0))


;;select the faces
  (prompt "Select 3dface(s) to solidify: ")
  (setq ss (ssget '((0 . "3dface"))))


;;initialize lowest value
  (setq ent (ssname ss 0))
  (setq ed (entget ent))
  (setq bottom (caddr (trans (cdr (assoc 10 ed)) 0 1)))  

;;find lowest vertex in selection set of faces 
  (setq n 0)
    (while                         
    (< n (sslength ss)) 
    (progn 
      (setq ent (ssname ss n))
      (setq ed (entget ent))
      (setq low10 (caddr (trans (cdr (assoc 10 ed)) 0 1)))
      (setq low11 (caddr (trans (cdr (assoc 11 ed)) 0 1)))
      (setq low12 (caddr (trans (cdr (assoc 12 ed)) 0 1)))
      (setq low13 (caddr (trans (cdr (assoc 13 ed)) 0 1)))
      (setq bottom (min bottom low10 low11 low12 low13))
      (setq n (1+ n))
      );progn
  );while

;; get desired thickness of solid
  (setq soldepth 0)
  (while
     (zerop soldepth)
     (progn
       (setq soldepth (getdist "\nEnter desired thickness of solid below lowest vertex <1>: "))
       (if (not soldepth) (setq soldepth 1.0))
       (if (zerop soldepth)
          (princ "\nThickness can be small, but not zero. (Slice it later, if need be.)"))
       );progn
     );while
  (setq bot (- bottom (abs soldepth)))
 
;; initialize selection sets to receive solids  
  (setq sspartial (ssadd))          ;initialize partial set of extruded segments to be unioned together
  (setq ssfinal (ssadd))            ;initialize final set of solids
  
  (princ "\nUnioning large number of small solids can lock up AutoCAD")
  (princ "\nif memory limits are exceeded. Would you like to continue")
  (princ "\nwith automatic unioning, or union them manually?")
  (initget 1 "Auto Manual")
  (setq reply (getkword " Auto or Manual?"))
  (setq reply (substr reply 1 1))

;;create solids
(setq num (sqrt (sslength ss)))  ;;number of partial solids to create
(setq n 0)
(setq partialsolid 0)
(setq time1 (getvar "DATE"))

(while 
  (< n (sslength ss))
  (progn 
    (setq ent (ssname ss n))
    (setq ed (entget ent))
    (setq p1 (assoc 10 ed)                 ;first vertex of face
          p2 (assoc 11 ed)
          p3 (assoc 12 ed)
          p4 (assoc 13 ed))
    (setq c1 (trans (cdr p1) 0 1)          ;top coordinates
          c2 (trans (cdr p2) 0 1)
          c3 (trans (cdr p3) 0 1)
          c4 (trans (cdr p4) 0 1))
    (setq b1 (list (car c1) (cadr c1) bot) ;bottom coordinates
          b2 (list (car c2) (cadr c2) bot)
          b3 (list (car c3) (cadr c3) bot)
          b4 (list (car c4) (cadr c4) bot))
    (LOFT c1 c2 c3 b1 b2 b3)
    (LOFT c3 c4 c1 b3 b4 b1)
    (setq partialsolid (1+ partialsolid))

    (if 
     (or (>= partialsolid num) (= n (1- (sslength ss))))
      (if (= reply "A")
        (progn
          (setq partialsolid 0) 
          (command "_.union" sspartial "")
          (ssadd (entlast) ssfinal)
          (setq sspartial (ssadd))   ;;re-initialize with empty set      
          );progn
        );if 
      );if
  (progress n (sslength ss)) 
   (setq n (1+ n))         
  );progn 
);while

(if (= reply "A")
  (progn
    (grtext -1 "Unioning final solid...")
    (command "_.union" ssfinal "")
    );progn
  );if
    
;;cleanup
  (setvar "cmdecho" oldecho)
  (setvar "osmode" oldsnap)
  (setvar "blipmode" oldblip)
  (if R17 (setvar "solidhist" oldsolidhist))
  (setq sspartial nil 
        ssfinal nil)
  (command "_.undo" "_end")
  (grtext)
  (princ)

);defun

;;============== SUBROUTINES ====================
(defun LOFT (r1 r2 r3 s1 s2 s3 / e1 extr highest)
  (command "_.area" s1 s2 s3 "")
  (if (> (getvar "area") 0.00000001) ;;avoid problems with tiny solids
    (progn
      (command "_.pline" s1 s2 s3 "_c")
      (setq highest (max (caddr r1) (caddr r2) (caddr r3)))
      (setq extr (- highest bot))
      (if 
        R17
        (command "_.extrude" (entlast) "" extr)     ;;2007 and higher 
        (command "_.extrude" (entlast) "" extr 0.0) ;;2006 and below
        );endif
 
      (if                  ;;don't slice if top is flat
       (not
        (and 
          (equal (caddr r1) (caddr r2)) 
          (equal (caddr r1) (caddr r3))
          );and
         );not
       (command "_.slice" (entlast) "" "_3p" r1 r2 r3 s1)
       );if
     (ssadd (entlast) sspartial)
     );progn
    );if
  );defun
  

(defun progress (current total / time2 time3 elapsed complete   ;;time1 is a global variable
                 projected r days hours minutes seconds message)
(if
  (and (> current 0)                 ;;skip first one to avoid divide by 0
       (= 0 (rem (fix current) 10))  ;;only update every 10th iteration
       );and
    (progn
     (if (not time1) (setq time1 (getvar "date")))  ;initialize here if neglected in calling code
     (setq time2 (getvar "date"))
     (setq time3 (- time2 time1))
     (setq elapsed (* 86400 time3))           ;;elapsed time in seconds
     (setq complete (/ current total 1.0))    ;;decimal value betw 0.0 and 1.0
         (setq projected (/ elapsed complete))  ;;projected time in seconds
         (setq r (- projected elapsed))         ;;remaining time in seconds
         (setq 
           days     (fix (/ r 86400))
           r        (- r (* days 86400))      
           hours    (fix (/ r 3600))
           r        (- r (* hours 3600))
           minutes  (fix (/ r 60))
           r        (- r (* minutes 60))
           seconds  (fix r)
           )
         (setq message 
           (strcat 
            "% complete:" 
            (if 
             (< (* 100 complete) 10)
             (strcat "0" (itoa (fix (* 100 complete))))
             (itoa (fix (* 100 complete)))
             )
           "  Remaining:"
           (itoa days) ":"
           (itoa hours) ":"
           (if (< minutes 10)(strcat "0" (itoa minutes))(itoa minutes) ) ":"
           (if (< seconds 10)(strcat "0" (itoa seconds))(itoa seconds) )
           );strcat
        );setq
      (grtext -1 message)
   );progn
  );if
);defun

(alert 
"Face-to-Solid loaded. Type  F2S  to run the program.
\nNote: if many faces are selected, AutoCAD may crash due to memory
limitations when unioning the many solids created from them, so please 
\nSAVE ALL OPEN DRAWINGS \n
before using this routine with large numbers of faces. The routine
will prompt for automatic or manual unioning; select manual to do the 
unioning yourself in smaller increments if automatic causes problems.
\nAlso, see the introductory comments in the LISP file about cleaning up
face coordinates to avoid unioning errors.")