Author Topic: Examples of usage GRREAD - let's share  (Read 199060 times)

0 Members and 1 Guest are viewing this topic.

ymg

  • Guest
Re: Examples of usage GRREAD - let's share
« Reply #195 on: May 29, 2014, 01:08:07 PM »
reltro,

Cool!!  8-)

Reminds me of Radial Menu in Autohotkey.

ymg

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #196 on: May 30, 2014, 05:48:16 AM »
Additions to helixes...

G-HELIX (golden spiral - cw)

Code: [Select]
(defun c:ghcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun qcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun qcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar (list 0. (- (- 1. g)) 0.) (+ (* -0.5 pi) (* a (setq k (1+ k)))) g))
      (setq p2 (polar (list 0. (- (- 1. g)) 0.) (+ (* -0.5 pi) (* a (1+ k))) g))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (- (- 1. g)) 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) (* g g)))
      (setq p2 (polar (list (- (- g (* g g))) (- (- 1. g)) 0.) (+ (* -1.0 pi) (* a (1+ k))) (* g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (- (* g g g)) 0.) (+ (* -1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
      (setq p2 (polar (list (- (- g (* g g))) (- (* g g g)) 0.) (+ (* -1.5 pi) (* a (1+ k))) (* g g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq g (/ (- (sqrt 5.) 1.) 2.))
  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 6)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (qcirl1 n -1))
        (setq l2 (qcirl2 n -1))
        (setq l3 (qcirl3 n -1))
        (setq l4 (qcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* -0.5 pi) an) d))
  (setq p3 (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g)))
  (setq p4 (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g)))
  (setq p5 (polar (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g g g)) an (* d g g g)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p2 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p3 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p4 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ pi an) (* d g g g g)))
    (setq d (* d g g g g))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* -0.5 pi) an) d))
    (setq p3 (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g)))
    (setq p4 (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g)))
    (setq p5 (polar (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g g g)) an (* d g g g)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p2 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p3 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p4 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
« Last Edit: June 01, 2014, 09:26:31 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #197 on: May 30, 2014, 05:49:01 AM »
G-HELIX (golden spiral - ccw)

Code: [Select]
(defun c:ghccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun qcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun qcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (setq k (1+ k)))) g))
      (setq p2 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (1+ k))) g))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) (* g g)))
      (setq p2 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (1+ k))) (* g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
      (setq p2 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (1+ k))) (* g g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq g (/ (- (sqrt 5.) 1.) 2.))
  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 6)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (qcirl1 n -1))
        (setq l2 (qcirl2 n -1))
        (setq l3 (qcirl3 n -1))
        (setq l4 (qcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 0.5 pi) an) d))
  (setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
  (setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
  (setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p2 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p3 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p4 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ pi an) (* d g g g g)))
    (setq d (* d g g g g))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 0.5 pi) an) d))
    (setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
    (setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
    (setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p2 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p3 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p4 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
« Last Edit: June 01, 2014, 09:27:14 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #198 on: May 30, 2014, 05:50:13 AM »
Half circles HELIX (cw)

Code: [Select]
(defun c:chcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.5 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.5))
      (setq p2 (polar (list -0.5 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.5))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.25))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.25))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.375 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.125))
      (setq p2 (polar (list -0.375 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.125))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 pp)
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
  (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.0625 d)))
    (setq d (* 0.0625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 pp)
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
    (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
« Last Edit: June 01, 2014, 09:28:20 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #199 on: May 30, 2014, 05:50:55 AM »
Half circles HELIX (ccw)

Code: [Select]
(defun c:chccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.5 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.5))
      (setq p2 (polar (list -0.5 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.5))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.25))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.25))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.375 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.125))
      (setq p2 (polar (list -0.375 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.125))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 pp)
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
  (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.0625 d)))
    (setq d (* 0.0625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 pp)
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
    (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
« Last Edit: June 01, 2014, 09:29:13 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #200 on: May 30, 2014, 05:51:53 AM »
Three quarter circles HELIX (cw)

Code: [Select]
(defun c:cqhcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.75))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.75))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.5625))
      (setq p2 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.5625))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.203125 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.421875))
      (setq p2 (polar (list -0.203125 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.421875))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 (polar pp an (* 0.5 d)))
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
  (setq p5 (polar pp an (* 0.21875 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.31640625 d)))
    (setq d (* 0.31640625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 (polar pp an (* 0.5 d)))
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
    (setq p5 (polar pp an (* 0.21875 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
« Last Edit: June 01, 2014, 09:30:04 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #201 on: May 30, 2014, 05:52:38 AM »
Three quarter circles HELIX (ccw)

Code: [Select]
(defun c:cqhccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.75))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.75))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.5625))
      (setq p2 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.5625))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.203125 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.421875))
      (setq p2 (polar (list -0.203125 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.421875))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 (polar pp an (* 0.5 d)))
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
  (setq p5 (polar pp an (* 0.21875 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.31640625 d)))
    (setq d (* 0.31640625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 (polar pp an (* 0.5 d)))
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
    (setq p5 (polar pp an (* 0.21875 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
« Last Edit: June 01, 2014, 09:30:51 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

reltro

  • Guest
Re: Examples of usage GRREAD - let's share
« Reply #202 on: May 30, 2014, 12:33:15 PM »
Here is an other to draw a rectangle with a specific ratio...

Starts with 1:2

Its a lil useless without OSNAP... :(

Code: [Select]
(defun C:Rect,Ratio ( / P1 P vector,Len vector,Len,get vector,Len,set vector,cross opt arsin arcos opt2 Rect0 Rect1 Rect2 Rect3 tmpRatio typed UserPrompt)
    (setq    P1                (getpoint "Pick StartPoint: ")
            vector,Len,get    (lambda (v / )        (sqrt (apply '+ (mapcar '(lambda (a / ) (expt a 2)) v))))
            vector,Len,set    (lambda (v l / f)    (setq f (/ (float l) (vector,Len,get v))) (mapcar '(lambda (a /) (* a f)) v))
            vector,cross    (lambda (a b)
                                (mapcar
                                    '(lambda (n / )
                                        (-
                                            (* (nth (car n) a)(nth (cadr n) b))
                                            (* (nth (cadr n) a) (nth (car n) b))
                                        )
                                    )
                                    '((1 2) (2 0) (0 1))
                                )
                            )
            arsin            (lambda (x)
                                (cond
                                    ((= x 1.0) (/ pi 2.0))
                                    ((= x -1.0) (/ pi -2.0))
                                    ((< (abs x) 1.0) (atan (/ x (sqrt (- 1.0 (* x x))))))
                                    ('default (*error* (strcat "\n error: bad argument: " (rtos (abs x) 2) ">1.0\n ")))
                                )
                            )
            opt                0
            opt2            0
            ratio            2
    )
    (setq UserPrompt (lambda (/) (princ "\nPick Second Point or toogle between modes with RIGHTMOUSE and TAB or enter a new ratio (1:x) ")))
   
    (eval
        (list 'defun '*error* '(msg / )
            (list
                (lambda (err / )
                    (setq *error* err)
                    (redraw)
                    (if msg
                        (progn
                            (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
                                (princ msg)
                            )
                            (*error* msg)
                        )
                    )
                )
                *error*
            )
        )
    )
   
    (UserPrompt)
   
    (while (not (= (car (setq P (grread 'T))) 3))
        (cond
            ((= (car P) 5)
                (    (lambda (P / v l v,perp H ang)
                        (setq    v (mapcar '- P P1)
                                l (vector,Len,get v)
                        )
                        (if (> l 0)
                            (cond
                                ((= opt 0)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq    Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 P
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 1)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 -1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq    Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 P
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 2)
                                    (setq H (sqrt (+ 1 (expt ratio 2))))
                                    (setq ang (arsin (/ ratio H)))
                                    (setq l    (* (cos ang) l))
                                   
                                    (setq ang
                                        (if (= opt2 0)
                                            (- (angle P1 P) ang)
                                            (+ (angle P1 P) ang)
                                        )
                                    )
                                   
                                    (setq    Rect0 P1
                                            Rect1 (polar P1 ang l)
                                            Rect2 P
                                            Rect3 (polar Rect2 ang (* -1 l))
                                    )
                                   
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                            )
                        )
                    )
                    (cadr P)
                )
            )
            ((= (car P) 25)
                (if (= opt 2)
                    (setq opt 0)
                    (setq opt (1+ opt))
                )
            )
            ((and (= (car P) 2) (or (and (> (cadr P) 47) (< (cadr P) 58)) (= (cadr P) 46)))
                (setq typed (chr (cadr P)))
                (princ typed)
                (setq tmpRatio (cons typed tmpRatio))
            )
            ((and (= (car P) 2) (= (cadr P) 8))
                (princ (chr (cadr P)))
                (setq tmpRatio (cdr tmpRatio))
            )
            ((and (= (car P) 2) (or (= (cadr P) 13) (= (cadr P) 32)))
                (if tmpRatio
                    (setq    ratio        (read (apply 'strcat (reverse tmpRatio)))
                            tmpRatio    nil
                    )
                )
                (UserPrompt)
            )
            ((and (= (car P) 2) (= (cadr P) 9))
                (if (= opt2 1)
                    (setq opt2 0)
                    (setq opt2 1)
                )
            )
        )
    )
    (if (apply 'and '(Rect0 Rect1 Rect2 Rect3))
        (command "_pline" Rect0 Rect1 Rect2 Rect3 "_close")
    )
   
    (*error* nil)
)

reltro

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #203 on: May 30, 2014, 02:38:48 PM »
Its a lil useless without OSNAP... :(

This reminds me on this topic... grread without dynamic draw...
Here is how would Lee Mac make it work with SNAPS...

http://www.cadtutor.net/forum/showthread.php?82662-Rectangle-lisp.Little-help-!/page3&p=#25
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Jeremy

  • Guest
Re: Examples of usage GRREAD - let's share
« Reply #204 on: May 30, 2014, 03:34:42 PM »
Reltro,

Very neat menu concept! Have you considered using entmake to create text on the fly rather than vectoring it? One small suggestion, make the text that names the current command a different color than white so that it stands out a little more.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #205 on: May 31, 2014, 02:15:03 AM »
Reltro,

I've implemented Lee's SNAPS to your function... Hope you don't mind...

Code: [Select]
(defun C:Rect,Ratio ( / _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho P1 P PS oo pp ss vector,Len vector,Len,get vector,Len,set vector,cross opt arsin arcos opt2 Rect0 Rect1 Rect2 Rect3 tmpRatio typed UserPrompt )

    (vl-load-com)

    (defun _acapp nil
        (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
        (_acapp)
    )

    (defun _getosmode ( os / lst )
        (foreach mode
           '(
                (0001 . "_end")
                (0002 . "_mid")
                (0004 . "_cen")
                (0008 . "_nod")
                (0016 . "_qua")
                (0032 . "_int")
                (0064 . "_ins")
                (0128 . "_per")
                (0256 . "_tan")
                (0512 . "_nea")
                (1024 . "_qui")
                (2048 . "_app")
                (4096 . "_ext")
                (8192 . "_par")
            )
            (if (not (zerop (logand (car mode) os)))
                (setq lst (cons "," (cons (cdr mode) lst)))
            )
        )
        (apply 'strcat (cdr lst))
    )

    (defun _grX ( p s c / -s r j )
        (setq -s (- s)
               r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
               j p
        )
        (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
        (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
        (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
       
        (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
        (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
        (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

        p
    )

    (defun _OLE->ACI ( c )
        (apply '_RGB->ACI (_OLE->RGB c))
    )

    (defun _OLE->RGB ( c )
        (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
    )

    (defun _RGB->ACI ( r g b / c o )
        (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
            (progn
                (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
                (vlax-release-object o)
                (if (vl-catch-all-error-p c)
                    (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                    c
                )
            )
        )
    )

    (defun _snap ( p osm )
      (if (osnap p (_getosmode osm))
        (osnap p (_getosmode osm))
        p
      )
    )

    (defun _polarangs ( ang / n k a l )
      (if (/= ang 0.0)
        (progn
          (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
          (setq k -1.0)
          (repeat (1+ (fix n))
            (setq a (* (setq k (1+ k)) ang))
            (setq l (cons a l))
          )
          l
        )
        (list 0.0)
      )
    )

    (defun _polar ( p0 p flag ang / a b an )
      (if flag
        (progn
          (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
          (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
          (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
          (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
        )
        p
      )
    )

    (defun _ortho ( p0 p flag )
      (if flag
        (_polar p0 p t (* 0.5 pi))
        p
      )
    )

    (setq   P1              (getpoint "\nPick StartPoint : ")
            vector,Len,get  (lambda (v / ) (sqrt (apply '+ (mapcar '(lambda (a / ) (expt a 2)) v))))
            vector,Len,set  (lambda (v l / f) (setq f (/ (float l) (vector,Len,get v))) (mapcar '(lambda (a /) (* a f)) v))
            vector,cross    (lambda (a b)
                                (mapcar
                                    '(lambda (n / )
                                        (-
                                            (* (nth (car n) a)(nth (cadr n) b))
                                            (* (nth (cadr n) a) (nth (car n) b))
                                        )
                                    )
                                    '((1 2) (2 0) (0 1))
                                )
                            )
            arsin           (lambda (x)
                                (cond
                                    ((= x 1.0) (/ pi 2.0))
                                    ((= x -1.0) (/ pi -2.0))
                                    ((< (abs x) 1.0) (atan (/ x (sqrt (- 1.0 (* x x))))))
                                    ('default (*error* (strcat "\n error: bad argument: " (rtos (abs x) 2) ">1.0\n ")))
                                )
                            )
            opt             0
            opt2            0
            ratio           2
    )
    (setq UserPrompt (lambda (/) (princ "\nPick Second Point or toogle between modes with RIGHTMOUSE and TAB or enter a new ratio (1:x) = 1:")))
   
    (setvar 'orthomode 1)
    (setq ape (getvar 'aperture))
    (setvar 'aperture 40)
    (setq as (getvar 'autosnap))
    (setvar 'autosnap 31)
    (setq osm (getvar 'osmode))
    (setvar 'osmode 15359)
    (if (eq (getvar 'orthomode) 1) (setq oo t) (setq oo nil))
    (if (eq (logand (getvar 'autosnap) 8) 8) (setq pp t) (setq pp nil))
    (if (eq (logand (getvar 'autosnap) 16) 16) (setq ss t) (setq ss nil))
   
    (eval
        (list 'defun '*error* '(msg / )
            (list
                (lambda (err / )
                    (setq *error* err)
                    (if ape (setvar 'aperture ape))
                    (if as (setvar 'autosnap as))
                    (if osm (setvar 'osmode osm))
                    (redraw)
                    (if msg
                        (progn
                            (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
                                (princ msg)
                            )
                            (*error* msg)
                        )
                    )
                    (princ)
                )
                *error*
            )
        )
    )
   
    (UserPrompt)
   
    (while (not (= (car (setq P (grread 'T))) 3))
        (cond
            ((= (car P) 5)
                (   (lambda (P / v l v,perp H ang)
                        (cond
                            ( (and oo pp ss)
                              (setq PS (_snap (_ortho P1 P t) (getvar 'osmode)))
                            )
                            ( (and oo (not pp) ss)
                              (setq PS (_snap (_ortho P1 P t) (getvar 'osmode)))
                            )
                            ( (and (not oo) pp ss)
                              (setq PS (_snap (_polar P1 P t (getvar 'polarang)) (getvar 'osmode)))
                            )
                            ( (and (not oo) (not pp) ss)
                              (setq PS (_snap P (getvar 'osmode)))
                            )
                            ( (and oo pp (not ss))
                              (setq PS (_ortho P1 P t))
                            )
                            ( (and oo (not pp) (not ss))
                              (setq PS (_ortho P1 P t))
                            )
                            ( (and (not oo) pp (not ss))
                              (setq PS (_polar P1 P t (getvar 'polarang)))
                            )
                            ( (and (not oo) (not pp) (not ss))
                              (setq PS P)
                            )
                        )
                        (setq   v (mapcar '- PS P1)
                                l (vector,Len,get v)
                        )
                        (if (> l 0)
                            (cond
                                ((= opt 0)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq   Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 PS
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 1)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 -1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq   Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 PS
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 2)
                                    (setq H (sqrt (+ 1 (expt ratio 2))))
                                    (setq ang (arsin (/ ratio H)))
                                    (setq l    (* (cos ang) l))
                                   
                                    (setq ang
                                        (if (= opt2 0)
                                            (- (angle P1 PS) ang)
                                            (+ (angle P1 PS) ang)
                                        )
                                    )
                                   
                                    (setq   Rect0 P1
                                            Rect1 (polar P1 ang l)
                                            Rect2 PS
                                            Rect3 (polar Rect2 ang (* -1 l))
                                    )
                                   
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                            )
                        )
                    )
                    (cadr P)
                )
            )
            ((= (car P) 25)
                (if (= opt 2)
                    (setq opt 0)
                    (setq opt (1+ opt))
                )
            )
            ((and (= (car P) 2) (or (and (> (cadr P) 47) (< (cadr P) 58)) (= (cadr P) 46)))
                (setq typed (chr (cadr P)))
                (princ typed)
                (setq tmpRatio (cons typed tmpRatio))
            )
            ((and (= (car P) 2) (= (cadr P) 8))
                (princ (chr (cadr P)))
                (setq tmpRatio (cdr tmpRatio))
            )
            ((and (= (car P) 2) (or (= (cadr P) 13) (= (cadr P) 32)))
                (if tmpRatio
                    (setq ratio (read (apply 'strcat (reverse tmpRatio)))
                          tmpRatio nil
                    )
                )
                (UserPrompt)
            )
            ((and (= (car P) 2) (= (cadr P) 9))
                (if (= opt2 1)
                    (setq opt2 0)
                    (setq opt2 1)
                )
            )
            ((and (= (car P) 2) (= (cadr P) 15))
              (if (eq oo t) (setq oo nil) (setq oo t))
            )
            ((and (= (car P) 2) (= (cadr P) 21))
              (if (eq pp t) (setq pp nil) (setq pp t))
            )
            ((and (= (car P) 2) (= (cadr P) 6))
              (if (eq ss t) (setq ss nil) (setq ss t))
            )
        )
        (if (not (equal PS (cadr P) 1e-6))
          (_grX PS (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
        )
    )
   
    (if (apply 'and '(Rect0 Rect1 Rect2 Rect3))
        (command "_pline" "_non" Rect0 "_non" Rect1 "_non" Rect2 "_non" Rect3 "_close")
    )
   
    (*error* nil)
)

EDIT : Forgot to add (vl-load-com)
« Last Edit: May 31, 2014, 04:48:03 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #206 on: May 31, 2014, 03:50:13 AM »
I've noticed my wrong input for 'osmode - now changed to :

(setvar 'osmode 15359)

Code updated also here on cadtutor...
http://www.cadtutor.net/forum/showthread.php?86255-Choose-midpoint-and-endpoint-draw-line.&p=#4

Also changed :
(setvar 'aperture 40)

M.R.
« Last Edit: May 31, 2014, 04:47:26 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

reltro

  • Guest
Re: Examples of usage GRREAD - let's share
« Reply #207 on: May 31, 2014, 05:53:01 AM »
Reltro,

Very neat menu concept! Have you considered using entmake to create text on the fly rather than vectoring it? One small suggestion, make the text that names the current command a different color than white so that it stands out a little more.

Hey...
I improved the Menu a lil bit and added also a version with Mtext to display the title...
http://www.theswamp.org/index.php?topic=47177.msg522100#msg522100

the Text in the circle-parts are still vectors... they are precalculated, so it would be harder to modify...
I prefer the version where all the stuff are vectors...

greets
reltro

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: Examples of usage GRREAD - let's share
« Reply #208 on: May 31, 2014, 10:41:23 AM »
I've implemented Lee's SNAPS to your function... Hope you don't mind...

Why do you insist on removing my name & author prefix from every line of code that you steal from me...?

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Examples of usage GRREAD - let's share
« Reply #209 on: May 31, 2014, 12:09:50 PM »
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?

I haven't stolen anything (where do you see MR: as prefix of functions I borrowed from you)... Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable... For purpose of stating the source of codes I provided link from where it was borrowed... Beside this I make my own functions which I consider are useful in describing method more complete and combine them to make program functionality better... Only subfunctions are the pieces I borrow from time to time, and you are not the only person I refer to; the main body of program I shared is unique and so is the main function name - I am just trying to make progression in terms of CAD - that's my hobby - to make life easier to myself and to the others who are using achievements that are shared and from time to time I make some mistakes I hope I correct meanwhile on the time I get... I am very responsible person and I don't like to leave some started things unfinished, just making sure I leave correct footprints for those people that like to participate and make progress of community greater like myself...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube