
;; ************************************************************************
;;;                I N  T H E   N A M E   O F   G O D
(defun ifnlisp (flesh)
 (setvar "cmdecho" 0)
 (setvar "blipmode" 0)
 (command "ucs" "")
 (setq flesh (strcase flesh))
 (setq cl (getvar "clayer"))
 (princ (strcat "\n       * * *   W E L C O M E   T O  < IFN >  P "
                                  "R O G R A M   * * * "))
 (princ (strcat "\nInsert Flesh (" flesh " block) , Version  3.2 "
                 ", (c) 1993 by R. Negarandeh ."))
  ;;
  ;; Body of function
  ;;
  (if *error*                         ; Set our new error handler
    (setq err_oe *error* *error* err_er)
    (setq *error* err_er)
  )
       (if (= (tblsearch "layer" "flesh" ) nil)
           (command "layer" "m" "flesh" "c" "1" "" "")
       )

 (if (= (tblsearch "block" flesh) nil) (makeflesh))
 (setq f 0)
 (if
     (= size1 nil )(setq size1 1 )
 )
 (setq size2 (rtos size1 2 0))
 (princ (strcat "\nEnter " flesh " scale factor <" size2))
 (setq size (getreal ">:"))
 (if
     (= size nil) (setq size size1 )
 )
 (setq size1 size)
 (setq yscale 1.00)
 (setq ysize (* size yscale))
   (while (/= f nil)
     (setq f (entsel "\nSelect ARC or LINE: "))
       (setq e (car f))
       (setq pt (cadr f))
             (if (/= e nil)
              (progn
                        (if
                          (= (cdr (assoc 0 (entget e))) "LINE" )
                                (progn
                                      (setq p (cdr (assoc 11 (entget e))))
                                      (setq q (cdr (assoc 10 (entget e))))
                                      (setq a1(* 180 (/ (angle q p ) pi)))
                                      (setq a2(* 180 (/ (angle p q ) pi)))
                                      (setq d1 (distance pt p ))
                                      (setq d2 (distance pt q ))
                                      (if
                                          (< d1 d2)
                                            (progn
                                                  (setq ip p)
                                                  (setq a a1)
                                            )
                                            (progn
                                                  (setq ip q)
                                                  (setq a a2)
                                            )
                                          )
                                    (command "insert" flesh ip size ysize a)
                                  (print)
                                )
                        (if
                         (= (cdr (assoc 0 (entget e))) "ARC" )
                            (progn
                               (setq c (cdr (assoc 10 (entget e))))
                               (setq r (cdr (assoc 40 (entget e))))
                               (setq pa (cdr (assoc 50 (entget e))))
                               (setq qa (cdr (assoc 51 (entget e))))
                               (setq p (polar c pa r))
                               (setq q (polar c qa r))
                               (setq at (asin (/ (* size 1.0000) (* r 2))))
                               (setq a1 (* 180 (/ (+ (- pa (/ pi 2)) at) pi)))
                               (setq a2 (* 180 (/ (- (+ qa (/ pi 2)) at) pi)))
                               (setq d1 (distance pt p ))
                               (setq d2 (distance pt q ))
                                 (if
                                    (< d1 d2)
                                      (progn
                                            (setq ip p)
                                            (setq a a1)
                                      )
                                      (progn
                                            (setq ip q)
                                            (setq a a2)
                                      )
                                 )
                               (command "insert" flesh ip size ysize a)
                               (print)
                            )
                                (progn (prompt "\nEntity is a ")
                                       (princ (cdr (assoc 0 (entget e))))
                                       (princ "    ")
                                )
                        )
               )
              )
             )
    (print)
   )
  (if err_oe (setq *error* err_oe))   ; Reset old error function if error
 (princ)
 (princ "\n     Good Luck .   ")
 (setvar "blipmode" 1)
 (setvar "cmdecho" 1)
 (setvar "clayer" cl)
 (prin1 )
)

(defun asin (a)
  (atan (/ a (sqrt (- 1.0 (* a a )))))
)

(defun dtr (a)
   (* pi (/ a 180.0))
)

(defun tan (a)
   (/ (sin a) (cos a))
)

