make pat files

[BIGAL]

Does any one have a good make a Pat file  lisp ? I thought why not add a pline to pattern. This was for a post here.

 

I have help files, old manuals and they are written in a way to totally confuse, its just not working. I am just missing something, the examples keep changing the angles that's what makes it so confusing. When you look at acad.pat etc and some of the patterns that are objects you can work out what the values represent but how are they relevant ?  I looked at Star and a scale of 1, and the numbers start to match but there relationship to the file is just confusing and how does it know to repeat the pattern to be closed ?

 

I have tried a older hatch make lisp but what comes out does not make any sense and pat does not work.

 

To quote the manual angle, x-origin, y-origin, delta-x, delta-y, [,dash-1,dash2...]

 

Code removed

 

Edited May 5, 2020 by BIGAL

[marko_ribar]

If you want rectangular-more specific square arrayed *.pat from polyline, I suggest that you explode your polyline, draw square around it approximately like bounding box of pline, then scale square and pline to square with edge 1.0 unit and move exploded pline and square at 0,0 coordinate of WCS... Now you have to remedy lines of exploded pline so that each vertex snap to grid of 0.01 of that square 1.0x1.0... Then load HatchMaker.lsp from this attachment, type SAVEHATCH hit enter, select lines of polyline, write short description and save file as yourhatch.pat at (strcat (getvar 'roamablerootprefix) "support\\") folder... PAT file will be saved... Now if you remembered your initial scale factor when you shrink square, you just have to scale hatch when applied to boundary you wish to use as hatching... Your *.PAT file should be recognized from Custom menu of HATCH / Settings / Dialog Box...

Other alternative you may consider if you have complex shapes like pline with arcs or splines or... You can use SUPERHATCH command and it will array rectangular with automatic conversions to hatch block and clipping blocks from boundary you wish to use for hatching...

 

I have a set of my custom hatch-make routines, but I want to keep them for me - search theswamp ShowYourStuff forum for "HATCH-MAKE" or just "HM-" and you'll find my rectangle RND version with perhaps links for some others at theswamp...

 

Just a note for your quote from documentation :

angle - first value (decimal degrees) , Xcoord of origin (up to 8 digits after decimal separator .), Y coord of origin, delta X (you should think this as distance from origin in angle specified firstly as angle) of new origin, delta Y (you should think as distance from origin in angle+90degree) of new origin, dash1 - if you have line and not xline this is necessity - length of full line segment, dash2 - negative value of length of empty gap between repetitions of full line segment

 

When you create *.pat file from this description, you must think that every line is repeating with spacing collinear depending of angle you specified and every line should have its delta x and delta y offsets... When all pattern lines are considered this way and when they combined form some shape in correct repeating manner, then your *.pat file is correct and hatch may produce desired outcome... The problem with your algorithm is that you considered delta x and delta y not as offsets of line, but thing that is considered at the end with dash1 and dash2 (length of full line and gap line) - you used values of vector of line deltas (car and cadr) - that's not what is intended with syntax for hatch pat line... Then again you haven't specified dash1 and dash2, so this is considered as XLINES and not LINES of exploded pline...

 

Regards, HTH., M.R.

HatchMaker.lsp

Edited April 30, 2020 by marko_ribar

[marko_ribar]

I know what are you trying to do, but that's not possible - only with routine I posted... To understand check this code and test it... It's not working in real situations, only hor and vert crossings is possible...

 

(defun c:savehatchfromstrlw ( / trim0trailing trimlineto80chr unit projpt2p1p2 s lw minp maxp w h pl lil o r c ol des fn f a x y no ip dx dy l oo g )

  (vl-load-com)

  (defun trim0trailing ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (= (car lst) 48)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun trimlineto80chr ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (>= (length lst) 80)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 0 (unit (mapcar '- p2 p1))))
    (setq p1t (trans p1 0 (unit (mapcar '- p2 p1))))
    (setq ip (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- p2 p1)) 0))
  )

  (while
    (or
      (prompt "\nPick polygonal LWPOLYLINE...")
      (not (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>")))))
    )
    (prompt "\nMissed...")
  )
  (setq lw (ssname s 0))
  (vla-getboundingbox (vlax-ename->vla-object lw) 'minp 'maxp)
  (mapcar 'set '(minp maxp) (mapcar 'safearray-value (list minp maxp)))
  (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp)))
  (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
  (setq lil (mapcar '(lambda ( a b ) (list a b)) pl (if (= 1 (logand 1 (cdr (assoc 70 (entget lw))))) (append (cdr pl) (list (car pl))) (cdr pl))))
  ;|
  (setq o (mapcar '- minp (list (* 500.0 w) (* 500.0 h))))
  (setq r -1)
  (repeat 1000
    (setq r (1+ r) c -1)
    (repeat 1000
      (setq c (1+ c))
      (setq ol (cons (mapcar '+ o (list (* c w) (* r h))) ol))
    )
  )
  (setq ol (vl-sort ol '(lambda ( a b ) (< (distance minp a) (distance minp b)))))
  |;
  (initget 1)
  (setq des (getstring "\nSpecify description : "))
  (while (not (snvalid des))
    (initget 1)
    (setq des (getstring "\nSpecify description : "))
  )
  (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar 'roamablerootprefix) "support\\") "pat" 1))
  (setq f (open fn "w"))
  (write-line (strcat "*" des ", " des) f)
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq x (caar li) y (cadar li))
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list x (+ y h)))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list (- x w) y))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list x (- y h)))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list (+ x w) y))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq l (distance (car li) (cadr li)))
    ;|
    (setq oo (vl-some '(lambda ( x ) (if (equal (angle minp x) a 1e-2) x)) (cdr ol)))
    (setq g (- (- (distance minp oo) l)))
    |;
    ;;; When you uncomment ;| and |; comment next line (setq g -1000000.0)
    (setq g -1000000.0)
    (if (zerop g)
      (write-line (strcat (rtos (cvunit a "radian" "degree") 2 8) "," (rtos x 2 8) "," (rtos y 2 8) "," (rtos dx 2 8) "," (rtos dy 2 8)) f)
      (write-line (strcat (rtos (cvunit a "radian" "degree") 2 8) "," (rtos x 2 8) "," (rtos y 2 8) "," (rtos dx 2 8) "," (rtos dy 2 8) "," (rtos l 2 8) "," (rtos g 2 8)) f)
    )
    ;;; From this comment to last ;;; comment paragraph and remove previous ;| and |; to check for rect array - no cross
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list (+ x w) y))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list x (+ y h)))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list (- x w) y))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list x (- y h)))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (if (zerop g)
      (write-line (strcat (rtos (cvunit a "radian" "degree") 2 8) "," (rtos x 2 8) "," (rtos y 2 8) "," (rtos dx 2 8) "," (rtos dy 2 8)) f)
      (write-line (strcat (rtos (cvunit a "radian" "degree") 2 8) "," (rtos x 2 8) "," (rtos y 2 8) "," (rtos dx 2 8) "," (rtos dy 2 8) "," (rtos l 2 8) "," (rtos g 2 8)) f)
    )
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list (+ x w) (+ y h)))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list (- x w) (+ y h)))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list (- x w) (- y h)))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list (+ x w) (- y h)))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (if (zerop g)
      (write-line (strcat (rtos (cvunit a "radian" "degree") 2 8) "," (rtos x 2 8) "," (rtos y 2 8) "," (rtos dx 2 8) "," (rtos dy 2 8)) f)
      (write-line (strcat (rtos (cvunit a "radian" "degree") 2 8) "," (rtos x 2 8) "," (rtos y 2 8) "," (rtos dx 2 8) "," (rtos dy 2 8) "," (rtos l 2 8) "," (rtos g 2 8)) f)
    )
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list (- x w) (+ y h)))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list (- x w) (- y h)))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list (+ x w) (- y h)))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list (+ x w) (+ y h)))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (if (zerop g)
      (write-line (trimlineto80chr (strcat (trim0trailing (cvunit a "radian" "degree") 2 8)) "," (trim0trailing (rtos x 2 8)) "," (trim0trailing (rtos y 2 8)) "," (trim0trailing (rtos dx 2 8)) "," (trim0trailing (rtos dy 2 8)))) f)
      (write-line (trimlineto80chr (strcat (trim0trailing (cvunit a "radian" "degree") 2 8)) "," (trim0trailing (rtos x 2 8)) "," (trim0trailing (rtos y 2 8)) "," (trim0trailing (rtos dx 2 8)) "," (trim0trailing (rtos dy 2 8)) "," (trim0trailing (rtos l 2 8)) "," (trim0trailing (rtos g 2 8)))) f)
    )
    ;;;
  )
  (close f)
  (princ)
)

