;| Sphere4Point.lsp (S4P) draws the unique sphere defined by four 
   non-coplanar points.

Notes:
  Points will be rejected if co-planar.
  Be sure to OSNAP to 3D points to avoid erroneous results.
  Works with all versions of AutoCAD.

by Bill Gilliss
bill <at> realerthanreal <dot> com
Comments and suggestions always welcome.

No warranty, either expressed or implied, is made as to the fitness of
this information for any particular purpose.   All materials are to be 
considered 'as-is' and use thereof should be considered as at your own
risk.

v 1.0 2010-03-14 - initial public release
v 1.1 2010-03-15 - compatible with all versions (doesn't use UCS OBJECT)

Keywords: AutoCAD AutoLISP four-point 4-point sphere
=======================================================================
|;

(defun c:sphere4point ( / p1 p2 p3 p4 g1 tempUCS *ucsname *gridmode
                           intlist sphereCenter myerror olderror intpts)
                          
;;========subroutines================

  (defun intpts (pt1 pt2 pt3 / cent norm)
    (command "._ucs" "_3" pt1 pt2 pt3)
    (command "._circle" "_3"  
      (trans pt1 0 1) (trans pt2 0 1) (trans pt3 0 1))
    (command "._ucs" "_w")
    (setq cent (trans (cdr (assoc 10 (entget (entlast)))) (entlast) 0))
    (setq norm (c:cal "cent + nor(pt1,pt2,pt3)" ))
    (entdel (entlast))
    (list cent norm)
    )

  (defun myerror (msg)  
    (command "._UCS" "_r" *ucsname) 
    (setvar 'gridmode *gridmode)    
    (setq *error* olderror) 
    )


;;====main program===================

  (arxload "geomcal")
  (setq olderror *error*)
  (setq *error* myerror)
  (setq *gridmode (getvar 'gridmode))
  (setvar 'gridmode 0)

  (if (= "" (setq *ucsname (getvar 'ucsname)))
      (progn
        (setq tempUCS "sphere4point")
        (if (tblsearch "UCS" tempUCS)
            (command "._UCS" "_save" tempUCS "_y")
            (command "._UCS" "_save" tempUCS)
            )
        (setq *ucsname tempUCS)
        )
    )

  ;;get 4 points - all coords in WCS
  (command "._ucs" "_w")
  (setq p1 (getpoint    "\nPoint 1: ")
        p2 (getpoint p1 "\nPoint 2: ")
          g1 (grdraw p1 p2 1 1)
        p3 (getpoint p2 "\nPoint 3: ")
          g1 (grdraw p2 p3 1 1)
        p4 (getpoint p3 "\nPoint 4: ")
          g1 (grdraw p3 p4 1 1)
        )

  ;;check points
  (if (inters p1 p2 p3 p4 nil)
      (progn
        (prompt "\nLines are co-planar. No unique sphere is possible.\n")
        (exit)
        (princ)
        )
    )

  ;; calculate intersection of lines normal to circle centers
  (setq intlist (append (intpts p1 p2 p3) (intpts p2 p3 p4)))
  (setq sphereCenter 
    (inters 
      (car intlist) (cadr intlist) (caddr intlist) (cadddr intlist) nil))
  (command "._sphere" sphereCenter p1)

  (myerror nil)
  (princ)
 
);defun ================================================================

(defun c:s4p ()
  (c:sphere4point)
  )
  
(princ "Sphere4point loaded. Type  s4p  to run.")
(princ)