;;;Region slicing routine
;;;Nik van Herpt
;;;10 January 2003
;;;
(defun c:rs (/ -os -ucs -points -p1 -p2 -distinct -p3 -lay -unable -set -nm -ename -elist)
 (command "undo" "g")
 (setq -os (getvar "osmode"))
 (setq -ucs (getvar "ucsname"))
 ;delete temp ucs if existing
 (if (tblsearch "ucs" "TempSliceUCS")
  (command "ucs" "d" "TempSliceUCS")
 )
 (command "ucs" "s" "TempSliceUCS")
 (prompt "\nSelect Region: ")
 (setq -points (acis_poll))
 (if -points
  (progn
   (redraw (cdr (car entity)) 3)
   (#clyr "TempSliceLayer")
   (setq -p1 (getpoint "\nFirst point: ")
         -p2 (getpoint -p1 "\nSecond point: "))
   (if (and (= (car -p1) (car -p2)) (= (cadr -p1) (cadr -p2)))
    (setq -distinct T)
    (progn
     (setq -p3 (list (car -p2) (cadr -p2) (+ (caddr -p2) 100))
           -lay (cdr (assoc 8 entity)))
     (setvar "osmode" 0)
     (command "ucs" "w")
     (command "ucs" "3p" (cdr (car points)) (cdr (cadr points)) (cdr (caddr points))) ;points variable from program below
     (command "line" "0,0,0" "0,0,100" "")
     (command "extrude" (cdr (car entity)) "" "p" (entlast)) ;entity variable from program below
     (command "ucs" "r" "TempSliceUCS")
     (command "slice" (entlast) "" -p1 -p2 -p3 "b")
 ;explode 3dsolids
     (setq -set (ssget "x" (list '(8 . "TempSliceLayer"))))
     (command "explode" (ssname -set 0))
 ;proceed if solid has been sliced
     (if (= (sslength -set) 3)
      (command "explode" (ssname -set 1))
      (setq -unable T)
     );if 
 ;set ucs 90 degrees to original face
     (command "ucs" "p")
     (command "ucs" "3p" "0,0,0" "100,0,0" "0,0,100");
 ;erase crossing extra objects
     (command "plan" "")
     (setq -set (ssget "c" (append (list (car (getvar "vsmin"))) '(50.0 0.0)) (getvar "vsmax") (list '(8 . "TempSliceLayer"))))
     (command "erase" -set "")
     (command "zoom" "p")
 ;change entites back to original layer
     (setq -set (ssget "x" (list '(8 . "TempSliceLayer"))))
     (setq -nm 0 -ename (ssname -set -nm))
     (while -ename
      (setq -elist (entget -ename)
            -elist (subst (cons 8 -lay) (assoc 8 -elist) -elist))
      (entmod -elist)
      (setq -nm (1+ -nm) -ename (ssname -set -nm))
     );while
   ));-distinct progn\if
 ;set ucs back to original
   (if (= -ucs "")
    (command "ucs" "w")
    (if (= (substr -ucs 1 1) "*")
     (cond
      ((= -ucs "*TOP*")(command "ucs" "g" "Top"))
      ((= -ucs "*BOTTOM*")(command "ucs" "g" "Bottom"))
      ((= -ucs "*FRONT*")(command "ucs" "g" "Front"))
      ((= -ucs "*BACK*")(command "ucs" "g" "Back"))
      ((= -ucs "*LEFT*")(command "ucs" "g" "Left"))
      ((= -ucs "*RIGHT*")(command "ucs" "g" "Right"))
     );cond
     (command "ucs" "r" -ucs)
    );if
   );if
 ;set clayer back
   (setvar "osmode" -os)
   (#rlyr)
 ;delete temp layer
   (command "purge" "la" "TempSliceLayer" "n")
 ));if/progn
 (if -distinct (progn (command "regen") (prompt "\nNeed a point distinct from 1st in XY plane.\n")))
 (if -unable (prompt "\nSlicing plane does not intersect the selected Region.\n"))
 (command "ucs" "d" "TempSliceUCS")
 (command "undo" "e")(princ)
)

;;;LAYER----------------------------------------------------------------
(defun #clyr (#nlyr)
 (setq #cl (getvar "clayer"))
 (command "layer" "m" #nlyr "")
 (princ))
;
(defun #rlyr ()
 (if #cl #cl (setq #cl "0"))
 (command "layer" "m" #cl "")
 (princ))

;;;--------------------------------------------------------------------------------------------------

;;;supplied by mataeux@yahoo.com

;;; portion of acis library by matthew rothgery

(defun acis_translate(string / item letter lst)
 (setq string(strcat string" ")item"")
 (while(>(strlen string)0)
  (setq letter(substr string 1 1)string(substr string 2))
  (if(=" "letter)
     (setq lst(append lst(list item))item"")
     (setq item(strcat item(chr(- 79(-(ascii letter)80)))))
  )
 )
 lst
)

(defun draw_aperture (pnt color / p1 p2 p3 p4)
  (setq pnt(trans pnt 0 1)
        p1 (mapcar'+(trans(list(- aperture)(- aperture)0)2 1)pnt)
        p2 (mapcar'+(trans(list(- aperture)   aperture 0)2 1)pnt)
        p3 (mapcar'+(trans(list   aperture    aperture 0)2 1)pnt)
        p4 (mapcar'+(trans(list   aperture (- aperture)0)2 1)pnt)
  )
  (grvecs(list color p1 p2 p2 p3 p3 p4 p4 p1))
)

(defun compute_center_point()'unsupported)

(defun acis_poll();/ device point points pointn entity entityPrev viewsize viewctr aperture sat)
 (while(=(car(setq device(grread T 4 2)))5)
  (and pointn(draw_aperture pointn 0))
  (or(=(getvar"VIEWSIZE")viewsize)
     (=(getvar"VIEWCTR" )viewctr )
     (setq viewctr (getvar"VIEWCTR" )
           viewsize(getvar"VIEWSIZE")
           aperture(*(/ viewsize(cadr(getvar"screensize")))(getvar"APERTURE"))
     )
  )
  (setq point(cadr device)entity(nentselp point))
  (if(and entity
          (setq entity(entget(car entity)))
          (member(cdr(assoc 0 entity))'("3DSOLID""REGION"))
          (or(equal entityPrev(setq entityPrev(cdr(assoc -1 entity))))
             (progn
              (setq points()sat())
              (foreach group entity(and(=(car group)1)(setq sat(append sat(list(acis_translate(cdr group)))))))
              (foreach line sat
               (cond
                    ((wcmatch(car line)"point") ;;; this works for straight edges
                     (setq points(cons(list 0(distof(nth 2 line))(distof(nth 3 line))(distof(nth 4 line)))points))
                    )
                    ((wcmatch(car line)"coedge") ;;; start here for curved surface support
                     ;(setq points(cons(compute_center_point)points))
                    )
               )
              )
             )
             T
          )
     )
     (setq points(mapcar'(lambda(pnt)(cons(distance(cdr(reverse(trans point 1 2)))(cdr(reverse(trans(cdr pnt)0 2))))(cdr pnt)))points)
           pointn(cdr(assoc(apply'min(mapcar'car points))points))
     )
     (setq pointn()entity())
  )
  (and pointn(draw_aperture pointn 2))
 )
 (and pointn(draw_aperture pointn 0))
 (if entity(list(cdr(assoc -1 entity))pointn))
)