M.R.

Edited November 18, 2020 by marko_ribar

[marko_ribar]

Or yet, this code should be OK, but HATCH not work (gaps are too big)...

 

(defun c:savehatchfromstrlw ( / trim0trailing trimlineto80chr unit projpt2p1p2 intrecsang s lw minp maxp w h pl lil des fn f a x y no ip dx dy l v k oo g ll al nn scf )

  (vl-load-com)

  (defun trim0trailing ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (= (car lst) 48)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun trimlineto80chr ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (>= (length lst) 80)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 0 (unit (mapcar '- p2 p1))))
    (setq p1t (trans p1 0 (unit (mapcar '- p2 p1))))
    (setq ip (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- p2 p1)) 0))
  )

  (defun intrecsang ( minp w h a / r1 r2 r3 r4 d li ip )
    (setq r1 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list w 0.0))) (cons 10 (mapcar '+ minp (list w h))) (cons 10 (mapcar '+ minp (list 0.0 h))) '(210 0.0 0.0 1.0))))
    (setq r2 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list (- w) 0.0))) (cons 10 (mapcar '+ minp (list (- w) h))) (cons 10 (mapcar '+ minp (list 0.0 h))) '(210 0.0 0.0 1.0))))
    (setq r3 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list (- w) 0.0))) (cons 10 (mapcar '+ minp (list (- w) (- h)))) (cons 10 (mapcar '+ minp (list 0.0 (- h)))) '(210 0.0 0.0 1.0))))
    (setq r4 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list w 0.0))) (cons 10 (mapcar '+ minp (list w (- h)))) (cons 10 (mapcar '+ minp (list 0.0 (- h)))) '(210 0.0 0.0 1.0))))
    (setq d (sqrt (+ (expt w 2) (expt h 2))))
    (setq li (entmakex (list '(0 . "LINE") (cons 10 (polar minp a 1e-6)) (cons 11 (polar minp a d)))))
    (cond
      ( (equal a 0.0 1e-6)
        (setq ip (polar minp 0.0 w))
      )
      ( (equal a (* 0.5 pi) 1e-6)
        (setq ip (polar minp (* 0.5 pi) h))
      )
      ( (equal a pi 1e-6)
        (setq ip (polar minp pi w))
      )
      ( (equal a (* 1.5 pi) 1e-6)
        (setq ip (polar minp (* 1.5 pi) h))
      )
      ( t
        (cond
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r1) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r2) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r3) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r4) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
        )
      )
    )
    (mapcar 'entdel (list r1 r2 r3 r4 li))
    ip
  )

  (while
    (or
      (prompt "\nPick polygonal LWPOLYLINE...")
      (not (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>")))))
    )
    (prompt "\nMissed...")
  )
  (setq lw (ssname s 0))
  (vla-getboundingbox (vlax-ename->vla-object lw) 'minp 'maxp)
  (mapcar 'set '(minp maxp) (mapcar 'safearray-value (list minp maxp)))
  (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp)))
  (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
  (setq lil (mapcar '(lambda ( a b ) (list a b)) pl (if (= 1 (logand 1 (cdr (assoc 70 (entget lw))))) (append (cdr pl) (list (car pl))) (cdr pl))))
  (initget 1)
  (setq des (getstring "\nSpecify description : "))
  (while (not (snvalid des))
    (initget 1)
    (setq des (getstring "\nSpecify description : "))
  )
  (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar 'roamablerootprefix) "support\\") "pat" 1))
  (setq f (open fn "w"))
  (write-line (strcat "*" des ", " des) f)
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq x (caar li) y (cadar li))
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list x (+ y h)))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list (- x w) y))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list x (- y h)))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list (+ x w) y))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq l (distance (car li) (cadr li)))
    (setq ip (intrecsang minp w h a))
    (setq v (mapcar '- ip minp))
    (setq k 0)
    (while (not (and (equal (/ (* (setq k (1+ k)) (car v)) w) (fix (/ (* k (car v)) w)) 1e-6) (equal (/ (* k (cadr v)) h) (fix (/ (* k (cadr v)) h)) 1e-6))))
    (setq oo (mapcar '+ minp (mapcar '* v (list k k))))
    (setq g (- (- (distance minp oo) l)))
    (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
    (setq al (cons (cvunit a "radian" "degree") al))
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list (+ x w) y))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list x (+ y h)))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list (- x w) y))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list x (- y h)))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
    (setq al (cons (cvunit a "radian" "degree") al))
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list (+ x w) (+ y h)))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list (- x w) (+ y h)))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list (- x w) (- y h)))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list (+ x w) (- y h)))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
    (setq al (cons (cvunit a "radian" "degree") al))
    (cond
      ( (and (>= a 0.0) (< a (* 0.5 pi)))
        (setq no (list (- x w) (+ y h)))
      )
      ( (and (>= a (* 0.5 pi)) (< a pi))
        (setq no (list (- x w) (- y h)))
      )
      ( (and (>= a pi) (< a (* 1.5 pi)))
        (setq no (list (+ x w) (- y h)))
      )
      ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
        (setq no (list (+ x w) (+ y h)))
      )
    )
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
    (setq al (cons (cvunit a "radian" "degree") al))
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (setq nn (car (vl-sort (apply 'append ll) '(lambda ( a b ) (> (abs a) (abs b))))))
  (prompt "\nBiggest number is : ") (princ (rtos nn 2 20))
  (initget 6)
  (setq scf (getreal "\nSpecify scale factor - largest number must be smaller than 10000.0 <1.0> : "))
  (if (null scf)
    (setq scf 1.0)
  )
  (setq ll (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (/ y scf)) x)) ll))
  (setq k -1)
  (foreach li ll
    (setq k (1+ k))
    (if (zerop (last li))
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)))) f)
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)) "," (trim0trailing (rtos (nth 5 li) 2 8)) "," (trim0trailing (rtos (nth 6 li) 2 8)))) f)
    )
  )
  (close f)
  (princ)
)

 

Edited November 18, 2020 by marko_ribar

[BIGAL]

Thank you marko for further information.

 

I used hatchmaker followed the rules about the 1 unit sq snap 0.01 etc just did not work did not get anything like what I was aiming at, hatch pattern output is random. Version I used was CADALYST 10/05 Tip 2065: 

 

I was just trying to do a slot. The idea was to have more facets for the arc ends all objects were lines. There may be another variable setting that is causing incorrect pattern generation. What are your Units, snap, grid etc looking for something.

 

 

I will have a look at your code etc thanks again.

 

An example not working

*Uber,uber
180,0.46,0.62,0,1,0.25,-0.75
90,0.17,0.62,0,1,0.29,-0.71
0,0.17,0.37,0,1,0.25,-0.75

Edited May 1, 2020 by BIGAL

[eldon]

7 hours ago, BIGAL said:

An example not working

*Uber,uber
180,0.46,0.62,0,1,0.25,-0.75
90,0.17,0.62,0,1,0.29,-0.71
0,0.17,0.37,0,1,0.25,-0.75

Edited 7 hours ago by BIGAL

 

I think that the pattern definitions use the basic AutoCAD angle set up, i.e. zero is at East and the angles are anticlockwise. When you use the hatch command, the base angle is taken into account, but not the direction. I suspect that your units are set up for land surveying (?)

