Author Topic: orthogonal track  (Read 2012 times)

0 Members and 1 Guest are viewing this topic.

Augusto

  • Newt
  • Posts: 75
orthogonal track
« on: February 02, 2019, 02:38:58 PM »
I've always wanted autoCAD to have this function natively.
I still have to hit some angles. I believe I have the Clockwise-p function.
If you could help me fix it, I'd be grateful.

Thanks to member PKENEWELL for encouraging me to learn about the GRREAD function.
If he had not made a constructive criticism at the time, i would not have expanded my knowledge, but of course I am far from the quality of the people here.

You have a good start Augusto. I would recommend strongly however you learn how to do entity modification using the entity list and ENTMOD, or using VLA-Object modification rather than repeating a command sequence in the GRREAD loop. Your current method is slow and very inefficient. There is also a number of other things that must be emulated in a GRREAD loop to make the program viable to other users, such as object snaps and function keys etc. I'm sorry I currently do not have time to play more with your code and give you an example. Keep learning and experimenting with the code and you will progress.

To give you something to try out: This is a function I created to emulate Function keys while working in a GRREAD loop.

Code: [Select]
(defun c:test()
  (vl-load-com)
  ;otrack
 
;;; https://www.theswamp.org/index.php?topic=12813.msg369811#msg369811
;;; Add MText to drawing
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
                 #Space #Insertion #Object
                )
  (or #Width (setq #Width 0))
  (or *AcadDoc*
      (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ or
  (setq #Space     (if (or (eq acmodelspace
                               (vla-get-activespace *AcadDoc*)
                           ) ;_ eq
                           (eq :vlax-true (vla-get-mspace *AcadDoc*))
                       ) ;_ or
                     (vla-get-modelspace *AcadDoc*)
                     (vla-get-paperspace *AcadDoc*)
                   ) ;_ if
        #Insertion (cond
                     ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
                     ((eq (type #InsertionPoint) 'variant) #InsertionPoint)
                     (T nil)
                   ) ;_ cond
  ) ;_ setq
  ;; create MText object
  (setq #Object (vla-addmtext #Space #Insertion #Width #String))
  ;; change layer, if applicable
  (and #Layer
       (tblsearch "layer" #Layer)
       (vla-put-layer #Object #Layer)
  ) ;_ and
  ;; change justification & match insertion point with new justification
  (cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
         (vla-put-attachmentpoint #Object #Justification)
         (vla-move #Object
                   (vla-get-InsertionPoint #Object)
                   #Insertion
         ) ;_ vla-move
        )
  ) ;_ cond
  #Object
) ;_ defun
;;; Quick Text
;;; Required Subroutines: AT:Mtext AT:Getstring
;;; Alan J. Thompson, 09.23.09

(defun c:QT (/ #Point1 #Point2 #String #Text #Final)
  (setq #String "orthogonal track")
  (setq #Point1 '(0.0 0.0 0.0))
  (setq #Point2 #Point1)
  (setq #Text (AT:Mtext #Point1 QT:Default 0 nil 5))
  (while (eq 5 (car (setq #Final (grread T 4 4))))
    (redraw)
    (setq pt2 (cadr #Final))
    (if
      (vl-some
(function
  (lambda (pt)
    (setq pt1 pt)
    (setq ang (angle pt1 pt2))
    (setq listAngles (list ang))
    (setq listAngles
   (vl-sort
     (append listAngles orthogonalAngles)
     '<
   ) ;_ >vl-sort
    ) ;_ >setq
    (if (= position 0)
      (setq before (last listAngles))
      (setq before (nth (- position 1) listAngles))
    ) ;_ >if
    (if (= ang (last listAngles))
      (setq after (car listAngles))
      (setq after (nth (+ position 1) listAngles))
    ) ;_ >if
    (cond
      ((<=
(abs
   (- ang before)
) ;_ >abs
magneticFactor
       ) ;_ ><=
       (setq ang before) ;_ >setq
      )
      ((<=
(abs
   (- ang after)
) ;_ >abs
magneticFactor
       ) ;_ ><=
       (setq ang after)
      )
      (t nil)
    ) ;_ >cond
  ) ;_ >lambda
) ;_ >function
objectPoints
      ) ;_ >vl-some
       (progn
(grdraw pt1 (setq pt2 (polar pt1 ang (distance pt1 pt2))) 1)
(vla-put-insertionpoint
   #Text
   (vlax-3d-point (trans pt2 1 0))
) ;_ >vla-put-insertionpoint
       ) ;_ >progn
       (vla-put-insertionpoint
#Text
(vlax-3d-point (trans (cadr #Final) 1 0))
       ) ;_ >vla-put-insertionpoint
    ) ;_ >if
  ) ;_ while
  (princ)
) ;_ defun

  ;; Unique  -  Lee Mac
  ;; Returns a list with duplicate elements removed.
  (defun LM:Unique (l)
    (if l
      (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))
    ) ;_ >if
  ) ;_ >defun

  ; converts degrees to radians
  (defun deg2rad(d) (* pi (/ d 180.0)))

  (setq acadObj (vlax-get-acad-object))
  (setq doc (vla-get-ActiveDocument acadObj))
  (setq modelSpace (vla-get-ModelSpace doc))
  (setq objectPoints '())

  (vlax-for obj (vla-get-ModelSpace doc)
    (cond
      ((= (vla-get-ObjectName obj) "AcDbLine")
       (setq objectPoints
      (append
objectPoints
(list
  (vlax-safearray->list
    (vlax-variant-value (vla-get-StartPoint obj))
  ) ;_ >vlax-safearray->list
) ;_ >list
(list
  (vlax-safearray->list
    (vlax-variant-value (vla-get-endPoint obj))
  ) ;_ >vlax-safearray->list
) ;_ >list
      ) ;_ >append
       ) ;_ >setq
      )
      ((= (vla-get-ObjectName obj) "AcDbCircle")
       (setq objectPoints
      (append
objectPoints
(list
  (vlax-safearray->list
    (vlax-variant-value (vla-get-Center obj))
  ) ;_ >vlax-safearray->list
) ;_ >list
      ) ;_ >append
       ) ;_ >setq
      )
    ) ;_ >cond
  ) ;_ >cond
 
  (setq objectPoints (LM:Unique objectPoints)
orthogonalAngles '(0.0 1.5708) ;3.14159 4.71239
magneticFactor (deg2rad 2) ;to simulate magnetic
  ) ;_ >setq
  (c:QT)
)
« Last Edit: February 02, 2019, 02:47:40 PM by Augusto »

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: orthogonal track
« Reply #1 on: February 02, 2019, 06:21:38 PM »
I see you've also caught the grread bug  :-)

You may be interested in this alternative implementation of orthogonal tracking with grread.

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Re: orthogonal track
« Reply #2 on: February 03, 2019, 03:58:02 AM »
@Augusto:
At least two variables seem to be undefined:
QT:Default
position.

Augusto

  • Newt
  • Posts: 75
Re: orthogonal track
« Reply #3 on: February 04, 2019, 05:41:15 AM »
It was just missing defining the variable "position".
I believe that from this concept it is possible to make many variances. Make yourself comfortable.
A great week everyone.

Code: [Select]
(defun c:test (/ orthogonalTrack grr pt1
pt2 ang listAngles
orthogonalAngles position
before after magneticFactor
objectPoints dist tracesSpace
deg2rad LM:Unique acadObj obj
         doc modelSpace orthogonalTrack
      ) ;_ >/
  (vl-load-com)
  ;otrack
  (defun orthogonalTrack ()
    (while (eq 5 (car (setq grr (grread T 4 4))))
      (redraw)
      (setq pt2 (cadr grr))
      (if
(vl-some
  (function
    (lambda (pt)
      (setq pt1 pt)
      (setq ang (angle pt1 pt2))
      (setq listAngles (list ang))
      (setq listAngles
     (vl-sort
       (append listAngles orthogonalAngles)
       '<
     ) ;_ >vl-sort
      ) ;_ >setq
      (setq position (vl-position ang listAngles))
      (if (= position 0)
(setq before (last listAngles))
(setq before (nth (- position 1) listAngles))
      ) ;_ >if
      (if (= ang (last listAngles))
(setq after (car listAngles))
(setq after (nth (+ position 1) listAngles))
      ) ;_ >if
      (cond
((<=
   (abs
     (- ang before)
   ) ;_ >abs
   magneticFactor
) ;_ ><=
(setq ang before) ;_ >setq
)
((<=
   (abs
     (- ang after)
   ) ;_ >abs
   magneticFactor
) ;_ ><=
(setq ang after)
)
(t nil)
      ) ;_ >cond
    ) ;_ >lambda
  ) ;_ >function
  objectPoints
) ;_ >vl-some
(progn
  (setq dist
(distance pt1
   (setq pt2 (polar pt1 ang (distance pt1 pt2)))
) ;_ >distance
  ) ;_ >setq
  (while (> dist tracesSpace)
    (grdraw pt1 (setq pt1 (polar pt1 ang tracesSpace)) 3)
    (setq pt1 (polar pt1 ang tracesSpace))
    (setq dist (distance pt1 pt2))
  ) ;_ >while
) ;_ >progn
      ) ;_ >if
    ) ;_ while
    (princ)
  ) ;_ defun
 
  ;; Unique - Lee Mac
  ;; Returns a list with duplicate elements removed.
  (defun LM:Unique (l)
    (if l
      (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))
    ) ;_ >if
  ) ;_ >defun
; converts degrees to radians
  (defun deg2rad (d) (* pi (/ d 180.0)))
  (setq acadObj (vlax-get-acad-object))
  (setq doc (vla-get-ActiveDocument acadObj))
  (setq modelSpace (vla-get-ModelSpace doc))
  (setq objectPoints '())
  (vlax-for obj (vla-get-ModelSpace doc)
    (cond
      ((= (vla-get-ObjectName obj) "AcDbLine")
       (setq objectPoints
      (append
objectPoints
(list
  (vlax-safearray->list
    (vlax-variant-value (vla-get-StartPoint obj))
  ) ;_ >vlax-safearray->list
) ;_ >list
(list
  (vlax-safearray->list
    (vlax-variant-value (vla-get-endPoint obj))
  ) ;_ >vlax-safearray->list
) ;_ >list
      ) ;_ >append
       ) ;_ >setq
      )
      ((= (vla-get-ObjectName obj) "AcDbCircle")
       (setq objectPoints
      (append
objectPoints
(list
  (vlax-safearray->list
    (vlax-variant-value (vla-get-Center obj))
  ) ;_ >vlax-safearray->list
) ;_ >list
      ) ;_ >append
       ) ;_ >setq
      )
    ) ;_ >cond
  ) ;_ >cond

  (setq objectPoints (LM:Unique objectPoints)
orthogonalAngles '(0.0 1.5708 3.14159 4.71239)
magneticFactor (deg2rad 2)     ;to simulate magnetic
tracesSpace      1     ;spacing and length of dashes
  ) ;_ >setq
  (orthogonalTrack)
)
« Last Edit: February 04, 2019, 05:46:42 AM by Augusto »

PKENEWELL

  • Bull Frog
  • Posts: 309
Re: orthogonal track
« Reply #4 on: February 04, 2019, 04:55:31 PM »
...

Thanks to member PKENEWELL for encouraging me to learn about the GRREAD function.
If he had not made a constructive criticism at the time, i would not have expanded my knowledge, but of course I am far from the quality of the people here.

Thanks Augusto. I'm glad I was able to inspire you to learn more. Looks like you're learning quickly too, and as Lee pointed out, you have caught the GRREAD bug.  :-D
"When you are asked if you can do a job, tell 'em, 'Certainly I can!' Then get busy and find out how to do it." - Theodore Roosevelt