Jump to content

help to improve lisp routine, (coordinate grid)

Omar ugarte

By Omar ugarte
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Omar ugarte Newbie

Omar ugarte

Posted
Posted

Hello everyone.
I need to improve a Lisp routine. I've had this routine for a few years; a coworker gave it to me.
It's a Lisp routine for generating a coordinate grid from a selection of three points.
I need to eliminate the insertion of three points (vertices). I want to be able to select a closed polyline with a single click and generate the grid.
I want to keep the entire structure of the Lisp; I only want to change the vertex selection.
I should mention that I have no experience programming AutoLISP.
Please, if you can help me with this.

  

(defun strpto (aa / largo)
	(setq largo (strlen aa))
	(cond ((< largo 4) aa)
		((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
		((= largo 7) (strcat (substr aa 1 1) "." (substr aa 2 3) "." (substr aa 5 3)))
		(t aa)
	)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
   (setq a1 (- (cadr p2)(cadr p1))
         a2 (- (cadr p4)(cadr p2))
         a3 (- (cadr p3)(cadr p4))
         a4 (- (cadr p1)(cadr p3))
         b1 (- (car p1)(car p2))
         b2 (- (car p2)(car p4))
         b3 (- (car p4)(car p3))
         b4 (- (car p3)(car p1))
         c1 (- (* (car p1)(cadr p2))(* (car p2)(cadr p1)))
         c2 (- (* (car p2)(cadr p4))(* (car p4)(cadr p2)))
         c3 (- (* (car p4)(cadr p3))(* (car p3)(cadr p4)))
         c4 (- (* (car p3)(cadr p1))(* (car p1)(cadr p3)))
   )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX (a b c y)
   (if (= 0.0 a)            ; no hay interseccion
       nil
       (/ (- c (* b y)) a)
   )
)

(Defun IntersecX ( / l lista)
   (setq l ()
         lista (list (CalculaX a1 b1 c1 startY) (CalculaX a2 b2 c2 startY)
                     (CalculaX a3 b3 c3 startY) (CalculaX a4 b4 c4 startY)
               )
   )
   (while (/= lista nil)
       (setq x (car lista))
       (if (and (/= x nil) (<= x maxX) (>= x minX))
           (setq l (append l (list x)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY (a b c x)
   (if (= 0.0 b)                 ; no hay interseccion
       nil
       (/ (- c (* a x)) b)
   )
)

(Defun IntersecY ( / l lista)
   (setq l ()
         lista (list (CalculaY a1 b1 c1 startX) (CalculaY a2 b2 c2 startX)
                     (CalculaY a3 b3 c3 startX) (CalculaY a4 b4 c4 startX)
               )
   )
   (while (/= lista nil)
       (setq y (car lista))
       (if (and (/= y nil) (<= y maxY) (>= y minY))
           (setq l (append l (list y)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla (/ p1 p2 p3 p4 paux incx incy l h n maldato base
                   alfa startX startY minX minY maxX maxY)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
  (setq p1 (getpoint "\nIngrese un vertice de la region ")
        p2 (getpoint p1 "\nIngrese el otro vertice ")
  )
  (command "LINE" p1 p2 "")
  (if (> (cadr p1)(cadr p2))              ; siempre el p1 abajo
      (setq paux p1 p1 p2 p2 paux)
  )
  (setq p3 (getpoint p1 "\nIngrese punto para Ancho de la region ")
        l (distance p1 p3)        ; calculo de puntos p3 y p4 , paralelos
        alfa (angle p1 p2)        ; a p1 y p2 a distancia l
        alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
         (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
      (if (< (* (- (car p2)(car p1)) (- (cadr p3)(cadr p1))) 0.0)
          (setq alfa (+ pi alfa))
      )
  )
  (setq p3 (list (+ (car p1)(* l (cos alfa))) (+ (cadr p1)(* l (sin alfa))))
        p4 (list (+ (car p2)(* l (cos alfa))) (+ (cadr p2)(* l (sin alfa))))
  )
  (command "LINE" p1 p2 p4 p3 "C")                 ; marco exterior
  (if (< (cadr p3) (cadr p1))                      ; punto1 siempre mas bajo
      (setq  paux p1 p1 p3 p3 paux paux p2 p2 p4 p4 paux)
  )
  (setq minX (min (car p2) (car p3))
        maxX (max (car p2) (car p3))
        minY (cadr p1)
        maxY (cadr p4)
        l (- maxX minX)
        h (- maxY minY)
        malDato 1
  )
  (while (= malDato 1)
         (setq incx (getreal "\nIncremento malla (m) :"))
         (if (< (abs (/ l 3)) incrx)
             (print "\nIncremento muy grande")
             (setq malDato 0)
         )
  )

  (setq incy incx)

  (setq n (fix (/ minX incx))             ; posiciones donde comenzar
        startX (* (1+ n) incx)            ; el cuadriculado
        n (fix (/ minY incy))             ; tanto en X como en Y
        startY (* (1+ n) incy)
        largoMax (max (distance p1 p3)    ; el largo maximo de la region
                      (distance p1 p4)
                 )
  )
  (if (< minX 0)
      (setq startX (- startX incx))
  )
  (if (< minY 0)
      (setq startY (- startY incy))
  )

  (setq ff     (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala)) ; alto de los caracteres

  (setq angP1P3 (angle p1 p3)
        angP1P2 (angle p1 p2)
        angBorde (min (abs angP1P3)(abs angP1P2))
        dh (min (/ incx 40.0)(/ incy 40.0))
        x1 minX              ; el caso en que no hay que rotar
        x2 maxX
        y1 minY
        y2 maxY
  )
  (if (or (= (cadr p1)(cadr p2)) (= (car p1)(car p3)) (= (car p1)(car p2)))
      (setq revisar 0
            dl (min (/ incx 30.0)(/ incy 30.0))
      )
      (setq revisar 1
            dl (* (* alto (/ (cos angBorde)(sin angBorde))) 2)
      )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
         (if (= revisar 1)
            (setq ptos (IntersecX)
                  x1 (car ptos)
                  x2 (cadr ptos)
            )
         )
         (setq coordY (rtos startY 2 0)
               coordY (strcat "N-" (strpto coordY))
         )
         (command "LINE" (list x1 startY) (list x2 startY) "")
         (cond ((> (- maxY startY) (* 2 alto))
                (command "TEXT" (list (+ x1 dl) (+ startY dh)) alto 0 coordY)
                (command "TEXT" "R" (list (- x2 dl) (+ startY dh)) alto 0 coordY)
               )
         )
         (setq startY (+ startY incy))
  )
  (while (< startX maxX)
         (if (= revisar 1)
             (setq ptos (IntersecY)
                   y1 (car ptos)
                   y2 (cadr ptos)
             )

         )
         (setq coordX (rtos startX 2 0)
               coordX (strcat "E-" (strpto coordX))
         )
         (command "LINE" (list startX y1) (list startX y2) "")
         (cond ((> (- startX minX) (* 2 alto))
                (command "TEXT" (list (- startX dh) (+ y1 dl)) alto 100 coordX)
                (command "TEXT" "R" (list (- startX dh) (- y2 dl)) alto 100 coordX)
               )
         )
         (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
      (setq alfa angP1P3)
      (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
      (setq alfarad (* -1 alfa)
            alfa (* -1 (/ (* 200 alfa) pi))
            p4 (list (- (* (car p4)(cos alfarad)) (* (cadr p4) (sin alfarad)))
                     (+ (* (car p4)(sin alfarad)) (* (cadr p4) (cos alfarad)))
               )
            p1 (list (- (* (car p1)(cos alfarad)) (* (cadr p1)(sin alfarad)))
                     (+ (* (car p1)(sin alfarad)) (* (cadr p1)(cos alfarad)))
               )
            base (list 0.0 0.0)   ; el origen
       )
  )
    (command "_.undo" "end")
    (command "_.undo" "auto" "on")
;;  (command "units" "2" "3" "3" "4" "n" "y")
)

 

GLAVCVS Experienced

GLAVCVS

Posted
Posted
6 hours ago, Omar ugarte said:

Hello everyone.
I need to improve a Lisp routine. I've had this routine for a few years; a coworker gave it to me.
It's a Lisp routine for generating a coordinate grid from a selection of three points.
I need to eliminate the insertion of three points (vertices). I want to be able to select a closed polyline with a single click and generate the grid.
I want to keep the entire structure of the Lisp; I only want to change the vertex selection.
I should mention that I have no experience programming AutoLISP.
Please, if you can help me with this.

  

(defun strpto (aa / largo)
	(setq largo (strlen aa))
	(cond ((< largo 4) aa)
		((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
		((= largo 7) (strcat (substr aa 1 1) "." (substr aa 2 3) "." (substr aa 5 3)))
		(t aa)
	)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
   (setq a1 (- (cadr p2)(cadr p1))
         a2 (- (cadr p4)(cadr p2))
         a3 (- (cadr p3)(cadr p4))
         a4 (- (cadr p1)(cadr p3))
         b1 (- (car p1)(car p2))
         b2 (- (car p2)(car p4))
         b3 (- (car p4)(car p3))
         b4 (- (car p3)(car p1))
         c1 (- (* (car p1)(cadr p2))(* (car p2)(cadr p1)))
         c2 (- (* (car p2)(cadr p4))(* (car p4)(cadr p2)))
         c3 (- (* (car p4)(cadr p3))(* (car p3)(cadr p4)))
         c4 (- (* (car p3)(cadr p1))(* (car p1)(cadr p3)))
   )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX (a b c y)
   (if (= 0.0 a)            ; no hay interseccion
       nil
       (/ (- c (* b y)) a)
   )
)

(Defun IntersecX ( / l lista)
   (setq l ()
         lista (list (CalculaX a1 b1 c1 startY) (CalculaX a2 b2 c2 startY)
                     (CalculaX a3 b3 c3 startY) (CalculaX a4 b4 c4 startY)
               )
   )
   (while (/= lista nil)
       (setq x (car lista))
       (if (and (/= x nil) (<= x maxX) (>= x minX))
           (setq l (append l (list x)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY (a b c x)
   (if (= 0.0 b)                 ; no hay interseccion
       nil
       (/ (- c (* a x)) b)
   )
)

(Defun IntersecY ( / l lista)
   (setq l ()
         lista (list (CalculaY a1 b1 c1 startX) (CalculaY a2 b2 c2 startX)
                     (CalculaY a3 b3 c3 startX) (CalculaY a4 b4 c4 startX)
               )
   )
   (while (/= lista nil)
       (setq y (car lista))
       (if (and (/= y nil) (<= y maxY) (>= y minY))
           (setq l (append l (list y)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla (/ p1 p2 p3 p4 paux incx incy l h n maldato base
                   alfa startX startY minX minY maxX maxY)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
  (setq p1 (getpoint "\nIngrese un vertice de la region ")
        p2 (getpoint p1 "\nIngrese el otro vertice ")
  )
  (command "LINE" p1 p2 "")
  (if (> (cadr p1)(cadr p2))              ; siempre el p1 abajo
      (setq paux p1 p1 p2 p2 paux)
  )
  (setq p3 (getpoint p1 "\nIngrese punto para Ancho de la region ")
        l (distance p1 p3)        ; calculo de puntos p3 y p4 , paralelos
        alfa (angle p1 p2)        ; a p1 y p2 a distancia l
        alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
         (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
      (if (< (* (- (car p2)(car p1)) (- (cadr p3)(cadr p1))) 0.0)
          (setq alfa (+ pi alfa))
      )
  )
  (setq p3 (list (+ (car p1)(* l (cos alfa))) (+ (cadr p1)(* l (sin alfa))))
        p4 (list (+ (car p2)(* l (cos alfa))) (+ (cadr p2)(* l (sin alfa))))
  )
  (command "LINE" p1 p2 p4 p3 "C")                 ; marco exterior
  (if (< (cadr p3) (cadr p1))                      ; punto1 siempre mas bajo
      (setq  paux p1 p1 p3 p3 paux paux p2 p2 p4 p4 paux)
  )
  (setq minX (min (car p2) (car p3))
        maxX (max (car p2) (car p3))
        minY (cadr p1)
        maxY (cadr p4)
        l (- maxX minX)
        h (- maxY minY)
        malDato 1
  )
  (while (= malDato 1)
         (setq incx (getreal "\nIncremento malla (m) :"))
         (if (< (abs (/ l 3)) incrx)
             (print "\nIncremento muy grande")
             (setq malDato 0)
         )
  )

  (setq incy incx)

  (setq n (fix (/ minX incx))             ; posiciones donde comenzar
        startX (* (1+ n) incx)            ; el cuadriculado
        n (fix (/ minY incy))             ; tanto en X como en Y
        startY (* (1+ n) incy)
        largoMax (max (distance p1 p3)    ; el largo maximo de la region
                      (distance p1 p4)
                 )
  )
  (if (< minX 0)
      (setq startX (- startX incx))
  )
  (if (< minY 0)
      (setq startY (- startY incy))
  )

  (setq ff     (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala)) ; alto de los caracteres

  (setq angP1P3 (angle p1 p3)
        angP1P2 (angle p1 p2)
        angBorde (min (abs angP1P3)(abs angP1P2))
        dh (min (/ incx 40.0)(/ incy 40.0))
        x1 minX              ; el caso en que no hay que rotar
        x2 maxX
        y1 minY
        y2 maxY
  )
  (if (or (= (cadr p1)(cadr p2)) (= (car p1)(car p3)) (= (car p1)(car p2)))
      (setq revisar 0
            dl (min (/ incx 30.0)(/ incy 30.0))
      )
      (setq revisar 1
            dl (* (* alto (/ (cos angBorde)(sin angBorde))) 2)
      )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
         (if (= revisar 1)
            (setq ptos (IntersecX)
                  x1 (car ptos)
                  x2 (cadr ptos)
            )
         )
         (setq coordY (rtos startY 2 0)
               coordY (strcat "N-" (strpto coordY))
         )
         (command "LINE" (list x1 startY) (list x2 startY) "")
         (cond ((> (- maxY startY) (* 2 alto))
                (command "TEXT" (list (+ x1 dl) (+ startY dh)) alto 0 coordY)
                (command "TEXT" "R" (list (- x2 dl) (+ startY dh)) alto 0 coordY)
               )
         )
         (setq startY (+ startY incy))
  )
  (while (< startX maxX)
         (if (= revisar 1)
             (setq ptos (IntersecY)
                   y1 (car ptos)
                   y2 (cadr ptos)
             )

         )
         (setq coordX (rtos startX 2 0)
               coordX (strcat "E-" (strpto coordX))
         )
         (command "LINE" (list startX y1) (list startX y2) "")
         (cond ((> (- startX minX) (* 2 alto))
                (command "TEXT" (list (- startX dh) (+ y1 dl)) alto 100 coordX)
                (command "TEXT" "R" (list (- startX dh) (- y2 dl)) alto 100 coordX)
               )
         )
         (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
      (setq alfa angP1P3)
      (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
      (setq alfarad (* -1 alfa)
            alfa (* -1 (/ (* 200 alfa) pi))
            p4 (list (- (* (car p4)(cos alfarad)) (* (cadr p4) (sin alfarad)))
                     (+ (* (car p4)(sin alfarad)) (* (cadr p4) (cos alfarad)))
               )
            p1 (list (- (* (car p1)(cos alfarad)) (* (cadr p1)(sin alfarad)))
                     (+ (* (car p1)(sin alfarad)) (* (cadr p1)(cos alfarad)))
               )
            base (list 0.0 0.0)   ; el origen
       )
  )
    (command "_.undo" "end")
    (command "_.undo" "auto" "on")
;;  (command "units" "2" "3" "3" "4" "n" "y")
)

 

 

Hi Omar. Bienvenido

Try this 

(defun strpto (aa / largo)
  (setq largo (strlen aa))
  (cond	((< largo 4) aa)
	((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
	((= largo 7)
	 (strcat (substr aa 1 1)
		 "."
		 (substr aa 2 3)
		 "."
		 (substr aa 5 3)
	 )
	)
	(t aa)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
  (setq	a1 (- (cadr p2) (cadr p1))
	a2 (- (cadr p4) (cadr p2))
	a3 (- (cadr p3) (cadr p4))
	a4 (- (cadr p1) (cadr p3))
	b1 (- (car p1) (car p2))
	b2 (- (car p2) (car p4))
	b3 (- (car p4) (car p3))
	b4 (- (car p3) (car p1))
	c1 (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))
	c2 (- (* (car p2) (cadr p4)) (* (car p4) (cadr p2)))
	c3 (- (* (car p4) (cadr p3)) (* (car p3) (cadr p4)))
	c4 (- (* (car p3) (cadr p1)) (* (car p1) (cadr p3)))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX	(a b c y)
  (if (= 0.0 a)				; no hay interseccion
    nil
    (/ (- c (* b y)) a)
  )
)

(Defun IntersecX (/ l lista)
  (setq	l     ()
	lista (list (CalculaX a1 b1 c1 startY)
		    (CalculaX a2 b2 c2 startY)
		    (CalculaX a3 b3 c3 startY)
		    (CalculaX a4 b4 c4 startY)
	      )
  )
  (while (/= lista nil)
    (setq x (car lista))
    (if	(and (/= x nil) (<= x maxX) (>= x minX))
      (setq l (append l (list x)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY	(a b c x)
  (if (= 0.0 b)				; no hay interseccion
    nil
    (/ (- c (* a x)) b)
  )
)

(Defun IntersecY (/ l lista)
  (setq	l     ()
	lista (list (CalculaY a1 b1 c1 startX)
		    (CalculaY a2 b2 c2 startX)
		    (CalculaY a3 b3 c3 startX)
		    (CalculaY a4 b4 c4 startX)
	      )
  )
  (while (/= lista nil)
    (setq y (car lista))
    (if	(and (/= y nil) (<= y maxY) (>= y minY))
      (setq l (append l (list y)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)

(defun dameEsquinas (e / le lp)
  (if (= (cdr (assoc 0 (setq le (entget e)))) "LWPOLYLINE")
    (foreach l le
      (if (= (car l) 10)
	(setq lp (cons (cdr l) lp))
      )
    )
  )
  (if lp (vl-sort lp '(lambda(a b) (< (car a) (car b)))))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla	(/	p1     p2     p3     p4	    paux   incx
		 incy	l      h      n	     maldato	   base
		 alfa	startX startY minX   minY   maxX   maxY
		)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
;;;  (setq	p1 (getpoint "\nIngrese un vertice de la region ")
;;;	p2 (getpoint p1 "\nIngrese el otro vertice ")
;;;  )
;;;  (command "LINE" p1 p2 "")
  (if (not (setq e (car (entsel "\nSelecciona el marco para la grilla..."))))
    (exit)
  )
  (setq l (dameEsquinas e)
	p1 (car l)
	p2 (cadr l)
	p3 (caddr l)
	l nil
  )
  (if (> (cadr p1) (cadr p2))		; siempre el p1 abajo
    (setq paux p1
	  p1 p2
	  p2 paux
    )
  )
  (setq	p3   (getpoint p1 "\nIngrese punto para Ancho de la region ")
	l    (distance p1 p3)		; calculo de puntos p3 y p4 , paralelos
	alfa (angle p1 p2)		; a p1 y p2 a distancia l
	alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
    (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
    (if	(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) 0.0)
      (setq alfa (+ pi alfa))
    )
  )
  (setq	p3 (list (+ (car p1) (* l (cos alfa)))
		 (+ (cadr p1) (* l (sin alfa)))
	   )
	p4 (list (+ (car p2) (* l (cos alfa)))
		 (+ (cadr p2) (* l (sin alfa)))
	   )
  )
  (command "LINE" p1 p2 p4 p3 "C")	; marco exterior
  (if (< (cadr p3) (cadr p1))		; punto1 siempre mas bajo
    (setq paux p1
	  p1 p3
	  p3 paux
	  paux p2
	  p2 p4
	  p4 paux
    )
  )
  (setq	minX	(min (car p2) (car p3))
	maxX	(max (car p2) (car p3))
	minY	(cadr p1)
	maxY	(cadr p4)
	l	(- maxX minX)
	h	(- maxY minY)
	malDato	1
  )
  (while (= malDato 1)
    (setq incx (getreal "\nIncremento malla (m) :"))
    (if	(< (abs (/ l 3)) incrx)
      (print "\nIncremento muy grande")
      (setq malDato 0)
    )
  )

  (setq incy incx)

  (setq	n	 (fix (/ minX incx))	; posiciones donde comenzar
	startX	 (* (1+ n) incx)	; el cuadriculado
	n	 (fix (/ minY incy))	; tanto en X como en Y
	startY	 (* (1+ n) incy)
	largoMax (max (distance p1 p3)	; el largo maximo de la region
		      (distance p1 p4)
		 )
  )
  (if (< minX 0)
    (setq startX (- startX incx))
  )
  (if (< minY 0)
    (setq startY (- startY incy))
  )

  (setq ff (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala))	; alto de los caracteres

  (setq	angP1P3	 (angle p1 p3)
	angP1P2	 (angle p1 p2)
	angBorde (min (abs angP1P3) (abs angP1P2))
	dh	 (min (/ incx 40.0) (/ incy 40.0))
	x1	 minX			; el caso en que no hay que rotar
	x2	 maxX
	y1	 minY
	y2	 maxY
  )
  (if (or (= (cadr p1) (cadr p2))
	  (= (car p1) (car p3))
	  (= (car p1) (car p2))
      )
    (setq revisar 0
	  dl	  (min (/ incx 30.0) (/ incy 30.0))
    )
    (setq revisar 1
	  dl	  (* (* alto (/ (cos angBorde) (sin angBorde))) 2)
    )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
    (if	(= revisar 1)
      (setq ptos (IntersecX)
	    x1	 (car ptos)
	    x2	 (cadr ptos)
      )
    )
    (setq coordY (rtos startY 2 0)
	  coordY (strcat "N-" (strpto coordY))
    )
    (command "LINE" (list x1 startY) (list x2 startY) "")
    (cond ((> (- maxY startY) (* 2 alto))
	   (command "TEXT"
		    (list (+ x1 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	   (command "TEXT"
		    "R"
		    (list (- x2 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	  )
    )
    (setq startY (+ startY incy))
  )
  (while (< startX maxX)
    (if	(= revisar 1)
      (setq ptos (IntersecY)
	    y1	 (car ptos)
	    y2	 (cadr ptos)
      )

    )
    (setq coordX (rtos startX 2 0)
	  coordX (strcat "E-" (strpto coordX))
    )
    (command "LINE" (list startX y1) (list startX y2) "")
    (cond ((> (- startX minX) (* 2 alto))
	   (command "TEXT"
		    (list (- startX dh) (+ y1 dl))
		    alto
		    100
		    coordX
	   )
	   (command "TEXT"
		    "R"
		    (list (- startX dh) (- y2 dl))
		    alto
		    100
		    coordX
	   )
	  )
    )
    (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
    (setq alfa angP1P3)
    (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
    (setq alfarad (* -1 alfa)
	  alfa	  (* -1 (/ (* 200 alfa) pi))
	  p4	  (list	(- (* (car p4) (cos alfarad)) (* (cadr p4) (sin alfarad)))
			(+ (* (car p4) (sin alfarad)) (* (cadr p4) (cos alfarad)))
		  )
	  p1	  (list	(- (* (car p1) (cos alfarad)) (* (cadr p1) (sin alfarad)))
			(+ (* (car p1) (sin alfarad)) (* (cadr p1) (cos alfarad)))
		  )
	  base	  (list 0.0 0.0)	; el origen
    )
  )
  (command "_.undo" "end")
  (command "_.undo" "auto" "on")
  ;;  (command "units" "2" "3" "3" "4" "n" "y")
)

 

The "command" calls in your code are designed for an English version of AutoCAD, and mine is in Spanish.
For this reason, and due to lack of time, I haven't tested the code sufficiently.

Try it yourself and then comment on the results.

  • Thanks 1
Omar ugarte Newbie

Omar ugarte

Posted
  • Author
Posted
1 hour ago, GLAVCVS said:

 

Hi Omar. Bienvenido

Try this 

(defun strpto (aa / largo)
  (setq largo (strlen aa))
  (cond	((< largo 4) aa)
	((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
	((= largo 7)
	 (strcat (substr aa 1 1)
		 "."
		 (substr aa 2 3)
		 "."
		 (substr aa 5 3)
	 )
	)
	(t aa)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
  (setq	a1 (- (cadr p2) (cadr p1))
	a2 (- (cadr p4) (cadr p2))
	a3 (- (cadr p3) (cadr p4))
	a4 (- (cadr p1) (cadr p3))
	b1 (- (car p1) (car p2))
	b2 (- (car p2) (car p4))
	b3 (- (car p4) (car p3))
	b4 (- (car p3) (car p1))
	c1 (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))
	c2 (- (* (car p2) (cadr p4)) (* (car p4) (cadr p2)))
	c3 (- (* (car p4) (cadr p3)) (* (car p3) (cadr p4)))
	c4 (- (* (car p3) (cadr p1)) (* (car p1) (cadr p3)))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX	(a b c y)
  (if (= 0.0 a)				; no hay interseccion
    nil
    (/ (- c (* b y)) a)
  )
)

(Defun IntersecX (/ l lista)
  (setq	l     ()
	lista (list (CalculaX a1 b1 c1 startY)
		    (CalculaX a2 b2 c2 startY)
		    (CalculaX a3 b3 c3 startY)
		    (CalculaX a4 b4 c4 startY)
	      )
  )
  (while (/= lista nil)
    (setq x (car lista))
    (if	(and (/= x nil) (<= x maxX) (>= x minX))
      (setq l (append l (list x)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY	(a b c x)
  (if (= 0.0 b)				; no hay interseccion
    nil
    (/ (- c (* a x)) b)
  )
)

(Defun IntersecY (/ l lista)
  (setq	l     ()
	lista (list (CalculaY a1 b1 c1 startX)
		    (CalculaY a2 b2 c2 startX)
		    (CalculaY a3 b3 c3 startX)
		    (CalculaY a4 b4 c4 startX)
	      )
  )
  (while (/= lista nil)
    (setq y (car lista))
    (if	(and (/= y nil) (<= y maxY) (>= y minY))
      (setq l (append l (list y)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)

(defun dameEsquinas (e / le lp)
  (if (= (cdr (assoc 0 (setq le (entget e)))) "LWPOLYLINE")
    (foreach l le
      (if (= (car l) 10)
	(setq lp (cons (cdr l) lp))
      )
    )
  )
  (if lp (vl-sort lp '(lambda(a b) (< (car a) (car b)))))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla	(/	p1     p2     p3     p4	    paux   incx
		 incy	l      h      n	     maldato	   base
		 alfa	startX startY minX   minY   maxX   maxY
		)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
;;;  (setq	p1 (getpoint "\nIngrese un vertice de la region ")
;;;	p2 (getpoint p1 "\nIngrese el otro vertice ")
;;;  )
;;;  (command "LINE" p1 p2 "")
  (if (not (setq e (car (entsel "\nSelecciona el marco para la grilla..."))))
    (exit)
  )
  (setq l (dameEsquinas e)
	p1 (car l)
	p2 (cadr l)
	p3 (caddr l)
	l nil
  )
  (if (> (cadr p1) (cadr p2))		; siempre el p1 abajo
    (setq paux p1
	  p1 p2
	  p2 paux
    )
  )
  (setq	p3   (getpoint p1 "\nIngrese punto para Ancho de la region ")
	l    (distance p1 p3)		; calculo de puntos p3 y p4 , paralelos
	alfa (angle p1 p2)		; a p1 y p2 a distancia l
	alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
    (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
    (if	(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) 0.0)
      (setq alfa (+ pi alfa))
    )
  )
  (setq	p3 (list (+ (car p1) (* l (cos alfa)))
		 (+ (cadr p1) (* l (sin alfa)))
	   )
	p4 (list (+ (car p2) (* l (cos alfa)))
		 (+ (cadr p2) (* l (sin alfa)))
	   )
  )
  (command "LINE" p1 p2 p4 p3 "C")	; marco exterior
  (if (< (cadr p3) (cadr p1))		; punto1 siempre mas bajo
    (setq paux p1
	  p1 p3
	  p3 paux
	  paux p2
	  p2 p4
	  p4 paux
    )
  )
  (setq	minX	(min (car p2) (car p3))
	maxX	(max (car p2) (car p3))
	minY	(cadr p1)
	maxY	(cadr p4)
	l	(- maxX minX)
	h	(- maxY minY)
	malDato	1
  )
  (while (= malDato 1)
    (setq incx (getreal "\nIncremento malla (m) :"))
    (if	(< (abs (/ l 3)) incrx)
      (print "\nIncremento muy grande")
      (setq malDato 0)
    )
  )

  (setq incy incx)

  (setq	n	 (fix (/ minX incx))	; posiciones donde comenzar
	startX	 (* (1+ n) incx)	; el cuadriculado
	n	 (fix (/ minY incy))	; tanto en X como en Y
	startY	 (* (1+ n) incy)
	largoMax (max (distance p1 p3)	; el largo maximo de la region
		      (distance p1 p4)
		 )
  )
  (if (< minX 0)
    (setq startX (- startX incx))
  )
  (if (< minY 0)
    (setq startY (- startY incy))
  )

  (setq ff (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala))	; alto de los caracteres

  (setq	angP1P3	 (angle p1 p3)
	angP1P2	 (angle p1 p2)
	angBorde (min (abs angP1P3) (abs angP1P2))
	dh	 (min (/ incx 40.0) (/ incy 40.0))
	x1	 minX			; el caso en que no hay que rotar
	x2	 maxX
	y1	 minY
	y2	 maxY
  )
  (if (or (= (cadr p1) (cadr p2))
	  (= (car p1) (car p3))
	  (= (car p1) (car p2))
      )
    (setq revisar 0
	  dl	  (min (/ incx 30.0) (/ incy 30.0))
    )
    (setq revisar 1
	  dl	  (* (* alto (/ (cos angBorde) (sin angBorde))) 2)
    )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
    (if	(= revisar 1)
      (setq ptos (IntersecX)
	    x1	 (car ptos)
	    x2	 (cadr ptos)
      )
    )
    (setq coordY (rtos startY 2 0)
	  coordY (strcat "N-" (strpto coordY))
    )
    (command "LINE" (list x1 startY) (list x2 startY) "")
    (cond ((> (- maxY startY) (* 2 alto))
	   (command "TEXT"
		    (list (+ x1 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	   (command "TEXT"
		    "R"
		    (list (- x2 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	  )
    )
    (setq startY (+ startY incy))
  )
  (while (< startX maxX)
    (if	(= revisar 1)
      (setq ptos (IntersecY)
	    y1	 (car ptos)
	    y2	 (cadr ptos)
      )

    )
    (setq coordX (rtos startX 2 0)
	  coordX (strcat "E-" (strpto coordX))
    )
    (command "LINE" (list startX y1) (list startX y2) "")
    (cond ((> (- startX minX) (* 2 alto))
	   (command "TEXT"
		    (list (- startX dh) (+ y1 dl))
		    alto
		    100
		    coordX
	   )
	   (command "TEXT"
		    "R"
		    (list (- startX dh) (- y2 dl))
		    alto
		    100
		    coordX
	   )
	  )
    )
    (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
    (setq alfa angP1P3)
    (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
    (setq alfarad (* -1 alfa)
	  alfa	  (* -1 (/ (* 200 alfa) pi))
	  p4	  (list	(- (* (car p4) (cos alfarad)) (* (cadr p4) (sin alfarad)))
			(+ (* (car p4) (sin alfarad)) (* (cadr p4) (cos alfarad)))
		  )
	  p1	  (list	(- (* (car p1) (cos alfarad)) (* (cadr p1) (sin alfarad)))
			(+ (* (car p1) (sin alfarad)) (* (cadr p1) (cos alfarad)))
		  )
	  base	  (list 0.0 0.0)	; el origen
    )
  )
  (command "_.undo" "end")
  (command "_.undo" "auto" "on")
  ;;  (command "units" "2" "3" "3" "4" "n" "y")
)

 

The "command" calls in your code are designed for an English version of AutoCAD, and mine is in Spanish.
For this reason, and due to lack of time, I haven't tested the code sufficiently.

Try it yourself and then comment on the results.

 

Dear friend GLAVCVS, thank you so much for your reply.
The routine worked perfectly.

I'm very grateful for your help.
Regards

mhupp Grand Master

mhupp

Posted
Posted

Could you post a sample drawing of what you would use this on and what your looking for. Rather then picking points for the grid you could do a selection and run the bounding box

  

(defun C:foo ()
  (if (setq SS (ssget))
    (BBOX)
    (command "_.RECTANG" LL UR)
    (prompt (strcat "El rectángulo mide: " (car L&W) " x " (cadr L&W)))
  )
  (princ)
)
;;----------------------------------------------------------------------------;;
;; Length and Width of a Selection 
(defun BBox (/ ptslst)
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
    (setq ptslst (cons (vlax-safearray->list minpt) ptslst)
          ptslst (cons (vlax-safearray->list maxpt) ptslst)
    )
  )
  (setq LL (apply 'mapcar (cons 'min ptslst))
        UR (apply 'mapcar (cons 'max ptslst))
        L&W (mapcar '- UR LL)
  )
  (princ)
)

 

 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...