Linetype handle

August 19, 2015

Hello,

I've been learning about lisps for the three month .

I have a idea , and completed 90% , I met difficult problem .

Here is a Demo

Problem

Invisible Line is Dashed , OK, No problem.

Visible line must be Continuous , not Dashed .

(defun c:pps  (/ mm_lay pi2 2pi 3pi2 les i pltlr pltud clt plt
		obj info ac0 dr40 pt10 starc edarc pt11 pt10s p10
		n alist alist1 alist2 lft rht upt dnt cor1 cor2 cor3
		cor4 pcenter locat key xcor1 xcor2 xcor3 xcor4 plistn
		loc1 loc2 locat2 locn1 locn2 lcline0 clocat clocat2
		lcline1 lcline2 celine0 celine1 celine2 pt1 pt2
		oldline pt1 pt2 pt3 pt0 *error* erases mvs vxs)
		
(defun erases (ss / i) 
(setq i -1)
(repeat (sslength ss)
	(entdel (ssname ss (setq i (1+ i))))
)
)

(defun mvs (lst / a lst2)  
(while (setq a (car lst) lst2 (cons a lst2) lst (vl-remove a lst)))
(reverse lst2)
)

(defun vxs (e / i v lst)
(setq i -1)
(while
	(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
	(setq lst (cons v lst))
)
(reverse lst)
)

(defun *error*(s)  
(setvar 'cmdecho 0)
(command "_.undo" "e")
(setvar 'cmdecho 1)
(redraw)
)

(if (null (tblsearch "layer" "03centreline"))
	(progn (setq mm_lay (getvar "CLAYER"))
		(setvar "cmdecho" 0)
		(command "_layer" "m" "03centreline" "c" "1" "" "l" "center" "" "lw" "0.18" "03centreline" "")
		(setvar "cmdecho" 1)
		(setvar "clayer" mm_lay)
	)
)
	
(if (null (tblsearch "layer" "04dashed"))
		(progn (setq mm_lay (getvar "CLAYER"))
			(setvar "cmdecho" 0)
			(command "_layer" "m" "04dashed" "c" "2" "" "l" "DASHED" "" "lw" "0.18" "04dashed" "")
			(setvar "cmdecho" 1)
			(setvar "clayer" mm_lay)
		)
)
(setq pi2 (/ pi 2))
(setq 2pi (* pi 2))
(setq 3pi2 (/ (* 3 pi) 2))
(setq les (ssget '((0 . "LINE,CIRCLE,ARC,LWPOLYLINE")
				(-4 . "<NOT")
				(8 . "*03centreline*")
				(-4 . "NOT>")
				)
		)
)
(setq i 0)
(repeat (sslength les)
	(setq obj (ssname les i))
	(setq info (entget obj))
	(setq ac0 (cdr (assoc 0 info)))
	(cond
		((= ac0 "CIRCLE")
		(progn
			(setq dr40 (cdr (assoc 40 info)))
			(setq pt10 (cdr (assoc 10 info)))
			(setq clt (cons pt10 clt))
			(setq pltlr (cons (polar pt10 0 dr40)
							(cons (polar pt10 pi dr40) pltlr)
						)
			)
			(setq pltud (cons (polar pt10 pi2 dr40)
							(cons (polar pt10 3pi2 dr40) pltud)
						)
			)
		);end_progn
		)

		((= ac0 "ARC")
				(setq dr40 (cdr (assoc 40 info)))
				(setq pt10 (cdr (assoc 10 info)))
				;; (setq clt (cons pt10 clt))
				(setq starc (cdr (assoc 50 info)))
				(setq edarc (cdr (assoc 51 info)))

				(if
					(or
						(and (= starc 0) (= edarc pi))
						(and (= starc pi) (= edarc 0))
						(and (= starc pi2) (= edarc 3pi2))
						(and (= starc 3pi2) (= edarc pi2))
					)
					(setq clt (cons pt10 clt))
				)
					(cond
						((or
							
							(and (<= starc pi2) (<= pi2 edarc) (< edarc 3pi2))
							(and (<= pi2 edarc) (< edarc 3pi2 starc))
						)
						(setq pltud (cons (polar pt10 pi2 dr40) pltud))
						)

						((or
							(and (<= starc pi2) (>= edarc 3pi2))
							(and (<= starc pi2) (< edarc pi2))
							(and (> starc 3pi2) (>= edarc 3pi2))
						)
						(setq        pltud (cons (polar pt10 pi2 dr40)
											(cons (polar pt10 3pi2 dr40) pltud)
											)
						)
						)

						((<= pi2 edarc starc 3pi2)
							(setq        pltud (cons (polar pt10 pi2 dr40)
												(cons (polar pt10 3pi2 dr40) pltud)
											  )
							)
						)

						((and
							(> starc pi2)
							(<= starc 3pi2)
							(or (>= edarc 3pi2) (and (>= edarc 0) (< edarc pi2)))
						  )
						(setq pltud (cons (polar pt10 3pi2 dr40) pltud))
						)
					)

					(cond
						((and (<= starc pi edarc) (> starc 0))
								(setq pltlr (cons (polar pt10 pi dr40) pltlr))
						)

						((<= pi edarc starc)
							(setq        pltlr (cons (polar pt10 0 dr40)
												(cons (polar pt10 pi dr40) pltlr)
												)
							)
						)

						((>= pi starc edarc)
							(setq        pltlr (cons (polar pt10 0 dr40)
												(cons (polar pt10 pi dr40) pltlr)
												)
							)
						)

						((< edarc pi starc)
							(setq pltlr (cons (polar pt10 0 dr40) pltlr))
						)

					)
		)
				

				((= ac0 "LINE")
					(setq pt10 (cdr (assoc 10 info)))
					(setq pt11 (cdr (assoc 11 info)))
					(setq plt (cons pt10 (cons pt11 plt)))
				)

				((= ac0 "LWPOLYLINE")
					(setq pt10s (vxs obj))
					(setq plt (append pt10s plt))
				)

	);end_cond
			(setq i (1+ i))
);end_repeat
(setq alist (append plt pltlr pltud))
(setq
	alist1
	(vl-sort alist
		(function (lambda (e1 e2) (< (car e1) (car e2))))
	)
)
(setq lft (car alist1))
(setq rht (car (reverse alist1)))
(setq        alist2
			(vl-sort alist
				(function (lambda (e1 e2) (> (cadr e1) (cadr e2))))
			)
)
(setq upt (car alist2))
(setq dnt (car (reverse alist2)))
(setq alist1 (mvs alist1))
(setq alist2 (mvs alist2))
(setq cor1 (mapcar '+
			(mapcar '* lft '(1 0 1))
			(mapcar '* upt '(0 1 1))
			)
)
(setq cor2 (mapcar '+
			(mapcar '* lft '(1 0 1))
			(mapcar '* dnt '(0 1 1))
			)
)
(setq cor3 (mapcar '+
			(mapcar '* rht '(1 0 1))
			(mapcar '* upt '(0 1 1))
		)
)
(setq cor4 (mapcar '+
			(mapcar '* rht '(1 0 1))
			(mapcar '* dnt '(0 1 1))
		)
)
		
(setq pcenter (inters cor1 cor4 cor3 cor2 nil))
		
(setq locat (getpoint pcenter "\nProjection position:"))
		
(if (> (abs (- (car locat) (car pcenter)))
			(abs (- (cadr locat) (cadr pcenter)))
	)
(setq key 0)
;;;x dir
(setq key 1)
;;;y dir
)
		
(cond
	((= key 0)
	(setq
		xcor1 (mapcar '+ cor1 '(99999 0 0))
		xcor2 (mapcar '+ cor2 '(99999 0 0))
		xcor3 (mapcar '+ cor3 '(-99999 0 0))
		xcor4 (mapcar '+ cor4 '(-99999 0 0))
	)
	(grdraw xcor1 xcor3 1 1)
	(grdraw xcor2 xcor4 1 1)
	)
	((= key 1)
		(setq
			xcor1 (mapcar '+ cor1 '(0 99999 0))
			xcor2 (mapcar '+ cor2 '(0 -99999 0))
			xcor3 (mapcar '+ cor3 '(0 99999 0))
			xcor4 (mapcar '+ cor4 '(0 -99999 0))
		)
		(grdraw xcor1 xcor2 1 1)
		(grdraw xcor3 xcor4 1 1)
	)
);end_cond
		
(cond
	((= key 0)
	(setq plistn (append plt pltud))
	(setq loc1  (mapcar        '+
				(mapcar '* locat '(1 0 1))
				(mapcar '* upt '(0 1 1))
				)
	)
	(setq loc2        (mapcar        '+
	(mapcar '* locat '(1 0 1))
	(mapcar '* dnt '(0 1 1))
					)
	)
	)
	((= key 1)
		(setq plistn (append plt pltlr))
			(setq loc1 (mapcar        '+
                       (mapcar '* locat '(0 1 1))
                       (mapcar '* lft '(1 0 1))
						)
			)
			(setq loc2 (mapcar        '+
						(mapcar '* locat '(0 1 1))
						(mapcar '* rht '(1 0 1))
						)
			)
	)
);end_cond
(grdraw loc1 loc1 1 1)
		
(setq locat2 (getpoint locat "\nWidth:"))
		(cond
			((= key 0)
				(setq locn1 (mapcar '+
					(mapcar '* locat2 '(1 0 1))
					(mapcar '* upt '(0 1 1))
							)
				)
				(setq locn2 (mapcar '+
					(mapcar '* locat2 '(1 0 1))
					(mapcar '* dnt '(0 1 1))
							)		
				)
				(setq lcline0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) plistn))
				(if (> (car locat) (car locat2))
					(setq clocat  locat
						clocat2 locat2
					)
					(setq clocat  locat2
						clocat2 locat
					)
				)
				(setq lcline1
					(mapcar
						'(lambda (x) (mapcar '+ x (mapcar '* locat '(1 0 1))))
						lcline0
					)
				)
				(setq lcline2
					(mapcar
						'(lambda (x) (mapcar '+ x (mapcar '* locat2 '(1 0 1))))
						lcline0
					)
				)
				(setq celine0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) clt))
				(setq celine1
					(mapcar
						'(lambda (x)
							(mapcar '+ x '(10 0 0) (mapcar '* clocat '(1 0 1)))
						)
						celine0
					)
				)
				(setq
					celine2 (mapcar '(lambda        (x)
						(mapcar '+
							x
							'(-10 0 0)
							(mapcar '* clocat2 '(1 0 1))
						)
					)
					celine0
					)
				)
			)
			((= key 1)
				(setq locn1 (mapcar '+
					(mapcar '* locat2 '(0 1 1))
					(mapcar '* lft '(1 0 1))
				)
				)
				(setq locn2 (mapcar '+
					(mapcar '* locat2 '(0 1 1))
					(mapcar '* rht '(1 0 1))
				)
				)
				(setq
				lcline0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) plistn))
				(if (> (cadr locat) (cadr locat2))
					(setq clocat  locat
						clocat2 locat2
					)
					(setq clocat  locat2
						clocat2 locat
					)
				)
				(setq lcline1
					(mapcar
						'(lambda (x) (mapcar '+ x (mapcar '* locat '(0 1 1))))
						lcline0
					)
				)
				(setq lcline2
					(mapcar
						'(lambda (x) (mapcar '+ x (mapcar '* locat2 '(0 1 1))))
						lcline0
					)
				)
				(setq celine0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) clt))
				(setq celine1
					(mapcar
						'(lambda (x)
							(mapcar '+ x '(0 10 0) (mapcar '* clocat '(0 1 1)))
						)
						celine0
					)
				)
				(setq
					celine2 (mapcar '(lambda        (x)
						(mapcar '+
							x
							'(0 -10 0)
							(mapcar '* clocat2 '(0 1 1))
						)
					)
					celine0
					)
				)
			)
		)
		(grdraw locn1 locn1 1 1)
		
		(setvar "cmdecho" 0)
		(command "_.undo" "be")
		(entmake (list '(0 . "line")
			'(8 . "0")
			(cons 10 loc1)
			(cons 11 loc2)
		)
		)
		(entmake (list '(0 . "line")
			'(8 . "0")
			(cons 10 locn1)
			(cons 11 locn2)
		)
		)
		
		(repeat
			(length plistn)
			(setq pt1 (car lcline1))
			(setq lcline1 (cdr lcline1))
			(setq pt2 (car lcline2))
			(setq lcline2 (cdr lcline2))
			(setq oldline (ssget "_w" pt1 pt2))
			
			(if (and (/= oldline nil) (/= (sslength oldline) 0))
				(erases oldline)
			)
			
			(entmake (list '(0 . "line")
                   '(8 . "04dashed")
                   (cons 10 pt1)
                   (cons 11 pt2)
			)
			)
		)
		
		(repeat (length clt)
			(setq pt1 (car celine1))
			(setq celine1 (cdr celine1))
			(setq pt2 (car celine2))
			(setq celine2 (cdr celine2))
			(setq oldline (ssget "_w" pt1 pt2))
			
			(if        (and (/= oldline nil) (/= (sslength oldline) 0))
				(erases oldline)
			)
			
			(entmake (list '(0 . "line")
				'(8 . "03centreline")
				(cons 10 pt1)
				(cons 11 pt2)
			)
			)
		)
		(setq oldline (ssget "_w" loc1 locn1))
		
		(if (and (/= oldline nil) (/= (sslength oldline) 0))
			(erases oldline)
		)
		
		(entmake (list '(0 . "line")
			'(8 . "0")
			(cons 10 loc1)
			(cons 11 locn1)
		)
		)
		(setq oldline (ssget "_w" loc2 locn2))
		
		(if (and (/= oldline nil) (/= (sslength oldline) 0))
			(erases oldline)
		)
		
		(entmake (list '(0 . "line")
			'(8 . "0")
			(cons 10 loc2)
			(cons 11 locn2)
		)
		)
		(command "_.undo" "e")
		(setvar "cmdecho" 0)
		(prin1)
)

Projection.lsp

August 19, 2015

Either both should be dashed, or both should be continuous, or something third... You are projecting right side viewed from left so according to you dash is OK on the first picture and then you are doing projection down side viewed from top so that edge is visible... You should take some kind of standard of projection - that is fine if you are doing it like it's shown on animated gif, but then you should consider visibility problems... And are you always projecting simple geometric shapes like that... If that's the case then consider entmaking bounding box rectangle and find intersection between it an shape... With your way of projection if points - intersections between bonding box and shape are on left/up edge of bounding box then projecting line should be continuous and opposite if on right/down edge then it should be dashed... Points that don't intersect with bounding box rectangle are always dashed... So when building point lists for projecting make elements of lists ((x y z) "cont") or ((x y z) "dash") so that you can obtain correct (cadr listelement) key according to which routine should determine what type of line layer should be used during entmake line entities...

August 19, 2015

@marko_ribar

Thanks for your reply . Seemingly very complex and beyond my ability.

If anyone is interested, Please help me modify it . Thanks.

August 19, 2015

Rosamund, look I can't modify your code, but fortunately it happens that I have similar one in my library that I think it's better than your... I'll attach both my lisp and animated gif... HTH, M.R.

statproj.lsp

August 20, 2015

Rosamund, look I can't modify your code, but fortunately it happens that I have similar one in my library that I think it's better than your... I'll attach both my lisp and animated gif... HTH, M.R.

@marko_ribar

I appreciate your support , your Demo is too small. Can't enlarge?

Sign In

Linetype handle

Recommended Posts

Rosamund Kwan

marko_ribar

Rosamund Kwan

marko_ribar

Rosamund Kwan

Join the conversation

Tutorials

Forums

Activity