Geometrifying Trigonometry NARRAYS Scale Down Issue

[dbhunia]

Dear Experts,

We are facing a scaling issue with "Geometrifying Trigonometry NARRAYS" (Topic is related to This post), please check the attached drawings & Lisp and advice what to do.

While we are generating the "Geometrifying Trigonometry NARRAYS" and generating the "Outlines of each geometrical shapes" up to a certain scale (please check the drawing "Geometrifying Trigonometry NARRAYS.dwg"), every thing going fine....

But below a certain scale (please check the drawing "Geometrifying Trigonometry NARRAYS_scale Down.dwg"), Lisp is generating the "Geometrifying Trigonometry NARRAYS" perfectly but not the "Outlines of each geometrical shapes".......

After checking the drawing "Geometrifying Trigonometry NARRAYS_scale Down.dwg" minutely I noticed that below a certain scale AutoCAD is not generating "Region" sometimes (for example go through the shapes within rectangular box) ..If we cannot make regions for closed locked set of small lines , then we are stuck......

[CodeDing · Accepted solution]

@dbhunia,

I believe boundaries use your current view to help create them, so if your object looks small when creating a boundary, then zooming to that object should create that boundary more effectively. 

I would be sure that you are zooming to your object if it is really small. See if that helps.

Best,

~DD

[marko_ribar · Accepted solution]

From what I understood... As you noticed, the trick is to scale up base triangle, then when it finishes to scale down all thing... As @CodeDing mentioned, you need to zoom to object in order to acquire correct sel. set with (ssget "CP" ...)... Also your base triangle as complete drawing is too far from origin WCS '(0.0 0.0 0.0) point, so as you can see I (entmod) initial block, and then finally I moved complete thing to its original location... So here is my revision, if it can help you somehow :

