Topic: Progressive hatch

[Shade]

Does anyone have a lisp that will produce the following hatch (pink lines).



We have a lot of curved millwork at my place of employment and a lisp or hatch pattern that can show a curved surface would be beneficial.
The white lines and the arc are only shown in the example as guidelines on how we currently produce the the pattern.
I may have to come up with a lisp myself soon.  I just lack the time right now to produce a lisp. Hence the fishing expedition.

Any help would be appreciated, 

[ronjonp]

Not a hatch but...

http://www.theswamp.org/index.php?topic=24688.0

[CAB]

I don't think you are going to find a hatch solution.
What is the process for developing the profile lines?
Is the molding always an arc or are plines used also?

My pseudo code:

Code: [Select]

User selects the profile
User selects the corner. May be able to calc this point
User enter number of divisions or length of division along profile or angle between divisions
Routine draws the radial lines form origin to intersect with profile
then draw vertical line to some base line
Is that close to the process needed?
Can you upload some sample profiles with the pattern lines?

[Marco Jacinto]

I have this code, hope it help.

It try to get automatically the with for the objects, but only works in WCS, in other case you have to enter it manually.

Hope it helps.

Code: [Select]

(defun c:docyl (/ p1 p2 obj ll ur ltp sc ent an OldOsmode DIR FILE VARLST VARLT X)
  (vl-arx-import 'BPOLY)
  (or (findfile "cyl1.pat")
      (progn
(setq dir  (vl-filename-directory (findfile "acad.exe"))
      file (open (strcat dir "\\cyl1.pat")
"w"
   )
)
(mapcar (function(lambda (x)
   (princ x file)
   (princ "\n" file)
))
(list
  "*cyl1,Cylinder effect"  "0, 0,0.01, 0,1"
  "0, 0,0.02, 0,1"    "0, 0,0.04, 0,1"
  "0, 0,0.08, 0,1"    "0, 0,0.16, 0,1"
  "0, 0,0.30, 0,1"    "0, 0,0.50, 0,1"
  "0, 0,0.70, 0,1"    "0, 0,0.84, 0,1"
  "0, 0,0.92, 0,1"    "0, 0,0.96, 0,1"
  "0, 0,0.98, 0,1"    "0, 0,0.99, 0,1"
)
)
(close file)
      )
  )
  (foreach var
       '(("cmdecho" . 0)
("osmode" . nil)
("cecolor" . "8")
("snapbase" . nil)
("hporiginmode" . nil)
("hporigin" . nil)
)
    (setq varlst (cons (cons (car var) (getvar (car var)))
       Varlst
)
    )
    (if (cdr var)
      (setvar (car var) (cdr var))
    )
  )
  (or sc (setq sc 1.00))
  (or an (setq an (/ pi 2)))
  (setq OldOsmode (getvar "osmode"))
  (if (/= (logand oldosmode 16384) 16384)
    (setvar "osmode" (+ oldosmode 16384))
  )
  (setq ent (bpoly (getpoint "\n Specify internal point:"))
  )
  (if ent
    (progn
      (setvar "osmode" oldosmode)
      (setq
p1 (getpoint (strcat "\n Specify first point for distance: <"
     (rtos sc 2 2)
     ">"
     )
   )
      )
      (if p1
(setq p2 (getpoint p1 "\n Specify second point: ")
)
(progn
  (vla-getboundingbox
    (vlax-ename->vla-object ent)
    'll
    'ur
  )
  (setq
    ltp (mapcar 'vlax-safearray->list (list ll ur))
    p1 (car ltp)
    p2 (list (car (cadr ltp)) (cadr (car ltp)))
  )
)
      )
; (command "line" (trans p1 0 1) (trans
; p2 0
; 1))
      (setq sc (distance (trans p1 0 1) (trans p2 0 1))
    an (+ (angle p1 p2) (/ pi 2))
      )
      (if (>= (atof (substr (getvar "acadver") 1 4)) 16.2)
(progn
  (setvar "hporiginmode" 0)
  (setvar "hporigin" (reverse (cdr (reverse p1))))
)
(setvar "snapbase" (reverse (cdr (reverse p1))))
      )
      (command "-bhatch"
       "p"
       "CYL1"
       sc
       (radian->degrees an)
       "s"
       ent
       ""
       ""
      )
      (entdel ent)
    )
  )
  (if varlst
    (mapcar '(lambda (x)
       (setvar (car x) (cdr x))
     )
    varlt
    )
  )
  (princ)
)

