[b_anton]

Доброго вечера!

Мастера нужна помощь в написании лиспа. Имеется некий многоугольник в виде полилинии. Хочется построить прямоугольники в количестве равном количеству сторон многоугольника. Ширина каждого прямоугольника равна длине каждой стороны многоугольника. Высота одинаковая и вводится руками. Прямоугольники распологаюся через определенное растояние (например через 1000 мм) на одной линии с базовой точкой указанной на экране.
И (если это возможно) хотелось бы добавить обозначение углов многоугольника в соответствие с обозначением углов прямоугольников.

Заранее спасибо за любую помощь!
ACAD 2010

результат на картинке. (ЗЫ: простановка размеров не нужна - они для понимания)

[gomer]

Сообщение от b_anton нужна помощь в написании

А что сложного-то?

[b_anton]

Лисп не знаю...

[gomer]

Изучайте или сюда

[Олег (jr.)]

Попробуй такой вариант без особых поверок

Код:

[Выделить все]

;; fixo () 2013 * all rights removed 
(defun c:rets (/ *error* a cnt coords gap hgt num p pline q sides sset wid)
  (defun *error*  (msg)
      (command "_undo" "_end")
      (command)
      (if (and msg
	       (wcmatch	msg
			"Function cancelled,quit / exit abort,console break"))
	(princ
	  (strcat "\nError: " msg)
	  )
	)
    (setvar "nomutt" 0)
      )
   ;; 			основная чaсть программы			 ;;
  (princ "\nВыбрать полигон")
  (setvar "nomutt" 1)

  (if (setq sset (ssget "_:S:L:E" (list (cons 0 "lwpolyline"))))
    (progn
      (setvar "nomutt" 0)
      (command "_undo" "_begin")
      (setq pline (ssname sset 0))
      (setq coords (vl-remove-if
		     'not
		     (mapcar '(lambda (a)
				(if (eq 10 (car a))
				  (cdr a)
				) ;_ end of if
			      ) ;_ end of lambda
			     (entget pline)
		     ) ;_ end of mapcar
		   ) ;_ end of vl-remove-if
      ) ;_ end of setq
      (setq sides (mapcar '(lambda (p q) (distance p q))
			  coords
			  (append (cdr coords) (list (car coords)))
		  ) ;_ end of mapcar
      ) ;_ end of setq
      (setq num (length sides))
      (setq hgt (getdist "\nВысота прямоугольников: "))
      (setq gap (getdist "\nРасстояние между прямоугольниками: "))
      (setq p (getpoint "\nПервая точка: "))
      (setq cnt 0)
      (repeat num
	(setq wid (nth cnt sides))
	(entmakex
	  (append
	    (list '(0 . "LWPOLYLINE")
		  '(100 . "AcDbEntity")
		  '(100 . "AcDbPolyline")
		  '(90 . 4)
		  '(70 . 1)
		  (cons 10 (setq p (trans p 1 0)))
	    ) ;_ end of list
	    (mapcar
	      (function (lambda (x) (cons 10 (mapcar '+ p x))))
	      (list (list wid 0. 0.) (list wid hgt 0.) (list 0. hgt 0.))
	    ) ;_ end of mapcar

	  ) ;_ end of append
	) ;_ end of entmakex
	(setq p (mapcar '+ p (trans (list (+ wid gap) 0. 0.) 1 0)))
	(setq cnt (1+ cnt))
      ) ;_ end of repeat
    ) ;_ end of progn
  ) ;_ end of if
(*error* nil)
  (princ)
) ;_ end of defun
(prompt "\n\t---\tСтарт команды: RETS  \t---")
(prin1)

[b_anton]

Олег (jr.), благодарю! все работает как и хотел косяков не выявлено

Подскажите, а если в контуре будет присутствовать дуговой сегмент как построить прямоугольник шириной равной длине дуги сегмента?

[Олег (jr.)]

Сообщение от b_anton Подскажите, а если в контуре будет присутствовать дуговой сегмент как построить прямоугольник шириной равной длине дуги сегмента?

Тоже несложно но лучше тогда использовать
функции ActiveX чтобы легче разобрать контур на сегменты,
потом покажу, если кто раньше не сделает

[b_anton]

ок, спасибо!

[Олег (jr.)]

Переделал из старой рутины, начинает вставлять прямоугольники
с первого указанного, включая выпуклые сегменты

Код:

[Выделить все]

;;; Programm for the dimensioning of all the polygon/polyline segments
;;; and creating the running rectangles by length of every segment
;;; Polyline must be closed or opened
;;; Copyrights (c) 2005 Fatty T.O.H. * all rights removed
;;; A2005 / Windows XP / 7
;;; Thanks to Matt W. for the correction

;;; possible macro for button:
;;; ^C^C^P(progn (terpri)(if (not C:RECS)(load "RECS.lsp"))(princ)(C:RECS))
 
(defun C:RECS (/ *Error* ;|*Debug*|;  acsp adoc cnt coors epar get-vexs gap group-by-num hgt num p pick pl pos q range segm sides spar ss wid)
;Fatty () 2005  
;thanks to Robert R.Bell for the credit of error handler function
  (vl-load-com)
  (defun *Error* (msg)
    
  (cond	((not msg))
	((member msg '("Function cancelled" "quit / exit abort")))
	((princ (strcat "\nError: " msg))
	 ;|(cond (*Debug* (vl-bt)))|; ; for debug only
	)
  )
(setvar "nomutt" 0)
  (vla-endundomark
	(vla-get-activedocument (vlax-get-acad-object))
      )
)

  ;; helpers : 

  ;; gile
    (defun range (lst from to / result)
  (repeat (1+ (- (setq to (min (1- (length lst)) to)) from))
    (setq result (cons (nth to lst) result)
	  to	 (1- to)
    ) ;_ end of setq
  ) ;_ end of repeat
  result
) ;_ end of defun
  
  (if (< (atof (getvar "ACADVER")) 15.06)(progn
  (alert "Impossible to use this lisp \nin version less than A2000")(exit)(princ))
  (progn
  (vl-load-com)
  (or adoc (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (or acsp (setq acsp
		  (if (or (= (getvar "TILEMODE") 1)
			  (> (getvar "CVPORT") 1))
  (vla-get-modelspace adoc)
  (vla-get-paperspace adoc)
  )
	)
      )
  ;; 			основная чaсть программы			 ;;
  (princ "\nВыбрать полигон")
  (setvar "nomutt" 1)
  (if 
  (setq ss (ssget "_:S:E:L" '((0 . "*POLYLINE"))))
  (progn
   (vla-startundomark adoc)
   (setvar "nomutt" 0)
  (setq	pl (vlax-ename->vla-object (setq pline (ssname ss 0))))
 (setq pick(cadr (last (last (ssnamex ss)))))
 
      (setq pick (vlax-curve-getclosestpointto pl pick))
      (setq pos (fix (vlax-curve-getparamatpoint pl pick)))
   (setq epar (vlax-curve-getendparam pl)
	 spar (vlax-curve-getstartparam pl)
	 sides nil)
   
   (while (< spar epar)
     (setq segm (- (vlax-curve-getdistatparam pl (1+ spar))(vlax-curve-getdistatparam pl spar)))
     (setq sides (cons segm sides))
     (setq spar (1+ spar)))
     (setq sides (reverse sides))

      (if (not (zerop pos))
	(setq sides (append (range sides pos (1- (length sides)))(range sides 0 (- pos 1))))
	)
      (setq num (length sides))
      (setq hgt (getdist "\nВысота прямоугольников: "))
      (setq gap (getdist "\nРасстояние между прямоугольниками: "))
      (setq p (getpoint "\nПервая точка: "))
      (setq cnt 0)
      (repeat num
	(setq wid (nth cnt sides))
	(entmakex
	  (append
	    (list '(0 . "LWPOLYLINE")
		  '(100 . "AcDbEntity")
		  '(100 . "AcDbPolyline")
		  '(90 . 4)
		  '(70 . 1)
		  (cons 10 (setq p (trans p 1 0)))
	    ) ;_ end of list
	    (mapcar
	      (function (lambda (x) (cons 10 (mapcar '+ p x))))
	      (list (list wid 0. 0.) (list wid hgt 0.) (list 0. hgt 0.))
	    ) ;_ end of mapcar

	  ) ;_ end of append
	) ;_ end of entmakex
	(setq p (mapcar '+ p (trans (list (+ wid gap) 0. 0.) 1 0)))
	(setq cnt (1+ cnt))
      ) ;_ end of repeat 
  	)
  	)
	)
	)
  (*Error* nil)  
  (princ)
)
 
(prompt "\n\t---\tСтарт команды: RECS  \t---")
(prin1)
 (or (vl-load-com)(princ))

[b_anton]

Олег в последнем коде не добавляли работу с дуговыми с сегментами?

[Олег (jr.)]

А ты сам проверь

[b_anton]

Проверил. Прямоугольник строит по хорде, не по длине дуги

[Олег (jr.)]

Сообщение от b_anton Проверил. Прямоугольник строит по хорде, не по длине дуги

Правильно, надо переделать, сейчас времени нет потом

[b_anton]

благодарен за помощь

[Олег (jr.)]

Проверь код выложенный выше снова,
добавил для всех сегментов, не тестировал !

[b_anton]

Есть небольшой баг - один из прямоугольников строится шириной равной периметру контура минус длина сегмента для которого строится прямоугольник.

[Олег (jr.)]

Сообщение от b_anton Есть небольшой баг - один из прямоугольников строится шириной равной периметру контура минус длина сегмента для которого строится прямоугольник.

Опять попробуй, вроде проверил все

[b_anton]

Олег (jr.) все работает четко! Благодарю, очень сильно выручил с этим лиспом!

[Олег (jr.)]

Пожалуйста, рад помочь когда могу

[b_anton]

Потом сам попробую нумерацию добавить, может чего получиться