(defun c:GBI (sel / HY BA PE) 
(vl-load-com)
(setq PT_lst nil)
(setq COB (vlax-invoke (vlax-ename->vla-object sel) 'explode))
   (foreach COBI COB
        (setq ent (entget (vlax-vla-object->ename COBI)))
        (if (and (= (cdr (assoc 0 ent)) "LINE") (= (cdr (assoc 8 ent)) "HYPOTENUSE"))
            (setq HY (list (cdr (assoc 8 ent)) (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
        )
        (if (and (= (cdr (assoc 0 ent)) "LINE") (= (cdr (assoc 8 ent)) "BASE"))
            (setq BA (list (cdr (assoc 8 ent)) (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
        )
        (if (and (= (cdr (assoc 0 ent)) "LINE") (= (cdr (assoc 8 ent)) "PERPENDICULAR"))
            (setq PE (list (cdr (assoc 8 ent)) (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
        )
   )
(mapcar 'vla-delete COB)
(setq PT_lst (cons (list PE BA HY) PT_lst))
)
(defun triarea (pl)
  (abs (/ (apply '+ (mapcar '(lambda (a b) (- (* (car a) (cadr b)) (* (cadr a) (car b)))) pl (append (cdr pl) (list (car pl))))) 2.0))
)
(defun unique (l)
  (if l (cons (car l) (unique (vl-remove (car l) l))))
)
(defun c:INB ()
     (setq B1 (nth 1 (nth 1 (nth 0 PT_lst))) B2 (nth 2 (nth 1 (nth 0 PT_lst))))
     (command "insert" (cdr (assoc 2 (entget sel))) (nth 1 (nth 1 (nth 0 PT_lst))) "" "" "")
     (C:GBI (entlast))
     (setq IB1 (nth 1 (nth 2 (nth 0 PT_lst))) IB2 (nth 2 (nth 2 (nth 0 PT_lst)))) 
     (if (or (= N 1) (= N 3))
           (progn (command "_.ALIGN" (entlast) "" IB1 B1 IB2 B2 "" "Y")
                  (if (= N 1) (command "_.MIRROR" (entlast) "" B1 B2 "Y"))
           )
           (progn (command "_.ALIGN" (entlast) "" IB1 B2 IB2 B1 "" "Y")
                  (if (= N 2) (command "_.MIRROR" (entlast) "" B1 B2 "Y"))
           )
     )
)
(defun c:GTN ()
(while (or (not (setq sel (car (entsel "\nSelect Triangle Block: "))))
           (not (setq Pow (getint "\nEnter Power: ")))
           (not (= (cdr (assoc 0 (entget sel))) "INSERT"))
       )
       (prompt "\nInvalid...")
)
(initget "Yes No")
(setq Ans (cond ((getkword "\nDo you want Boundary [Yes/No] <No>: ")) ("No")))
(setvar "cmdecho" 0)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq bp (cdr (assoc 10 (entget sel))))
(entupd (cdr (assoc -1 (entmod (subst '(10 0.0 0.0 0.0) (cons 10 bp) (entget sel))))))
(setq el (entlast))
(C:GBI sel)
(setq pl (unique (apply 'append (mapcar 'cdr (car PT_lst)))))
(if (< (triarea pl) 1.0)
  (progn
    (setq f (fix (/ 1.0 (triarea pl))))
    (command "scale" sel "" '(0.0 0.0 0.0) f)
    (C:GBI sel)
  )
)
(vla-getBoundingBox (vlax-ename->vla-object sel) 'll 'ur)
(setq LL (vlax-safearray->list ll) UR (vlax-safearray->list ur) ISB LL)
(setq Off (* (distance LL UR) 2.0))
(setq IB (polar ISB (* pi 1.5) off))
(setq IB (list IB (polar IB 0 off) (polar IB 0 (* 2 off)) (polar IB 0 (* 3 off))))
(setq IB_lst nil)
(foreach PT IB
     (command "copy" sel "" LL PT) (setq IB_lst (cons (list (entlast)) IB_lst))
)
(setq NIB_lst nil)
(repeat (setq N (length IB_lst))
     (setq Ent_lst (nth (setq N (- N 1)) IB_lst))
     (C:GBI (setq PIB (nth (1- (length Ent_lst)) Ent_lst)))
     (C:INB)
     (setq NIB_lst (cons (list PIB (entlast)) NIB_lst))
)
(if (= "Yes" Ans) (foreach L_item NIB_lst (C:GOL L_item)))
(setq IB_lst NIB_lst)
(setq IB (nth 0 IB))
(setq Pow (- Pow 1) count 1)
(while (/= count Pow)
    (C:NTH) (setq count (+ count 1))
)
(setq ss (ssadd))
(while (setq el (entnext el))
  (if (not (vlax-erased-p el))
    (ssadd el ss)
  )
)
(if f
  (progn
    (command "scale" ss "" '(0.0 0.0 0.0) (/ 1.0 f))
    (command "scale" sel "" '(0.0 0.0 0.0) (/ 1.0 f))
  )
)
(command "move" ss "" '(0.0 0.0 0.0) bp)
(entupd (cdr (assoc -1 (entmod (subst (cons 10 bp) '(10 0.0 0.0 0.0) (entget sel))))))
(setvar "cmdecho" 1)
(setvar "osmode" osm)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:NTH ()
(setq IB_lst_N nil)
(foreach B IB_lst
    (setq N 0)
    (setq B (reverse B))
    (setq IB (polar IB (* pi 1.5) off))
    (setq IBX (list IB (polar IB 0 off) (polar IB 0 (* 2 off)) (polar IB 0 (* 3 off))))
    (foreach PT IBX
        (setq add (ssadd))
        (repeat (setq N1 (length B))
                (setq BE (nth (setq N1 (- N1 1)) B))
                (command "copy" BE "" LL PT) 
                (ssadd (entlast) add)
        )
        (setq N (+ N 1))
        (C:GBI (entlast))
        (C:INB)
        (ssadd (entlast) add)
        (setq aa nil)
        (repeat (setq i (sslength add))
                (setq e (ssname add (setq i (1- i))))
                (setq aa (cons e aa))
        )
        (if (= "Yes" Ans) (C:GOL aa))
        (setq IB_lst_N (cons aa IB_lst_N))
    )
)
(setq IB_lst IB_lst_N)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:GOL ( NIB_lst / )
(setq pea (getvar 'peditaccept))
(setvar 'peditaccept 1)
(setq ssr (ssadd))
    (foreach item NIB_lst
        (vl-catch-all-apply 'vl-cmdf (list "_.copy" item "" LL (polar LL 0 (* 12 off))))
        (vl-catch-all-apply 'vl-cmdf (list "_.explode" (entlast)))
        (setq sse (ssget "P" '((0 . "LINE") (8 . "HYPOTENUSE,BASE,PERPENDICULAR"))))
        (vl-catch-all-apply 'vl-cmdf (list "_.region" sse ""))
        (ssadd (entlast) ssr)
    )
    (vl-catch-all-apply 'vl-cmdf (list "_.union" ssr ""))
    (vl-catch-all-apply 'vl-cmdf (list "_.explode" (ssname (ssget "P" '((0 . "REGION"))) 0)))
    (vl-catch-all-apply 'vl-cmdf (list "_.pedit" "_m" (ssget "_p") "" "_j" 0.0 ""))
    (vl-catch-all-apply 'vl-cmdf (list "_.zoom" "_ob" (entlast) ""))
    (setq PLC (Poly_Cor_Extr 10 (entget (setq PL (entlast)))))
    (setq IPE (ssget "_CP" PLC))
    (vl-catch-all-apply 'vl-cmdf (list "_.zoom" "_p"))
    (if (< 1 (sslength IPE)) 
       (progn 
         (ssdel PL IPE)
         (command "_.erase" IPE "")
       )
   )
(setvar 'peditaccept pea)
)
(defun Poly_Cor_Extr (key cor / val cor_list)
   (foreach val cor
        (if (eq key (car val)) (setq cor_list (cons (cdr val) cor_list)))
   )
(reverse cor_list)
)

M.R.

BTW. Classification of unique polygons aren't included - I only used the code you attached, so you need to implement your addition further - colorize it...

[marko_ribar]

I don't know, but scaling with integer won't work as desired... So this line :

(command "scale" sel "" '(0.0 0.0 0.0) f)

should actually be :

(command "scale" sel "" '(0.0 0.0 0.0) (float f))

Sorry for mistake, I hope you don't mind my remark...

M.R.

[dbhunia]

@marko_ribar and @CodeDing thanks for your reply.... You both are right....

I also noticed that if I add these Red lines (scaling check to be added) in the Function "(C:GOL)", I am getting all the "Outlines of each geometrical shapes".... But it Increasing Program Execution timing ....

(defun c:GOL ( NIB_lst / )
(setq ssr (ssadd))
    (foreach item NIB_lst
	(vl-catch-all-apply 'vl-cmdf (list "_.copy" item "" LL (polar LL 0 (* 12 off))))
	(command "scale" (entlast) "" LL 10);;;;;;;;;;;;;;;Scaled up here (say factor 10);;;;;;;;;;;;;;
	(vl-catch-all-apply 'vl-cmdf (list "_.explode" (entlast)))
	(setq sse (ssget "P" '((0 . "LINE") (8 . "HYPOTENUSE,BASE,PERPENDICULAR"))))
	(vl-catch-all-apply 'vl-cmdf (list "_.pedit" "_m" sse "" "_y" "_j" 0.0 ""))
	(vl-catch-all-apply 'vl-cmdf (list "_.region" (entlast) ""))
	(ssadd (entlast) ssr)
    )
   (vl-catch-all-apply 'vl-cmdf (list "_.zoom" "_ob" (entlast) ""))
   (vl-catch-all-apply 'vl-cmdf (list "_.union" ssr ""))
   (vl-catch-all-apply 'vl-cmdf (list "_.explode" (ssname (ssget "P" '((0 . "REGION"))) 0)))
   (vl-catch-all-apply 'vl-cmdf (list "_.pedit" "_m" (ssget "_p") "" "_y" "_j" 0.0 ""))
   (setq PLC (Poly_Cor_Extr 10 (entget (setq PL (entlast)))))
   (setq IPE (ssget "_CP" PLC))
   (if (< 1 (sslength IPE)) 
      (progn 
	(ssdel PL IPE)
	(command "_.erase" IPE "")
      )
   )
(command "scale" (entlast) "" LL 0.1);;;;;;;;;;;;;;;Scaled down here (say factor 0.1);;;;;;;;;;;;;;
(vl-catch-all-apply 'vl-cmdf (list "_.zoom" "_p"))
)

Is this the only way for getting all the "Outlines of each geometrical shapes".....Actually I want to reduce Program Execution timing ....

[marko_ribar]

I don't know if speeding up is possible, but I played with this more over... It seems that sometimes it won't finish - it breaks... I think it has to do something with scale factor for which I searched adequate value, still with some triangular shapes it breaks... I think that I can't find correct fix - I've changed also subs for insert, align and mirror - now it uses built-in functions (align) and (mirror3d) which are implemented in geom3d.crx and for previous versions in geom3d.arx module... Also I think I localized variables better... See if you can find solution that is flawless...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun triarea (pl)
  (abs (/ (apply '+ (mapcar '(lambda (a b) (- (* (car a) (cadr b)) (* (cadr a) (car b)))) pl (append (cdr pl) (list (car pl))))) 2.0))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun unique (l)
  (if l (cons (car l) (unique (vl-remove (car l) l))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun unique-fuzz (l)
  (if l (cons (car l) (unique-fuzz (vl-remove-if '(lambda (x) (equal x (car l) 1e-5)) l))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:GBI ( sel / HY BA PE cob ) 
(gc)
(vl-load-com)
(setq PT_lst nil)
(setq COB (vlax-invoke (vlax-ename->vla-object sel) 'explode))
   (foreach COBI COB
        (setq ent (entget (vlax-vla-object->ename COBI)))
        (if (and (= (cdr (assoc 0 ent)) "LINE") (= (cdr (assoc 8 ent)) "HYPOTENUSE"))
            (setq HY (list (cdr (assoc 8 ent)) (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
        )
        (if (and (= (cdr (assoc 0 ent)) "LINE") (= (cdr (assoc 8 ent)) "BASE"))
            (setq BA (list (cdr (assoc 8 ent)) (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
        )
        (if (and (= (cdr (assoc 0 ent)) "LINE") (= (cdr (assoc 8 ent)) "PERPENDICULAR"))
            (setq PE (list (cdr (assoc 8 ent)) (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
        )
   )
(mapcar 'vla-delete COB)
(setq PT_lst (cons (list PE BA HY) PT_lst))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:INB ( / b1 b2 ib1 ib2 )
(gc)
     (setq B1 (nth 1 (nth 1 (nth 0 PT_lst))) B2 (nth 2 (nth 1 (nth 0 PT_lst))))
     (command "insert" (cdr (assoc 2 (entget sel))) B1 "" "" "")
     (C:GBI (entlast))
     (setq IB1 (nth 1 (nth 2 (nth 0 PT_lst))) IB2 (nth 2 (nth 2 (nth 0 PT_lst)))) 
     (if (or (= N 1) (= N 3))
           (progn (align (entlast) IB1 B1 IB2 B2 "" "Y")
                  (if (= N 1) (mirror3d (entlast) "3p" B1 B2 (mapcar '+ B2 '(0.0 0.0 1.0)) "Y"))
           )
           (progn (align (entlast) IB1 B2 IB2 B1 "" "Y")
                  (if (= N 2) (mirror3d (entlast) "3p" B1 B2 (mapcar '+ B2 '(0.0 0.0 1.0)) "Y"))
           )
     )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:NTH ( / ib_lst_n n add n1 be aa i e )
(gc)
(foreach B IB_lst
    (setq N 0)
    (setq B (reverse B))
    (setq IB (polar IB (* pi 1.5) off))
    (setq IBX (list IB (polar IB 0 off) (polar IB 0 (* 2 off)) (polar IB 0 (* 3 off))))
    (foreach PT IBX
        (setq add (ssadd))
        (repeat (setq N1 (length B))
                (setq BE (nth (setq N1 (- N1 1)) B))
                (command "copy" BE "" LL PT) 
                (ssadd (entlast) add)
        )
        (setq N (+ N 1))
        (C:GBI (entlast))
        (C:INB)
        (ssadd (entlast) add)
        (setq aa nil)
        (repeat (setq i (sslength add))
                (setq e (ssname add (setq i (1- i))))
                (setq aa (cons e aa))
        )
        (if (= "Yes" Ans) (C:GOL aa))
        (setq IB_lst_N (cons aa IB_lst_N))
    )
)
(setq IB_lst IB_lst_N)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:GOL ( NIB_lst / pea ssr sse rl pl plc ipe )
(gc)
(setq pea (getvar "peditaccept"))
(setvar "peditaccept" 1)
(setq ssr (ssadd))
    (foreach item NIB_lst
        (vl-catch-all-apply 'vl-cmdf (list "_.copy" item "" LL (polar LL 0 (* 12 off))))
        (vl-catch-all-apply 'vl-cmdf (list "_.explode" (entlast)))
        (setq sse (ssget "P" '((0 . "LINE") (8 . "HYPOTENUSE,BASE,PERPENDICULAR"))))
        (vl-catch-all-apply 'vl-cmdf (list "_.region" sse ""))
        (if (= (cdr (assoc 0 (entget (entlast)))) "REGION")
          (progn
            (ssadd (entlast) ssr)
            (setq rl (cons (entlast) rl))
          )
        )
    )
    (vl-catch-all-apply 'vl-cmdf (list "_.union" ssr ""))
    (vl-catch-all-apply 'vl-cmdf (list "_.explode" (car (vl-remove-if '(lambda (x) (vlax-erased-p x)) rl))))
    (vl-catch-all-apply 'vl-cmdf (list "_.pedit" "_m" (ssget "_p") "" "_j" 0.0 ""))
    (vl-catch-all-apply 'vl-cmdf (list "_.zoom" "_ob" (entlast) ""))
    (vl-catch-all-apply 'vl-cmdf (list "_.zoom" "0.5xp"))
    (setq PLC (Poly_Cor_Extr 10 (entget (setq PL (entlast)))))
    (setq IPE (ssget "_CP" (unique-fuzz PLC)))
    (vl-catch-all-apply 'vl-cmdf (list "_.zoom" "_p"))
    (vl-catch-all-apply 'vl-cmdf (list "_.zoom" "_p"))
    (if (< 1 (sslength IPE)) 
       (progn 
         (ssdel PL IPE)
         (command "_.erase" IPE "")
       )
   )
(setvar "peditaccept" pea)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Poly_Cor_Extr ( key cor / val cor_list )
   (foreach val cor
        (if (eq key (car val)) (setq cor_list (cons (cdr val) cor_list)))
   )
(reverse cor_list)
)



(defun c:GTN ( / ss sel pow ans osm bp el pl f ll ur n ent_lst pib count )
(vl-load-com)
(if (and (not (vl-position "geom3d.arx" (arx))) (not (vl-position "geom3d.crx" (arx))))
  (if (findfile "geom3d.crx")
    (arxload (findfile "geom3d.crx"))
    (arxload (findfile "geom3d.arx"))
  )
)
(while (or (not (setq sel (car (entsel "\nSelect Triangle Block: "))))
           (not (setq Pow (getint "\nEnter Power: ")))
           (not (= (cdr (assoc 0 (entget sel))) "INSERT"))
       )
       (prompt "\nInvalid...")
)
(initget "Yes No")
(setq Ans (cond ((getkword "\nDo you want Boundary [Yes/No] <No>: ")) ("No")))
(setvar "cmdecho" 0)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq bp (cdr (assoc 10 (entget sel))))
(entupd (cdr (assoc -1 (entmod (subst '(10 0.0 0.0 0.0) (cons 10 bp) (entget sel))))))
(setq el (entlast))
(C:GBI sel)
(setq pl (unique (apply 'append (mapcar 'cdr (car PT_lst)))))
(if (< (sqrt (triarea pl)) 0.025)
  (progn
    (setq f (/ 0.025 (sqrt (triarea pl))))
    (command "scale" sel "" '(0.0 0.0 0.0) (float f))
    (C:GBI sel)
  )
)
(vla-getBoundingBox (vlax-ename->vla-object sel) 'll 'ur)
(setq LL (vlax-safearray->list ll) UR (vlax-safearray->list ur) ISB LL)
(setq Off (* (distance LL UR) 2.0))
(setq IB (polar ISB (* pi 1.5) off))
(setq IB (list IB (polar IB 0 off) (polar IB 0 (* 2 off)) (polar IB 0 (* 3 off))))
(setq IB_lst nil)
(foreach PT IB
     (command "copy" sel "" LL PT) (setq IB_lst (cons (list (entlast)) IB_lst))
)
(setq NIB_lst nil)
(repeat (setq N (length IB_lst))
     (setq Ent_lst (nth (setq N (- N 1)) IB_lst))
     (C:GBI (setq PIB (nth (1- (length Ent_lst)) Ent_lst)))
     (C:INB)
     (setq NIB_lst (cons (list PIB (entlast)) NIB_lst))
)
(if (= "Yes" Ans) (foreach L_item NIB_lst (C:GOL L_item)))
(setq IB_lst NIB_lst)
(setq IB (nth 0 IB))
(setq Pow (- Pow 1) count 1)
(while (/= count Pow)
    (C:NTH) (setq count (+ count 1))
)
(setq ss (ssadd))
(while (setq el (entnext el))
  (if (not (vlax-erased-p el))
    (ssadd el ss)
  )
)
(if f
  (progn
    (command "scale" ss "" '(0.0 0.0 0.0) (/ 1.0 f))
    (command "scale" sel "" '(0.0 0.0 0.0) (/ 1.0 f))
  )
)
(command "move" ss "" '(0.0 0.0 0.0) bp)
(entupd (cdr (assoc -1 (entmod (subst (cons 10 bp) '(10 0.0 0.0 0.0) (entget sel))))))
(setvar "cmdecho" 1)
(setvar "osmode" osm)
(setq PT_lst nil ISB nil Off nil IB nil IB_lst nil NIB_lst nil)
(princ)
)

Regards, M.R.

[marko_ribar]

I've modified it further more - the code is now shorter and works faster, but still it breaks... I don't know where is the problem and how could it be fixed - it seems that for more samples CAD memory is exhausted and just breaks for power > 4... Still I hope that my mods are not totally garbage, so I'll post it...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun triarea (pl)
  (abs
    (/ (apply
         '+
         (mapcar
           '(lambda (a b) (- (* (car a) (cadr b)) (* (cadr a) (car b))))
           pl
           (append (cdr pl) (list (car pl)))
         )
       )
       2.0
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun unique (l)
  (if l
    (cons (car l) (unique (vl-remove (car l) l)))
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:GBI (sel / HY BA PE cob ent)
  (vl-load-com)
  (setq PT_lst nil)
  (setq COB (vlax-invoke (vlax-ename->vla-object sel) 'explode))
  (foreach COBI COB
    (setq ent (entget (vlax-vla-object->ename COBI)))
    (cond
      ((and (= (cdr (assoc 0 ent)) "LINE")
            (= (cdr (assoc 8 ent)) "HYPOTENUSE")
       )
       (setq HY (list (cdr (assoc 8 ent))
                      (cdr (assoc 10 ent))
                      (cdr (assoc 11 ent))
                )
       )
      )
      ((and (= (cdr (assoc 0 ent)) "LINE")
            (= (cdr (assoc 8 ent)) "BASE")
       )
       (setq BA (list (cdr (assoc 8 ent))
                      (cdr (assoc 10 ent))
                      (cdr (assoc 11 ent))
                )
       )
      )
      ((and (= (cdr (assoc 0 ent)) "LINE")
            (= (cdr (assoc 8 ent)) "PERPENDICULAR")
       )
       (setq PE (list (cdr (assoc 8 ent))
                      (cdr (assoc 10 ent))
                      (cdr (assoc 11 ent))
                )
       )
      )
    )
  )
  (mapcar 'vla-delete COB)
  (setq PT_lst (cons (list PE BA HY) PT_lst))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:INB (/ b1 b2 ib1 ib2)
  (setq B1 (nth 1 (nth 1 (nth 0 PT_lst)))
        B2 (nth 2 (nth 1 (nth 0 PT_lst)))
  )
  (command "_.insert"
           (cdr (assoc 2 (entget sel)))
           B1
           ""
           ""
           ""
  )
  (C:GBI (entlast))
  (setq IB1 (nth 1 (nth 2 (nth 0 PT_lst)))
        IB2 (nth 2 (nth 2 (nth 0 PT_lst)))
  )
  (if (or (= N 1) (= N 3))
    (progn (align (entlast) IB1 B1 IB2 B2 "" "_Y")
           (if (= N 1)
             (mirror3d (entlast)
                       "_3p"
                       B1
                       B2
                       (mapcar '+ B2 '(0.0 0.0 1.0))
                       "_Y"
             )
           )
    )
    (progn (align (entlast) IB1 B2 IB2 B1 "" "_Y")
           (if (= N 2)
             (mirror3d (entlast)
                       "_3p"
                       B1
                       B2
                       (mapcar '+ B2 '(0.0 0.0 1.0))
                       "_Y"
             )
           )
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:NTH (/ ib_lst_n n add n1 be ibx)
  (foreach B IB_lst
    (setq N 0)
    (setq B (reverse B))
    (setq IB (polar IB (* pi 1.5) off))
    (setq IBX (list IB
                    (polar IB 0 off)
                    (polar IB 0 (* 2 off))
                    (polar IB 0 (* 3 off))
              )
    )
    (foreach PT IBX
      (setq add nil)
      (repeat (setq N1 (length B))
        (setq BE (nth (setq N1 (- N1 1)) B))
        (command "_.copy" BE "" LL PT)
        (setq add (cons (entlast) add))
      )
      (setq N (+ N 1))
      (C:GBI (entlast))
      (C:INB)
      (if (not (vl-position (entlast) add))
        (setq add (cons (entlast) add))
      )
      (if (= "Yes" Ans)
        (C:GOL add)
      )
      (setq IB_lst_N (cons add IB_lst_N))
    )
  )
  (setq IB_lst IB_lst_N)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:GOL (NIB_lst / pea li e rl)
  (vl-load-com)
  (setq pea (getvar "peditaccept"))
  (setvar "peditaccept" 1)
  (foreach item NIB_lst
    (command "_.copy" item "" LL (polar LL 0 (* 12 off)))
    (setq li (vlax-invoke
               (vlax-ename->vla-object (setq e (entlast)))
               'explode
             )
    )
    (vlax-invoke
      (vla-get-block
        (vla-get-activelayout
          (vla-get-activedocument (vlax-get-acad-object))
        )
      )
      'addregion
      li
    )
    (if (= (cdr (assoc 0 (entget (entlast)))) "REGION")
      (setq rl (cons (entlast) rl))
    )
    (if (and e (not (vlax-erased-p e)))
      (entdel e)
    )
    (mapcar 'vla-delete li)
  )
  (if (> (length rl) 1)
    (while (/= (length rl) 1)
      (command "_.union" (car rl) (cadr rl) "")
      (setq rl (vl-remove-if '(lambda (x) (vlax-erased-p x)) rl))
    )
  )
  (setq li (vlax-invoke
             (vlax-ename->vla-object (setq e (car rl)))
             'explode
           )
  )
  (apply 'vl-cmdf
         (cons "_.pedit"
               (cons "_m"
                     (append (mapcar 'vlax-vla-object->ename li)
                             (list "" "_j" 0.0 "")
                     )
               )
         )
  )
  (if (and e (not (vlax-erased-p e)))
    (entdel e)
  )
  (setvar "peditaccept" pea)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:GTN (/ ss sel pow ans osm bp el pl f ll ur n ent_lst pib count
              PT_lst ISB Off IB IB_lst NIB_lst
             )
  (vl-load-com)
  (if (and (not (vl-position "geom3d.arx" (arx)))
           (not (vl-position "geom3d.crx" (arx)))
      )
    (if (findfile "geom3d.crx")
      (arxload (findfile "geom3d.crx"))
      (arxload (findfile "geom3d.arx"))
    )
  )
  (while
    (or (not (setq sel (car (entsel "\nSelect Triangle Block: "))))
        (not (setq Pow (getint "\nEnter Power: ")))
        (not (= (cdr (assoc 0 (entget sel))) "INSERT"))
    )
     (prompt "\nInvalid...")
  )
  (initget "Yes No")
  (setq
    Ans (cond ((getkword "\nDo you want Boundary [Yes/No] <No>: "))
              ("No")
        )
  )
  (setvar "cmdecho" 0)
  (setq osm (getvar "osmode"))
  (setvar "osmode" 0)
  (setq bp (cdr (assoc 10 (entget sel))))
  (entupd
    (cdr
      (assoc -1
             (entmod (subst '(10 0.0 0.0 0.0) (cons 10 bp) (entget sel)))
      )
    )
  )
  (setq el (entlast))
  (C:GBI sel)
  (setq pl (unique (apply 'append (mapcar 'cdr (car PT_lst)))))
  (if (< (sqrt (triarea pl)) 0.025)
    (progn
      (setq f (/ 0.025 (sqrt (triarea pl))))
      (command "_.scale" sel "" '(0.0 0.0 0.0) (float f))
      (C:GBI sel)
    )
  )
  (vla-getBoundingBox (vlax-ename->vla-object sel) 'll 'ur)
  (setq LL  (vlax-safearray->list ll)
        UR  (vlax-safearray->list ur)
        ISB LL
  )
  (setq Off (* (distance LL UR) 2.0))
  (setq IB (polar ISB (* pi 1.5) off))
  (setq IB (list IB
                 (polar IB 0 off)
                 (polar IB 0 (* 2 off))
                 (polar IB 0 (* 3 off))
           )
  )
  (setq IB_lst nil)
  (foreach PT IB
    (command "_.copy" sel "" LL PT)
    (setq IB_lst (cons (list (entlast)) IB_lst))
  )
  (setq NIB_lst nil)
  (repeat (setq N (length IB_lst))
    (setq Ent_lst (nth (setq N (- N 1)) IB_lst))
    (C:GBI (setq PIB (nth (1- (length Ent_lst)) Ent_lst)))
    (C:INB)
    (setq NIB_lst (cons (list PIB (entlast)) NIB_lst))
  )
  (if (= "Yes" Ans)
    (foreach L_item NIB_lst (C:GOL L_item))
  )
  (setq IB_lst NIB_lst)
  (setq IB (nth 0 IB))
  (setq Pow   (- Pow 1)
        count 1
  )
  (while (/= count Pow)
    (C:NTH)
    (setq count (+ count 1))
  )
  (setq ss (ssadd))
  (while (setq el (entnext el))
    (if (not (vlax-erased-p el))
      (ssadd el ss)
    )
  )
  (if f
    (progn
      (command "_.scale" ss "" '(0.0 0.0 0.0) (/ 1.0 f))
      (command "_.scale" sel "" '(0.0 0.0 0.0) (/ 1.0 f))
    )
  )
  (command "_.move" ss "" '(0.0 0.0 0.0) bp)
  (entupd
    (cdr
      (assoc -1
             (entmod (subst (cons 10 bp) '(10 0.0 0.0 0.0) (entget sel)))
      )
    )
  )
  (setvar "cmdecho" 1)
  (setvar "osmode" osm)
  (princ)
)

HTH., M.R.

P.S. Now formatted through VLIDE, so it looks more robust, but the code is actually shorter...

[dbhunia]

I also facing this problem......Probably due to recursive Augmentation of locked set of shapes the size of the array is increasing......And at a certain point the loop is breaking......

[SanjoyNath]

Dear Experts of Lisp,

Dear @dbhunia

Fantastic roadsmap is visible now. World will very soon see how Autocad can prove Trigonometric Expressions Automatically through Geometry PWW (Picture Proof Through Proof Without Words) and expressing all four types of multiplications and divisions through Arrangements of Locked Sets. I am obliged that the Algorithm of Geometrifying Trigonometry(C) working fantastic as we have thought.

Please enter the operation names below the pictures to cross verify the merged lines and perpendicular bisectors reference flipping working fine 

https://github.com/SanjoyNath/GeometrifyingTrigonometry/wiki/Geometrifying-Trigonometry(C)-SanjoyNat...

example

[doaiena]

This project, that you guys have going on, is a cool proof of concept, but it might not work the way you have started it. AutoCAD was not intended to be a maths engine and the data types used are prone to error, especially during recursive operations, performed on large data sets. Depending on the data set and the functions used, the error will get larger as the recursion goes deeper. Because of that, sometimes you might get an unexpected result.

On another note, i would strongly suggest you port your code to .NET or C++. Gather all the data you need from AutoCAD, send it over to a new application that will do all the math work, and pass the results back to AutoCAD. You can then take advantage of multithreading /wherever possible/ and better manage your memory usage, without having AutoCAD constantly read and write to its database during the calculations. That way the application would be tens of times faster and it will give you the ability to perform deeper recursions and use larger data sets.

[SanjoyNath]

Thank you very much  @doaiena

The challenge to prepare geometric proofs for Trigonometric expressions came later.Problem started with unique nomenclature of any type of irregular polygons through Triangulations.We tried some reverse approaches also.We are preparing Geometrifying Trigonometry(C) engine in c#, c++ , java through implementation of  BOOST , CGAL , Open CV, Dot Numerics...

Some times we have used Some of Matlab also.

Autocad Lisp is the best because Geometrifying Trigonometry(C) Locked Set concept directly relates Autocads Block and even after the complete program runs we can bedit the block(Geometrifying Trigonometry(C) Locked Set of Line segments) to see after effects which is not possible in any other framework

Moreover the * operation of Geometrifying Trigonometry(C) has four different varieties

∞  Align and scale to fit Direct command in Autocad through lisp , which needs several Affine Transformation in c#

( @dbhunia  my very good friend is very expert in that)

 ó Direct mirror command in Autocad (We are using this CAD and lisp from 1998) about merged line

ö Double Direct mirror command in Autocad (We are using this CAD and lisp from 1998) about merged line and on Perpendicular Bisector of merged line . Writing these things in c++ or in c" is very tedious where lisp does these in 3 lines of command code

ò Direct mirror command in Autocad (We are using this CAD and lisp from 1998) about perpendicular bisector merged line

which are readymade commands in Autocad Autolisp.

Thanks to Autocad , Thanks to Autolisp that it is working as Automated Geometry Generation Engine from Any Given Trigonometric Expression through Theory of Geometrifying Trigonometry(C) which will help everyone to visualize geometric proofs (Many possible shapes and orientations whose colors are changeable through direct one point color changing in layers settings which is not possible in other mathematical packages)