(defun makeflesh ()
 (setvar "clayer" "flesh")
 (setq basep (list 0 0 0))
  (cond
    ((= flesh "FL1")
       (progn
          (setq nsold 10)
          (makesolid nsold)
       )
    )
    ((= flesh "FL2")
       (progn
          (setq nsold 1)
          (makesolid nsold)
       )
    )
    ((= flesh "FL3")
       (progn
          (setq bangl 193.0)
          (setq flen 1.13)
          (setq midlp (list -1 0 0))
          (setq fstpt (polar basep (dtr bangl) flen))
          (setq secpt (polar basep (-(dtr bangl)) flen))
          (setq ssblock (ssadd))
          (command "pline" basep fstpt midlp secpt "c")
          (ssadd (entlast) ssblock)
       )
    )
    ((= flesh "FL4")
       (progn
          (setq bangl 45.0)
          (setq fstpt (list -1.0 (tan (dtr bangl)) 0))
          (setq secpt (list -1.0 (-(tan (dtr bangl))) 0))
          (setq fstp1 (list -1.2 (tan (dtr bangl)) 0))
          (setq secp1 (list -1.2 (-(tan (dtr bangl))) 0))
          (setq ssblock (ssadd))
          (command "pline" basep fstpt secpt "c")
          (ssadd (entlast) ssblock)
          (command "line" fstp1 secp1 "")
          (ssadd (entlast) ssblock)
       )
    )
    ((= flesh "FL5")
       (progn
          (setq bangl 13.0)
          (setq fstpt (list -1.0 (tan (dtr bangl)) 0))
          (setq secpt (list -1.0 (-(tan (dtr bangl))) 0))
          (setq ssblock (ssadd))
          (command "pline" basep fstpt secpt "c")
          (ssadd (entlast) ssblock)
       )
    )
    ((= flesh "FL6")
       (progn
          (setq bangl 193.0)
          (setq flen 1.75)
          (setq midlp (list -1 0 0))
          (setq fstpt (polar basep (dtr bangl) flen))
          (setq secpt (polar basep (-(dtr bangl)) flen))
          (setq ssblock (ssadd))
          (command "pline" basep fstpt midlp secpt "c")
          (ssadd (entlast) ssblock)
       )
    )
    ((= flesh "FL7")
       (progn
        (setq bangl 150.0)
        (setq flen 0.75)
        (setq ssblock (ssadd))
        (setq n 0)
          (while (< n 3)
            (setq endpt (polar basep pi (* 0.2 n)))
            (setq fstpt (polar endpt (dtr bangl) flen))
            (setq secpt (polar endpt (-(dtr bangl)) flen))
            (command "pline" fstpt endpt secpt "")
            (ssadd (entlast) ssblock)
            (setq n (1+ n))
          )
       )
    )
    ((= flesh "FL8")
         (newflesh)
    )
    ((= flesh "FL9")
       (progn
         (newflesh)
         (command "hatch" "ansi31" "" "45" ssblock "")
         (ssadd (entlast) ssblock)
       )
    )
    ((= flesh "FL10")
       (progn
          (setq ssblock (ssadd))
          (command "donut" "0" "" basep "")
          (ssadd (entlast) ssblock)
       )
    )
  )
   (command "block" flesh basep ssblock "")
 (setvar "clayer" cl)
)
(setq ifnid 1)
(defun c:IFN ()
 (if
     (= flesh nil )(setq flesh "FL1" )
 )
 (setq flname (getstring (strcat "\nEnter name of flesh <" flesh "> :")))
        (cond ((= flname "")
                          (ifnlisp flesh)
              )
              ((or (= flname "fl") (= flname "FL"))
                          (progn
                                (menucmd "I=flesh")
                                (menucmd "I=*")
                          )
              )
              (t
                          (progn
                                (ifnlisp flname)
                                (setq flesh flname)
                          )
              )
        )
 (setq flesh (strcase flesh))
 (prin1)
)

(princ (strcat "\n      <InsertFlesh> loaded.  Start command with IFN ." ))
(princ )
; ************************************************************************
(defun makesolid (nsold)
    (setq centp (list -1.36965 0 0))
    (setq frstp (list -1.11495 -0.2679 0))
    (setq bangl 316.4468877)
    (setq radpt 0.369651863)
    (setq aangl (/ (- 360 bangl) nsold))
    (setq ssblock (ssadd))
    (setq n 0)
      (while (> (* 2 nsold) n)
        (setq pt1 (polar centp (dtr (+ bangl (* n aangl))) radpt ))
        (setq pt2 (polar centp (dtr (+ bangl (* (+ n 1) aangl))) radpt ))
        (command "solid" pt1 basep pt2 "" "")
        (ssadd (entlast) ssblock)
        (setq n (+ n 1))
      )
)
; ************************************************************************
(defun newflesh ()
            (setq centr (list
                              (list -0.595311  0.429882 0.0)
                              (list -0.595311 -0.429882 0.0)
                              (list  0.182954  1.76772  0.0)
                              (list  0.182954 -1.76772  0.0)
                        )
            )
            (setq radus (list
                              0.583372
                              0.583372
                              1.77716
                              1.77716
                        )
            )
            (setq stang (list
                              2.85085
                              2.33731
                              3.86068
                              1.67393
                        )
            )
            (setq enang (list
                              3.94588
                              3.43233
                              4.60926
                              2.42251
                        )
            )
        (setq ssblock (ssadd))
        (setq n -1)
          (while (< n 3)
            (setq ent (entmake
                           (list (cons 0 "arc")
                                 (cons 8 "flesh")
                                 (cons 10 (nth (setq n (1+ n)) centr))
                                 (cons 40 (nth n radus))
                                 (cons 50 (nth n stang))
                                 (cons 51 (nth n enang))
                           )
                      )
            )
            (ssadd (entlast) ssblock)
          )
)