So with the above example, if the angles were to be altered for fundamental autocad setup:-

*Uber,uber
270,0.46,0.62,0,1,0.25,-0.75
0,0.17,0.62,0,1,0.29,-0.71
90,0.17,0.37,0,1,0.25,-0.75

 

you would get this:-

 

 

[eldon]

I am not sure that you can have a truly random hatch pattern, because their definition is a family of parallel lines, which means there is repeatability somewhere.

[steven-g]

ar-sand and ar-conc are about as random as you can get, each individual line of code in the .pat file is repeated with a series of dash-dots but when each line of code repeats at different distances and angles then it is difficult to 'see' the repeating pattern.

[eldon]

With the sand hatch, there are only four families of parallel lines, and with the dash intervals adroitly chosen, the appearance is random.

 

Moreover, if one draws these lines and explodes the hatch, the grips reveal that all dots do lie on these lines.

 

 

[marko_ribar]

Only to inform and give my contribution... It is possible - I did it, only with turned SNAP to 0.5...

In attachment is my LISP and pattern file...

savehatchfromstrlw-final-SNAP-0-5.lsp pol.pat

[BIGAL]

Thank you every one it was the units that was causing the problems so I will edit the hatchmaker to suit. Its almost there. Its something to do I think with the 0.1 snap.

 