(DEFUN Radian->Degrees (nbrOfRadians /)
  (* 180.0 (/ nbrOfRadians PI))
) ;_ end of defun


[ronjonp]

That's pretty slick

*edit..you need to include the RADIAN->DEGREES function.

[Marco Jacinto]

Thanks, I always forgot to recheck for all the used functions.

I add the missing function in my previous post.

Saludos

Marco Jacinto

[UDDFL]

Bump...

That DOCYL routine is brilliant. Just curious, was there any particular method used for determining the line spacing?

[vladimirzm]

years ago i needed something basic and similar:

WIDTH: always two horizontal points
LONG: always two vertical points
then press "+" or "-" or "D"

Code: [Select]

(if c:cal () (arxload "geomcal"))

(defun c:tc (/ app doc xsp p1 p2 p3 sel_lineas arc centro delta
     x veces vec fin grr)

(defun tc_lineas (veces)
  (if veces
    ()
    (setq veces 16)
  )
  (if (< veces 4)
    (progn
      (prompt "\nYou can't generate less than 2 texture lines.")
      ;(prompt "\nNo puedes generar menos de 2 líneas de textura.")
      (setq veces 3)
    )
  )
  (setq vec veces)

  (setq delta
    (/
      (-
        (vlax-curve-getEndParam arc)
        (vlax-curve-getStartParam arc)
      )
      veces
    )
    x 1
  )
 
  (repeat (1- veces)
    (setq punto (vlax-curve-getPointAtParam arc (* x delta)))
    (if punto
      (progn
        (vla-addline
          xsp
          (vlax-3d-point
    (list
      (car (c:cal "xof(punto)"))
              (cadr (c:cal "yof(p2)"))
              0.0
            )
          )
          (vlax-3d-point
    (list
      (car (c:cal "xof(punto)"))
              (cadr (c:cal "yof(p3)"))
              0.0
            )
          )
        )
      )
    )
    (ssadd (entlast) sel_lineas)
    (setq x (1+ x))
  )

)

(defun tc_borralineas (/ ob)
  (repeat (sslength sel_lineas)
    (ssdel (setq ob (ssname sel_lineas 0)) sel_lineas)
    (vla-delete (vlax-ename->vla-object ob))
  )
)

  (setq app (vlax-get-acad-object)
        doc (vla-get-ActiveDocument app)       
        xsp (vla-get-ActiveSpace doc)
olderr *error* *error* tc_error
  )
  (if (= xsp 1)
    (setq xsp (vla-get-ModelSpace doc))
    (setq xsp (vla-get-paperSpace doc))
  )
  (prompt "\n Width: ")
  (setq p1 (getpoint) ;"\nIndica primer punto de ancho: ")
p2 (getpoint p1); "\nIndica segundo punto de ancho: ")
  )
  (prompt "\n Long: ")
  (setq p3 (getpoint p2); "\nIndica largo de textura: ")
  )

  (setq sel_lineas (ssadd))
  (setq arc
    (vla-addarc
      xsp
      (vlax-3d-point
        (c:cal "centro=(p1+p2)/2")
      )
      (distance centro p2)
      (angle centro p2)
      pi
    )
  )
  (vla-put-Visible arc :vlax-false)
 

  (setq grr '(2 100))
  (prompt (strcat ;"\n.\n *** Presiona Enter o barra espaceadora para terminar."
  ;"\n *** Presiona \"C\" para dibujar 20 líneas de textura."
  "\n Press +/- for more/less density. D for default: "
  )
  )
  (while (/= fin t)
    (cond
      ( (equal grr '(2 100)); = "D"       
        (If (> (sslength sel_lineas) 0)
          (tc_borralineas)
        )
        (tc_lineas nil)
      )
      ( (equal grr '(2 43)); = "+"
;;;        (alert "Presionó +")
        (tc_borralineas)
        (tc_lineas (+ vec 1))
      )
      ( (equal grr '(2 45)); = "-"
;;;        (alert "Presionó -")
        (tc_borralineas)
        (tc_lineas (- vec 1))
      )
      ( (or (equal grr '(2 32)) (equal grr '(2 13))); = Enter ó = Espacio
        (setq fin t)
      )
    )
    (if (/= fin t)
      (progn       
        (setq grr (grread nil 14 0))
      )
    )
  )
  (vla-delete arc)

  (setq *error* olderr)
  (princ) 
)

(defun tc_error (msg)
  (setq *error* olderr)
  (if arc (vla-delete arc) )
  (if sel_lineas (command "_erase" sel_lineas "") )
  (princ)
)
)

[UDDFL]

^ Holy moly... Winner!