marko sorry could not get it to work, please don't spend any more time on it. The pol pattern is a good starting point for me, that is more like what is required.

 

This was an answer for another post, I think I have enough now to work out what is actually going on, with regards to the post for moment easier to just use plines and array then group.

 

This is missing sections but close desired post answer is on right.

 

 

 

[TerryDotson]

Try the attached SLOT.PAT file, fresh off the farm.

Slot.pat

[marko_ribar]

On 5/2/2020 at 12:24 AM, marko_ribar said:

Only to inform and give my contribution... It is possible - I did it, only with turned SNAP to 0.5...

In attachment is my LISP and pattern file...

 

 

FWIW, The code can be much sorter, but still it is very unreliable...

 

(defun c:savehatchfromstrcur ( / trim0trailing trimlineto80chr unit projpt2p1p2 intrecsang s boundary ch i e minp maxp w h ww hh pl lil lili des fn f a x y no ip dx dy l v k kk oo g ll al nn scf loop fuzz )

  (vl-load-com)

  (defun trim0trailing ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (= (car lst) 48)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun trimlineto80chr ( str / lst )
    (setq lst (vl-string->list str))
    (setq lst (reverse lst))
    (while (>= (length lst) 80)
      (setq lst (cdr lst))
    )
    (setq lst (reverse lst))
    (vl-list->string lst)
  )

  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun projpt2p1p2 ( p p1 p2 / pp p1t ip )
    (setq pp (trans p 0 (unit (mapcar '- p2 p1))))
    (setq p1t (trans p1 0 (unit (mapcar '- p2 p1))))
    (setq ip (trans (list (car p1t) (cadr p1t) (caddr pp)) (unit (mapcar '- p2 p1)) 0))
    (setq ip (mapcar '+ '(0 0) ip))
  )

  (defun intrecsang ( minp w h a / r1 r2 r3 r4 d li ip )
    (setq r1 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list w 0.0))) (cons 10 (mapcar '+ minp (list w h))) (cons 10 (mapcar '+ minp (list 0.0 h))) '(210 0.0 0.0 1.0))))
    (setq r2 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list (- w) 0.0))) (cons 10 (mapcar '+ minp (list (- w) h))) (cons 10 (mapcar '+ minp (list 0.0 h))) '(210 0.0 0.0 1.0))))
    (setq r3 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list (- w) 0.0))) (cons 10 (mapcar '+ minp (list (- w) (- h)))) (cons 10 (mapcar '+ minp (list 0.0 (- h)))) '(210 0.0 0.0 1.0))))
    (setq r4 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 minp) (cons 10 (mapcar '+ minp (list w 0.0))) (cons 10 (mapcar '+ minp (list w (- h)))) (cons 10 (mapcar '+ minp (list 0.0 (- h)))) '(210 0.0 0.0 1.0))))
    (setq d (sqrt (+ (expt w 2) (expt h 2))))
    (setq li (entmakex (list '(0 . "LINE") (cons 10 (polar minp a 1e-4)) (cons 11 (polar minp a d)))))
    (cond
      ( (equal a 0.0 1e-6)
        (setq ip (polar minp 0.0 w))
      )
      ( (equal a (* 0.5 pi) 1e-6)
        (setq ip (polar minp (* 0.5 pi) h))
      )
      ( (equal a pi 1e-6)
        (setq ip (polar minp pi w))
      )
      ( (equal a (* 1.5 pi) 1e-6)
        (setq ip (polar minp (* 1.5 pi) h))
      )
      ( t
        (cond
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r1) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r2) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r3) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
          ( (setq ip (vlax-invoke (vlax-ename->vla-object r4) 'intersectwith (vlax-ename->vla-object li) acextendnone)) )
        )
      )
    )
    (mapcar 'entdel (list r1 r2 r3 r4 li))
    (setq ip (mapcar '+ '(0 0) ip))
  )

  (alert "SAVE DWG BEFORE APPLYING THIS ROUTINE...\nSet SNAP to ON and draw boundary rectangle and hatching geometry (lines + straight polygonal lwpolylines) inside boundary... SNAP must be 0.5x0.5...")
  (while
    (or
      (prompt "\nSelect boundary rectangle and hatching geometry...")
      (not (setq s (ssget '((-4 . "<or") (0 . "LINE") (-4 . "<and") (0 . "LWPOLYLINE") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>") (-4 . "and>") (-4 . "or>")))))
      (if s
        (not (equal (mapcar 'last (acet-geom-ss-extents-accurate s)) '(0.0 0.0) 1e-6))
      )
    )
    (prompt "\nEmpty sel set or selected geometry not planar with WCS...")
  )
  (setq boundary (ssname (ssget "_C" (car (acet-geom-ss-extents-accurate s)) (car (acet-geom-ss-extents-accurate s)) '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))) 0))
  (initget "Yes No")
  (setq ch (getkword "\nDo you want to implement boundary into hatch [Yes/No] <No> : "))
  (if (or (= ch "No") (null ch))
    (ssdel boundary s)
  )
  (vla-getboundingbox (vlax-ename->vla-object boundary) 'minp 'maxp)
  (mapcar 'set '(minp maxp) (mapcar 'safearray-value (list minp maxp)))
  (setq w (- (car maxp) (car minp)) h (- (cadr maxp) (cadr minp)))
  (repeat (setq i (sslength s))
    (setq e (ssname s (setq i (1- i))))
    (cond
      ( (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
        (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget e))))
        (setq lil (mapcar '(lambda ( a b ) (list a b)) pl (if (= 1 (logand 1 (cdr (assoc 70 (entget e))))) (append (cdr pl) (list (car pl))) (cdr pl))))
        (setq pl nil)
      )
      ( t
        (setq lili (cons (list (mapcar '+ '(0 0) (cdr (assoc 10 (entget e)))) (mapcar '+ '(0 0) (cdr (assoc 11 (entget e))))) lili))
      )
    )
  )
  (if lili
    (setq lil (append lil lili))
  )
  (initget 1)
  (setq des (getstring "\nSpecify description : "))
  (while (not (snvalid des))
    (initget 1)
    (setq des (getstring "\nSpecify description : "))
  )
  (setq fn (getfiled "Specify PATTERN file..." (strcat (getvar 'roamablerootprefix) "support\\") "pat" 1))
  (setq f (open fn "w"))
  (write-line (strcat "*" des ", " des) f)
  (foreach li lil
    (setq a (angle (car li) (cadr li)))
    (setq x (caar li) y (cadar li))
    (setq l (distance (car li) (cadr li)))
    (setq ip (intrecsang minp w h a))
    (setq v (mapcar '- ip minp))
    (setq k 0)
    (while (and (setq k (1+ k)) (not (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) 5e-12) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) 5e-12)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) 5e-12) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) 5e-12))))))
    (setq oo (mapcar '+ minp (mapcar '* v (list k k))))
    (setq g (- (- (distance minp oo) l)))
    (setq ww (* w (fix (if (minusp (car v)) (- (/ (* k (car v)) w) 0.01) (+ (/ (* k (car v)) w) 0.01)))))
    (setq hh (* h (fix (if (minusp (cadr v)) (- (/ (* k (cadr v)) h) 0.01) (+ (/ (* k (cadr v)) h) 0.01)))))
    (setq oo (mapcar '+ minp (list ww hh)))
    (setq no (mapcar '+ oo (mapcar '- (car li) minp)))
    (setq ip (projpt2p1p2 no (car li) (cadr li)))
    (setq fuzz 5e-12 kk k)
    (if (and (or (equal (/ (* 1 (abs (car v))) w) (fix (/ (* 1 (abs (car v))) w)) fuzz) (equal (/ (* 1 (abs (car v))) w) (fix (1+ (/ (* 1 (abs (car v))) w))) fuzz)) (or (equal (/ (* 1 (abs (cadr v))) h) (fix (/ (* 1 (abs (cadr v))) h)) fuzz) (equal (/ (* 1 (abs (cadr v))) h) (fix (1+ (/ (* 1 (abs (cadr v))) h))) fuzz)))
      (progn
        (setq k 1)
        (setq oo (mapcar '+ minp (mapcar '* v (list k k))))
        (setq g (- (- (distance minp oo) l)))
        (setq ww (* w (fix (if (minusp (car v)) (- (/ (* k (car v)) w) 0.01) (+ (/ (* k (car v)) w) 0.01)))))
        (setq hh (* h (fix (if (minusp (cadr v)) (- (/ (* k (cadr v)) h) 0.01) (+ (/ (* k (cadr v)) h) 0.01)))))
        (setq oo (mapcar '+ minp (list ww hh)))
        (setq no (mapcar '+ oo (mapcar '- (car li) minp)))
        (setq ip (projpt2p1p2 no (car li) (cadr li)))
      )
    )
    (if (not (and (not (equal no ip 1e-6)) (not (equal (car li) ip 1e-6))))
      (progn
        (while (and (< fuzz 0.5) (= k kk))
          (setq fuzz (* fuzz (sqrt 2.0)) k 0)
          (setq loop t)
          (while loop
            (while (and (setq k (1+ k)) (/= k kk) (not (and (or (equal (/ (* k (abs (car v))) w) (fix (/ (* k (abs (car v))) w)) fuzz) (equal (/ (* k (abs (car v))) w) (fix (1+ (/ (* k (abs (car v))) w))) fuzz)) (or (equal (/ (* k (abs (cadr v))) h) (fix (/ (* k (abs (cadr v))) h)) fuzz) (equal (/ (* k (abs (cadr v))) h) (fix (1+ (/ (* k (abs (cadr v))) h))) fuzz))))))
            (if (/= k kk)
              (progn
                (setq ww (* w (fix (if (minusp (car v)) (- (/ (* k (car v)) w) 0.01) (+ (/ (* k (car v)) w) 0.01)))))
                (setq hh (* h (fix (if (minusp (cadr v)) (- (/ (* k (cadr v)) h) 0.01) (+ (/ (* k (cadr v)) h) 0.01)))))
                (setq oo (mapcar '+ minp (list ww hh)))
                (setq no (mapcar '+ oo (mapcar '- (car li) minp)))
                (setq ip (projpt2p1p2 no (car li) (cadr li)))
              )
            )
            (if (or (and (not (equal no ip 1e-6)) (not (equal (car li) ip 1e-6))) (= k kk))
              (setq loop nil)
            )
          )
        )
        (if (not (and (not (equal no ip 1e-6)) (not (equal (car li) ip 1e-6))))
          (progn
            (cond
              ( (and (>= a 0.0) (< a (* 0.5 pi)))
                (setq no (list x (+ y h)))
              )
              ( (and (>= a (* 0.5 pi)) (< a pi))
                (setq no (list (- x w) y))
              )
              ( (and (>= a pi) (< a (* 1.5 pi)))
                (setq no (list x (- y h)))
              )
              ( (and (>= a (* 1.5 pi)) (< a (* 2 pi)))
                (setq no (list (+ x w) y))
              )
            )
            (setq ip (projpt2p1p2 no (car li) (cadr li)))
          )
        )
      )
    )
    (setq dx (if (equal (angle (car li) ip) a 1e-6) (distance (car li) ip) (- (distance (car li) ip))))
    (setq dy (if (equal (angle ip no) (if (> (+ a (* 0.5 pi)) (* 2 pi)) (- (+ a (* 0.5 pi)) (* 2 pi)) (+ a (* 0.5 pi))) 1e-6) (distance no ip) (- (distance no ip))))
    (setq ll (cons (list (cvunit a "radian" "degree") x y dx dy l g) ll))
    (setq al (cons (cvunit a "radian" "degree") al))
  )
  (setq ll (reverse ll))
  (setq al (reverse al))
  (setq nn (car (vl-sort (apply 'append ll) '(lambda ( a b ) (> (abs a) (abs b))))))
  (prompt "\nBiggest number is : ") (princ (rtos nn 2 20))
  (initget 6)
  (setq scf (getreal "\nSpecify scale factor for multiplication hatch data <1.0> : "))
  (if (null scf)
    (setq scf 1.0)
  )
  (setq ll (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (* y scf)) x)) ll))
  (setq k -1)
  (foreach li ll
    (setq k (1+ k))
    (if (zerop (last li))
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)))) f)
      (write-line (trimlineto80chr (strcat (trim0trailing (rtos (nth k al) 2 8)) "," (trim0trailing (rtos (cadr li) 2 8)) "," (trim0trailing (rtos (caddr li) 2 8)) "," (trim0trailing (rtos (nth 3 li) 2 8)) "," (trim0trailing (rtos (nth 4 li) 2 8)) "," (trim0trailing (rtos (nth 5 li) 2 8)) "," (trim0trailing (rtos (nth 6 li) 2 8)))) f)
    )
  )
  (close f)
  (princ)
)

 

Edited November 18, 2020 by marko_ribar

[BIGAL]

TerryDotson that is the pattern type only difference is spacing is a bit more. But so close. Gives the values which are so close so hopefully can work backwards. Where did you get it from ?

 

This is what is desired plan view

 

 

 

Edited May 2, 2020 by BIGAL

[marko_ribar]

Alan H., why do you need pat file for this - you have very long profile or ??? And beside this you have arcs at both sides of holes - I'd rather draw it with arcs and array them in one direction... BTW. You can now try my routine if you need it from straight segments, just be sure you set SNAP to 0.5x0.5 for both boundary and shape... Choose default "No" for gen boundary net...

 

[EDIT : When I think twice, you can easily create dynamic block with array action in one direction plus you'll have arcs too...]

Edited May 3, 2020 by marko_ribar

[hugha]

BIGAL,  try the attached.

 

14x28 semicircular ended slots @ 50 centres,  runs spaced 300 apart.   

 

 

hth,

Hugh Adamson

www.hatchkit.com.au

 

Entities.pat

[BIGAL]

Hi Marko I agree almost gave up and do it same way using array and group adding outside lines so get a beam with slots, the original post issue is with dynamic block you can not trim say a 1/2 slot  to reflect true beam length. 

 

Thanks hugha will look further into that pattern its certainly almost there. Will look into hatchkit. The insert point needs to be set and it works perfect. There are some small discrepancy in the curve straights. I use a arctochords.lsp so ends are correct need to zoom in close to see but not a problem.

 

 

Arc-to chords.lsp

Edited May 4, 2020 by BIGAL

[BIGAL]

Again thank you every one 

 

 

[marko_ribar]

AFAIK, you can use dynamic block with array action in one direction, then stretch it beyound boundary and finally you should be able to clip it with CLIPIT command to the boundary rectangle... Have you tried this?

 

HTH., M.R.

[marko_ribar]

Just an addend to CLIPIT command... To remove clipping you also have XCLIP command, just use it, select clipped block and choose "Delete"...

 

HTH., M.R.